From b23b160c4e2cff83e87815dcbc3543922bbe75da Mon Sep 17 00:00:00 2001
From: Kevin Gasperich
Date: Wed, 28 Jun 2023 14:32:55 -0500
Subject: [PATCH 001/140] ormas bitmask ezfio
---
src/bitmask/EZFIO.cfg | 24 ++++++++++++++++++++++++
1 file changed, 24 insertions(+)
diff --git a/src/bitmask/EZFIO.cfg b/src/bitmask/EZFIO.cfg
index 9d713304..25812ca0 100644
--- a/src/bitmask/EZFIO.cfg
+++ b/src/bitmask/EZFIO.cfg
@@ -3,3 +3,27 @@ type: integer
doc: Number of active |MOs|
interface: ezfio
+[ormas_n_space]
+type: integer
+doc: Number of active spaces
+interface: ezfio, provider, ocaml
+default: 1
+
+[ormas_mstart]
+type: integer
+doc: starting orb for each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio, provider, ocaml
+
+[ormas_min_e]
+type: integer
+doc: min number of electrons in each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio, provider, ocaml
+
+[ormas_max_e]
+type: integer
+doc: max number of electrons in each ORMAS space
+size: (bitmask.ormas_n_space)
+interface: ezfio, provider, ocaml
+
From 56d5843210099a2c7ba84951737e276a3677ce1c Mon Sep 17 00:00:00 2001
From: Kevin Gasperich
Date: Wed, 28 Jun 2023 18:23:10 -0500
Subject: [PATCH 002/140] ormas bitmasks
---
src/bitmask/EZFIO.cfg | 15 +-
src/bitmask/bitmasks_ormas.irp.f | 209 ++++++++++++++++++++++++++
src/cipsi/selection.irp.f | 5 +
src/cipsi_tc_bi_ortho/selection.irp.f | 5 +
4 files changed, 231 insertions(+), 3 deletions(-)
create mode 100644 src/bitmask/bitmasks_ormas.irp.f
diff --git a/src/bitmask/EZFIO.cfg b/src/bitmask/EZFIO.cfg
index 25812ca0..13007509 100644
--- a/src/bitmask/EZFIO.cfg
+++ b/src/bitmask/EZFIO.cfg
@@ -3,6 +3,12 @@ type: integer
doc: Number of active |MOs|
interface: ezfio
+[do_ormas]
+type: logical
+doc: if |true| restrict selection based on ORMAS rules
+interface: ezfio, provider, ocaml
+default: false
+
[ormas_n_space]
type: integer
doc: Number of active spaces
@@ -13,17 +19,20 @@ default: 1
type: integer
doc: starting orb for each ORMAS space
size: (bitmask.ormas_n_space)
-interface: ezfio, provider, ocaml
+interface: ezfio
+#default: (1)
[ormas_min_e]
type: integer
doc: min number of electrons in each ORMAS space
size: (bitmask.ormas_n_space)
-interface: ezfio, provider, ocaml
+interface: ezfio
+#default: (0)
[ormas_max_e]
type: integer
doc: max number of electrons in each ORMAS space
size: (bitmask.ormas_n_space)
-interface: ezfio, provider, ocaml
+interface: ezfio
+#default: (electrons.elec_num)
diff --git a/src/bitmask/bitmasks_ormas.irp.f b/src/bitmask/bitmasks_ormas.irp.f
new file mode 100644
index 00000000..0308e226
--- /dev/null
+++ b/src/bitmask/bitmasks_ormas.irp.f
@@ -0,0 +1,209 @@
+use bitmasks
+
+BEGIN_PROVIDER [integer, ormas_mstart, (ormas_n_space) ]
+ implicit none
+ call
+ implicit none
+ BEGIN_DOC
+! first orbital idx in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_mstart(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_mstart ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_mstart(ormas_mstart)
+ ASSERT (ormas_mstart(1).eq.1)
+ else if (ormas_n_space.eq.1) then
+ ormas_mstart = 1
+ else
+ print *, 'bitmask/ormas_mstart not found in EZFIO file'
+ stop 1
+ 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( ormas_mstart, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_mstart with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, ormas_min_e, (ormas_n_space) ]
+ implicit none
+ call
+ implicit none
+ BEGIN_DOC
+! min nelec in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_min_e(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_min_e ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_min_e(ormas_min_e)
+ else if (ormas_n_space.eq.1) then
+ ormas_min_e = 0
+ else
+ print *, 'bitmask/ormas_min_e not found in EZFIO file'
+ stop 1
+ 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( ormas_min_e, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_min_e with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, ormas_max_e, (ormas_n_space) ]
+ implicit none
+ call
+ implicit none
+ BEGIN_DOC
+! max nelec in each active space
+ END_DOC
+
+ logical :: has
+ PROVIDE ezfio_filename
+ if (mpi_master) then
+
+ call ezfio_has_bitmask_ormas_max_e(has)
+ if (has) then
+! write(6,'(A)') '.. >>>>> [ IO READ: ormas_max_e ] <<<<< ..'
+ call ezfio_get_bitmask_ormas_max_e(ormas_max_e)
+ else if (ormas_n_space.eq.1) then
+ ormas_max_e = elec_num
+ else
+ print *, 'bitmask/ormas_max_e not found in EZFIO file'
+ stop 1
+ 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( ormas_max_e, ormas_n_space, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read ormas_max_e with MPI'
+ endif
+ IRP_ENDIF
+
+! call write_time(6)
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, ormas_n_orb, (ormas_n_space) ]
+&BEGIN_PROVIDER [ integer, ormas_max_n_orb ]
+ implicit none
+ BEGIN_DOC
+ ! number of orbitals in each ormas space
+ END_DOC
+ ormas_n_orb = 0
+ ormas_n_orb(ormas_n_space) = mo_num + 1 - ormas_mstart(ormas_n_space)
+ do i = ormas_n_space-1, 1, -1
+ ormas_n_orb(i) = ormas_mstart(i+1) - ormas_mstart(i)
+ ASSERT (ormas_n_orb(i).ge.1)
+ enddo
+ ormas_max_n_orb = max(ormas_n_orb)
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, ormas_list_orb, (ormas_max_n_orb, ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+ ! list of orbitals in each ormas space
+ END_DOC
+ ormas_list_orb = 0
+ i = 1
+ do j = 1, ormas_n_space
+ do k = 1, ormas_n_orb(j)
+ ormas_list_orb(k,j) = i
+ i += 1
+ enddo
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), ormas_bitmask, (N_int, ormas_n_space) ]
+ implicit none
+ BEGIN_DOC
+ ! bitmask for each ormas space
+ END_DOC
+ ormas_bitmask = 0_bit_kind
+ do j = 1, ormas_n_space
+ call list_to_bitstring(ormas_bitmask(1,j), ormas_list_orb(:,j), ormas_n_orb(j), N_int)
+ enddo
+END_PROVIDER
+
+subroutine ormas_occ(key_in, occupancies)
+ implicit none
+ BEGIN_DOC
+ ! number of electrons in each ormas space
+ END_DOC
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer, intent(out) :: occupancies(ormas_n_space)
+ integer :: i,ispin,ispace
+
+ occupancies = 0
+ ! TODO: get start/end of each space within N_int
+ do ispace=1,ormas_n_space
+ do ispin=1,2
+ do i=1,N_int
+ occupancies(ispace) += popcnt(iand(ormas_bitmask(i,ispace),key_in(i,ispin)))
+ enddo
+ enddo
+ enddo
+end
+
+logical function det_allowed_ormas(key_in)
+ implicit none
+ BEGIN_DOC
+ ! return true if det has allowable ormas occupations
+ END_DOC
+ integer(bit_kind), intent(in) :: key_in(N_int,2)
+ integer :: i,ispin,ispace,occ
+
+ det_allowed_ormas = .True.
+ if (ormas_n_space.eq.1) return
+ det_allowed_ormas = .False.
+ ! TODO: get start/end of each space within N_int
+ do ispace=1,ormas_n_space
+ occ = 0
+ do ispin=1,2
+ do i=1,N_int
+ occ += popcnt(iand(ormas_bitmask(i,ispace),key_in(i,ispin)))
+ enddo
+ enddo
+ if ((occ.lt.ormas_min_e(ispace)).or.(occ.gt.ormas_max_e(ispace)) return
+ enddo
+ det_allowed_ormas = .True.
+end
+
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index 6f40a809..3928c965 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -595,6 +595,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if( val == 0d0) cycle
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+ if (do_ormas) then
+ logical, external :: det_allowed_ormas
+ if (.not.det_allowed_ormas(det)) cycle
+ endif
+
if (do_only_cas) then
integer, external :: number_of_holes, number_of_particles
if (number_of_particles(det)>0) then
diff --git a/src/cipsi_tc_bi_ortho/selection.irp.f b/src/cipsi_tc_bi_ortho/selection.irp.f
index 4c271a4b..4a9c4231 100644
--- a/src/cipsi_tc_bi_ortho/selection.irp.f
+++ b/src/cipsi_tc_bi_ortho/selection.irp.f
@@ -785,6 +785,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+ if (do_ormas) then
+ logical, external :: det_allowed_ormas
+ if (.not.det_allowed_ormas(det)) cycle
+ endif
+
if(do_only_cas) then
if( number_of_particles(det) > 0 ) cycle
if( number_of_holes(det) > 0 ) cycle
From b593352c0faf2d18f77db5894497f5b4bc041084 Mon Sep 17 00:00:00 2001
From: Kevin Gasperich
Date: Wed, 28 Jun 2023 18:34:34 -0500
Subject: [PATCH 003/140] minor fix
---
src/bitmask/bitmasks_ormas.irp.f | 13 +++++--------
1 file changed, 5 insertions(+), 8 deletions(-)
diff --git a/src/bitmask/bitmasks_ormas.irp.f b/src/bitmask/bitmasks_ormas.irp.f
index 0308e226..336022e5 100644
--- a/src/bitmask/bitmasks_ormas.irp.f
+++ b/src/bitmask/bitmasks_ormas.irp.f
@@ -1,8 +1,6 @@
use bitmasks
BEGIN_PROVIDER [integer, ormas_mstart, (ormas_n_space) ]
- implicit none
- call
implicit none
BEGIN_DOC
! first orbital idx in each active space
@@ -43,8 +41,6 @@ BEGIN_PROVIDER [integer, ormas_mstart, (ormas_n_space) ]
END_PROVIDER
BEGIN_PROVIDER [integer, ormas_min_e, (ormas_n_space) ]
- implicit none
- call
implicit none
BEGIN_DOC
! min nelec in each active space
@@ -83,8 +79,6 @@ BEGIN_PROVIDER [integer, ormas_min_e, (ormas_n_space) ]
END_PROVIDER
BEGIN_PROVIDER [integer, ormas_max_e, (ormas_n_space) ]
- implicit none
- call
implicit none
BEGIN_DOC
! max nelec in each active space
@@ -128,13 +122,14 @@ END_PROVIDER
BEGIN_DOC
! number of orbitals in each ormas space
END_DOC
+ integer :: i
ormas_n_orb = 0
ormas_n_orb(ormas_n_space) = mo_num + 1 - ormas_mstart(ormas_n_space)
do i = ormas_n_space-1, 1, -1
ormas_n_orb(i) = ormas_mstart(i+1) - ormas_mstart(i)
ASSERT (ormas_n_orb(i).ge.1)
enddo
- ormas_max_n_orb = max(ormas_n_orb)
+ ormas_max_n_orb = maxval(ormas_n_orb)
END_PROVIDER
BEGIN_PROVIDER [ integer, ormas_list_orb, (ormas_max_n_orb, ormas_n_space) ]
@@ -142,6 +137,7 @@ BEGIN_PROVIDER [ integer, ormas_list_orb, (ormas_max_n_orb, ormas_n_space) ]
BEGIN_DOC
! list of orbitals in each ormas space
END_DOC
+ integer :: i,j,k
ormas_list_orb = 0
i = 1
do j = 1, ormas_n_space
@@ -157,6 +153,7 @@ BEGIN_PROVIDER [ integer(bit_kind), ormas_bitmask, (N_int, ormas_n_space) ]
BEGIN_DOC
! bitmask for each ormas space
END_DOC
+ integer :: j
ormas_bitmask = 0_bit_kind
do j = 1, ormas_n_space
call list_to_bitstring(ormas_bitmask(1,j), ormas_list_orb(:,j), ormas_n_orb(j), N_int)
@@ -202,7 +199,7 @@ logical function det_allowed_ormas(key_in)
occ += popcnt(iand(ormas_bitmask(i,ispace),key_in(i,ispin)))
enddo
enddo
- if ((occ.lt.ormas_min_e(ispace)).or.(occ.gt.ormas_max_e(ispace)) return
+ if ((occ.lt.ormas_min_e(ispace)).or.(occ.gt.ormas_max_e(ispace))) return
enddo
det_allowed_ormas = .True.
end
From b5637661fa80c3277df196d52a8ceb4cc0a38106 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 15 Nov 2023 13:10:14 +0100
Subject: [PATCH 004/140] Fix shell_index when converting file
---
bin/qp_convert_output_to_ezfio | 8 ++++++--
1 file changed, 6 insertions(+), 2 deletions(-)
diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio
index 091423e4..32721e1e 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -224,14 +224,18 @@ 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)
+
+ shell_num = len(ang_mom)
+ assert(shell_index[0] = 1)
+ assert(shell_index[-1] = shell_num)
# ~#~#~#~#~ #
# W r i t e #
# ~#~#~#~#~ #
ezfio.set_basis_basis("Read from ResultsFile")
- ezfio.set_basis_shell_num(len(ang_mom))
+ ezfio.set_basis_shell_num(shell_num)
ezfio.set_basis_basis_nucleus_index(nucl_index)
ezfio.set_basis_prim_num(len(coefficient))
From 3cab869c2d7cb2e112d18e3612e3a1342f1eb227 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 25 Jan 2024 22:12:26 +0100
Subject: [PATCH 005/140] optim in 1e-Jastrow
---
plugins/local/jastrow/EZFIO.cfg | 2 +-
plugins/local/non_h_ints_mu/jast_1e.irp.f | 16 +-
.../local/non_h_ints_mu/jast_1e_utils.irp.f | 182 ++++++----
.../non_h_ints_mu/print_j1ecoef_info.irp.f | 94 +++++
.../local/non_h_ints_mu/test_non_h_ints.irp.f | 332 +++++++++++++++++-
.../grid_becke_vector.irp.f | 9 +-
6 files changed, 557 insertions(+), 78 deletions(-)
create mode 100644 plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f
diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg
index 0d4141af..c3ed29a3 100644
--- a/plugins/local/jastrow/EZFIO.cfg
+++ b/plugins/local/jastrow/EZFIO.cfg
@@ -99,7 +99,7 @@ size: (ao_basis.ao_num)
type: double precision
doc: coefficients of the 1-electron Jastrow in AOsxAOs
interface: ezfio
-size: (ao_basis.ao_num*ao_basis.ao_num)
+size: (ao_basis.ao_num,ao_basis.ao_num)
[j1e_coef_ao3]
type: double precision
diff --git a/plugins/local/non_h_ints_mu/jast_1e.irp.f b/plugins/local/non_h_ints_mu/jast_1e.irp.f
index fbd032ed..1fc2fd2b 100644
--- a/plugins/local/non_h_ints_mu/jast_1e.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e.irp.f
@@ -78,7 +78,7 @@ END_PROVIDER
double precision :: cx, cy, cz
double precision :: time0, time1
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
- double precision, allocatable :: coef_fit(:), coef_fit2(:), coef_fit3(:,:)
+ double precision, allocatable :: coef_fit(:), coef_fit2(:,:), coef_fit3(:,:)
PROVIDE j1e_type
@@ -243,7 +243,7 @@ END_PROVIDER
PROVIDE aos_grad_in_r_array
- allocate(coef_fit2(ao_num*ao_num))
+ allocate(coef_fit2(ao_num,ao_num))
if(mpi_master) then
call ezfio_has_jastrow_j1e_coef_ao2(exists)
@@ -254,7 +254,7 @@ END_PROVIDER
IRP_ENDIF
IRP_IF MPI
include 'mpif.h'
- call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ call MPI_BCAST(coef_fit2, (ao_num*ao_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao2 with MPI'
endif
@@ -264,7 +264,7 @@ END_PROVIDER
write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..'
call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2)
IRP_IF MPI
- call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ call MPI_BCAST(coef_fit2, (ao_num*ao_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
if (ierr /= MPI_SUCCESS) then
stop 'Unable to read j1e_coef_ao2 with MPI'
endif
@@ -272,14 +272,14 @@ END_PROVIDER
endif
else
- call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2)
+ call get_j1e_coef_fit_ao2(ao_num, coef_fit2)
call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
endif
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, ij, ipoint, c) &
+ !$OMP PRIVATE (i, j, ipoint, c) &
!$OMP SHARED (n_points_final_grid, ao_num, &
!$OMP aos_grad_in_r_array, coef_fit2, &
!$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
@@ -292,9 +292,7 @@ END_PROVIDER
do i = 1, ao_num
do j = 1, ao_num
- ij = (i-1)*ao_num + j
-
- c = coef_fit2(ij)
+ c = coef_fit2(j,i)
j1e_gradx(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,1) + aos_grad_in_r_array(i,ipoint,1) * aos_in_r_array(j,ipoint))
j1e_grady(ipoint) += c * (aos_in_r_array(i,ipoint) * aos_grad_in_r_array(j,ipoint,2) + aos_grad_in_r_array(i,ipoint,2) * aos_in_r_array(j,ipoint))
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 842908a7..90fcb5bb 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -120,15 +120,18 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
implicit none
integer , intent(in) :: dim_fit
- double precision, intent(out) :: coef_fit(dim_fit)
+ double precision, intent(out) :: coef_fit(dim_fit,dim_fit)
integer :: i, j, k, l, ipoint
- integer :: ij, kl
+ integer :: ij, kl, mn
+ integer :: info, n_svd, LWORK
double precision :: g
double precision :: t0, t1
- double precision, allocatable :: A(:,:), b(:), A_inv(:,:)
+ double precision :: cutoff_svd
+ double precision, allocatable :: A(:,:,:,:), b(:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
- double precision, allocatable :: u1e_tmp(:)
+ double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
+ double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
PROVIDE j1e_type
@@ -136,6 +139,9 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
PROVIDE elec_alpha_num elec_beta_num elec_num
PROVIDE mo_coef
+
+ cutoff_svd = 5d-8
+
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs x AOs ... '
@@ -169,57 +175,70 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! get A
- allocate(A(ao_num*ao_num,ao_num*ao_num))
+ !!$OMP PARALLEL &
+ !!$OMP DEFAULT (NONE) &
+ !!$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !!$OMP SHARED (n_points_final_grid, ao_num, &
+ !!$OMP final_weight_at_r_vector, aos_in_r_array_transp, A)
+ !!$OMP DO COLLAPSE(2)
+ !do k = 1, ao_num
+ ! do l = 1, ao_num
+ ! kl = (k-1)*ao_num + l
+ ! do i = 1, ao_num
+ ! do j = 1, ao_num
+ ! ij = (i-1)*ao_num + j
+ ! A(ij,kl) = 0.d0
+ ! do ipoint = 1, n_points_final_grid
+ ! A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ ! * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ ! enddo
+ ! enddo
+ ! enddo
+ ! enddo
+ !enddo
+ !!$OMP END DO
+ !!$OMP END PARALLEL
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, &
- !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A)
+ allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ allocate(A(ao_num,ao_num,ao_num,ao_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
!$OMP DO COLLAPSE(2)
- do k = 1, ao_num
- do l = 1, ao_num
- kl = (k-1)*ao_num + l
-
- do i = 1, ao_num
- do j = 1, ao_num
- ij = (i-1)*ao_num + j
-
- A(ij,kl) = 0.d0
- do ipoint = 1, n_points_final_grid
- A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
- * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
- enddo
- enddo
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
-! print *, ' A'
-! do ij = 1, ao_num*ao_num
-! write(*, '(100000(f15.7))') (A(ij,kl), kl = 1, ao_num*ao_num)
-! enddo
+ call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ , 0.d0, A(1,1,1,1), ao_num*ao_num)
+
+ deallocate(tmp)
+
! --- --- ---
! get b
- allocate(b(ao_num*ao_num))
+ allocate(b(ao_num,ao_num))
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, ij, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, &
- !$OMP final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
!$OMP DO COLLAPSE(2)
do i = 1, ao_num
do j = 1, ao_num
- ij = (i-1)*ao_num + j
-
- b(ij) = 0.d0
+ b(j,i) = 0.d0
do ipoint = 1, n_points_final_grid
- b(ij) = b(ij) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint)
+ b(j,i) = b(j,i) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint)
enddo
enddo
enddo
@@ -231,36 +250,69 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! solve Ax = b
- allocate(A_inv(ao_num*ao_num,ao_num*ao_num))
- !call get_inverse(A, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num)
- call get_pseudo_inverse(A, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num, 5d-8)
+ !call get_pseudo_inverse(A, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num, cutoff_svd)
+
+ allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
+
+ allocate(work(1))
+ lwork = -1
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ': SVD failed'
+ stop
+ endif
+
+ LWORK = max(5*ao_num*ao_num, int(WORK(1)))
+ deallocate(work)
+ allocate(work(lwork))
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ':: SVD failed'
+ stop 1
+ endif
+
+ deallocate(work)
+
+ n_svd = 0
+ do ij = 1, ao_num*ao_num
+ if(D(ij)/D(1) > cutoff_svd) then
+ D(ij) = 1.d0 / D(ij)
+ n_svd = n_svd + 1
+ else
+ D(ij) = 0.d0
+ endif
+ enddo
+ print*, ' n_svd = ', n_svd
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ij, kl) &
+ !$OMP SHARED (ao_num, n_svd, D, Vt)
+ !$OMP DO
+ do kl = 1, ao_num*ao_num
+ do ij = 1, n_svd
+ Vt(ij,kl) = Vt(ij,kl) * D(ij)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! A = A_inv
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_svd, 1.d0 &
+ , U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num &
+ , 0.d0, A(1,1,1,1), ao_num*ao_num)
+
+ deallocate(D, U, Vt)
+
+
+ ! ---
! coef_fit = A_inv x b
- call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_inv, ao_num*ao_num, b, 1, 0.d0, coef_fit, 1)
+ call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A(1,1,1,1), ao_num*ao_num, b(1,1), 1, 0.d0, coef_fit(1,1), 1)
- integer :: mn
- double precision :: tmp, acc, nrm
-
- acc = 0.d0
- nrm = 0.d0
- do ij = 1, ao_num*ao_num
- tmp = 0.d0
- do kl = 1, ao_num*ao_num
- tmp += A(ij,kl) * coef_fit(kl)
- enddo
- tmp = tmp - b(ij)
- if(dabs(tmp) .gt. 1d-7) then
- print*, ' problem found in fitting 1e-Jastrow'
- print*, ij, tmp
- endif
-
- acc += dabs(tmp)
- nrm += dabs(b(ij))
- enddo
- print *, ' Relative Error (%) =', 100.d0*acc/nrm
-
-
- deallocate(A, A_inv, b)
+ deallocate(A, b)
call wall_time(t1)
print*, ' END after (min) ', (t1-t0)/60.d0
diff --git a/plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f b/plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f
new file mode 100644
index 00000000..feb2685a
--- /dev/null
+++ b/plugins/local/non_h_ints_mu/print_j1ecoef_info.irp.f
@@ -0,0 +1,94 @@
+
+! ---
+
+program print_j1ecoef_info
+
+ implicit none
+
+ my_grid_becke = .True.
+ PROVIDE tc_grid1_a tc_grid1_r
+ my_n_pt_r_grid = tc_grid1_r
+ my_n_pt_a_grid = tc_grid1_a
+ touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ if(tc_integ_type .eq. "numeric") then
+ my_extra_grid_becke = .True.
+ PROVIDE tc_grid2_a tc_grid2_r
+ my_n_pt_r_extra_grid = tc_grid2_r
+ my_n_pt_a_extra_grid = tc_grid2_a
+ touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+ endif
+
+ call print_j1ecoef()
+
+end
+
+! ---
+
+subroutine print_j1ecoef()
+
+ implicit none
+ integer :: i, j, ij
+ integer :: ierr
+ logical :: exists
+ character(len=10) :: ni, nj
+ double precision, allocatable :: coef_fit2(:)
+
+ PROVIDE ao_l_char_space
+
+ allocate(coef_fit2(ao_num*ao_num))
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_j1e_coef_ao2(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'
+ call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read j1e_coef_ao2 with MPI'
+ endif
+ IRP_ENDIF
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao2 ] <<<<< ..'
+ call ezfio_get_jastrow_j1e_coef_ao2(coef_fit2)
+ IRP_IF MPI
+ call MPI_BCAST(coef_fit2, ao_num*ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read j1e_coef_ao2 with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ call get_j1e_coef_fit_ao2(ao_num*ao_num, coef_fit2)
+ call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
+
+ endif
+
+
+ do i = 1, ao_num
+ write(ni, '(I0)') ao_l(i)+1
+ do j = 1, ao_num
+ write(nj, '(I0)') ao_l(j)+1
+ ij = (i-1)*ao_num + j
+ print *, trim(adjustl(ni)) // trim(adjustl(ao_l_char_space(i))), " " &
+ , trim(adjustl(nj)) // trim(adjustl(ao_l_char_space(j))), " " &
+ , dabs(coef_fit2(ij))
+ enddo
+! print *, ' '
+ enddo
+
+
+ deallocate(coef_fit2)
+
+ return
+end
+
+! ---
+
+
diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
index 90e5a7b3..2b96591b 100644
--- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
+++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
@@ -39,8 +39,11 @@ program test_non_h
!call test_j1e_fit_ao()
- call test_tc_grad_and_lapl_ao_new()
- call test_tc_grad_square_ao_new()
+ !call test_tc_grad_and_lapl_ao_new()
+ !call test_tc_grad_square_ao_new()
+
+ !call test_fit_coef_A1()
+ call test_fit_coef_inv()
end
! ---
@@ -1112,3 +1115,328 @@ END_PROVIDER
! ---
+subroutine test_fit_coef_A1()
+
+ implicit none
+ integer :: i, j, k, l, ij, kl, ipoint
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision, allocatable :: A1(:,:)
+ double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
+
+ ! ---
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ call wall_time(t1)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ allocate(A2(ao_num,ao_num,ao_num,ao_num))
+
+ call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ , 0.d0, A2(1,1,1,1), ao_num*ao_num)
+ deallocate(tmp)
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
+
+ ! ---
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2(j,i,l,k) - A1(ij,kl))
+ if(diff .gt. 1d-10) then
+ print *, ' problem in A2 on:', i, i, l, k
+ print *, ' A1 :', A1(ij,kl)
+ print *, ' A2 :', A2(j,i,l,k)
+ stop
+ endif
+
+ accu += diff
+ norm += dabs(A1(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(A1, A2)
+
+ print*, ' accuracy (%) = ', 100.d0 * accu / norm
+
+ return
+end
+
+! ---
+
+subroutine test_fit_coef_inv()
+
+ implicit none
+ integer :: i, j, k, l, ij, kl, ipoint
+ integer :: n_svd, info, lwork, mn
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision :: cutoff_svd
+ double precision, allocatable :: A1(:,:), A1_inv(:,:)
+ double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
+ double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
+
+
+ cutoff_svd = 5d-8
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ allocate(A1_inv(ao_num*ao_num,ao_num*ao_num))
+ call get_pseudo_inverse(A1, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A1_inv, ao_num*ao_num, cutoff_svd)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A1_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ allocate(A2(ao_num,ao_num,ao_num,ao_num))
+
+ call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ , 0.d0, A2(1,1,1,1), ao_num*ao_num)
+
+ deallocate(tmp)
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
+
+ allocate(A2_tmp(ao_num,ao_num,ao_num,ao_num))
+ A2_tmp = A2
+
+ allocate(A2_inv(ao_num,ao_num,ao_num,ao_num))
+
+ allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
+
+ allocate(work(1))
+ lwork = -1
+
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ': SVD failed'
+ stop
+ endif
+
+ LWORK = max(5*ao_num*ao_num, int(WORK(1)))
+ deallocate(work)
+ allocate(work(lwork))
+
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ , D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
+ if(info /= 0) then
+ print *, info, ':: SVD failed'
+ stop 1
+ endif
+
+ deallocate(A2_tmp)
+ deallocate(work)
+
+ n_svd = 0
+ do ij = 1, ao_num*ao_num
+ if(D(ij)/D(1) > cutoff_svd) then
+ D(ij) = 1.d0 / D(ij)
+ n_svd = n_svd + 1
+ else
+ D(ij) = 0.d0
+ endif
+ enddo
+ print*, ' n_svd = ', n_svd
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ij, kl) &
+ !$OMP SHARED (ao_num, n_svd, D, Vt)
+ !$OMP DO
+ do kl = 1, ao_num*ao_num
+ do ij = 1, n_svd
+ Vt(ij,kl) = Vt(ij,kl) * D(ij)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_svd, 1.d0 &
+ , U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num &
+ , 0.d0, A2_inv(1,1,1,1), ao_num*ao_num)
+
+ deallocate(D, U, Vt)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A2_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2(j,i,l,k) - A1(ij,kl))
+ if(diff .gt. 1d-10) then
+ print *, ' problem in A2 on:', i, i, l, k
+ print *, ' A1 :', A1(ij,kl)
+ print *, ' A2 :', A2(j,i,l,k)
+ stop
+ endif
+
+ accu += diff
+ norm += dabs(A1(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ print*, ' accuracy on A (%) = ', 100.d0 * accu / norm
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ diff = dabs(A2_inv(j,i,l,k) - A1_inv(ij,kl))
+ !if(diff .gt. cutoff_svd) then
+ ! print *, ' problem in A2_inv on:', i, i, l, k
+ ! print *, ' A1_inv :', A1_inv(ij,kl)
+ ! print *, ' A2_inv :', A2_inv(j,i,l,k)
+ ! stop
+ !endif
+
+ accu += diff
+ norm += dabs(A1_inv(ij,kl))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(A1_inv, A2_inv)
+ deallocate(A1, A2)
+
+ print*, ' accuracy on A_inv (%) = ', 100.d0 * accu / norm
+
+ return
+end
+
+! ---
+
diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f
index 0386f3c6..473096d0 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -55,7 +55,7 @@ END_PROVIDER
do j = 1, nucl_num
do i = 1, n_points_radial_grid -1
do k = 1, n_points_integration_angular
- if(dabs(final_weight_at_r(k,i,j)) < thresh_grid)then
+ if(dabs(final_weight_at_r(k,i,j)) < thresh_grid) then
cycle
endif
i_count += 1
@@ -67,6 +67,13 @@ END_PROVIDER
index_final_points(2,i_count) = i
index_final_points(3,i_count) = j
index_final_points_reverse(k,i,j) = i_count
+
+ if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
+ print *, ' !!! WARNING !!!'
+ print *, ' negative weight !!!!'
+ print *, i_count, final_weight_at_r_vector(i_count)
+ stop
+ endif
enddo
enddo
enddo
From 8018440410fac858f9a5ed2fb9f2c4ec4963c4b3 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 25 Jan 2024 22:13:13 +0100
Subject: [PATCH 006/140] OPENMP & DGEMM in pseudo_inv
---
src/utils/linear_algebra.irp.f | 57 +++++++++++++++++++++++-----------
1 file changed, 39 insertions(+), 18 deletions(-)
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 314ad4f6..a67a219c 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1321,19 +1321,22 @@ subroutine get_inverse(A,LDA,m,C,LDC)
deallocate(ipiv,work)
end
-subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff)
- implicit none
+subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
+
BEGIN_DOC
! Find C = A^-1
END_DOC
- integer, intent(in) :: m,n, LDA, LDC
- double precision, intent(in) :: A(LDA,n)
- double precision, intent(in) :: cutoff
- double precision, intent(out) :: C(LDC,m)
- double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
- integer :: info, lwork
- integer :: i,j,k
+ implicit none
+ integer, intent(in) :: m, n, LDA, LDC
+ double precision, intent(in) :: A(LDA,n)
+ double precision, intent(in) :: cutoff
+ double precision, intent(out) :: C(LDC,m)
+
+ integer :: info, lwork
+ integer :: i, j, k, n_svd
+ double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
+
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n))
do j=1,n
do i=1,m
@@ -1355,22 +1358,40 @@ subroutine get_pseudo_inverse(A,LDA,m,n,C,LDC,cutoff)
stop 1
endif
- do i=1,n
- if (D(i)/D(1) > cutoff) then
- D(i) = 1.d0/D(i)
+ n_svd = 0
+ do i = 1, n
+ if(D(i)/D(1) > cutoff) then
+ D(i) = 1.d0 / D(i)
+ n_svd = n_svd + 1
else
D(i) = 0.d0
endif
enddo
+ print*, ' n_svd = ', n_svd
- C = 0.d0
- do i=1,m
- do j=1,n
- do k=1,n
- C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
- enddo
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j) &
+ !$OMP SHARED (n, n_svd, D, Vt)
+ !$OMP DO
+ do j = 1, n
+ do i = 1, n_svd
+ Vt(i,j) = D(i) * Vt(i,j)
enddo
enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm("N", "N", m, n, n_svd, 1.d0, U, m, Vt, n, 0.d0, C, LDC)
+
+ !C = 0.d0
+ !do i=1,m
+ ! do j=1,n
+ ! do k=1,n
+ ! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
+ ! enddo
+ ! enddo
+ !enddo
deallocate(U,D,Vt,work,A_tmp)
From c0a4b7890e51454e078ab894b935a4e772484fab Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 26 Jan 2024 13:19:21 +0100
Subject: [PATCH 007/140] Fix bug in complex svd
---
src/utils/linear_algebra.irp.f | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 314ad4f6..7cef9ee4 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -645,7 +645,7 @@ subroutine get_pseudo_inverse_complex(A,LDA,m,n,C,LDC,cutoff)
END_DOC
integer, intent(in) :: m,n, LDA, LDC
complex*16, intent(in) :: A(LDA,n)
- double precision, intent(in) :: cutoff
+ double precision, intent(in) :: cutoff, d1
complex*16, intent(out) :: C(LDC,m)
double precision, allocatable :: D(:), rwork(:)
@@ -673,8 +673,9 @@ subroutine get_pseudo_inverse_complex(A,LDA,m,n,C,LDC,cutoff)
stop 1
endif
+ d1 = D(1)
do i=1,n
- if (D(i) > cutoff*D(1)) then
+ if (D(i) > cutoff*d1) then
D(i) = 1.d0/D(i)
else
D(i) = 0.d0
From 0b83c1ab8b34bd303142f0a7352b0775510ee874 Mon Sep 17 00:00:00 2001
From: ydamour
Date: Fri, 26 Jan 2024 17:34:16 +0100
Subject: [PATCH 008/140] mkl with gfortran
---
config/gfortran_mkl.cfg | 62 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 62 insertions(+)
create mode 100644 config/gfortran_mkl.cfg
diff --git a/config/gfortran_mkl.cfg b/config/gfortran_mkl.cfg
new file mode 100644
index 00000000..f2787d63
--- /dev/null
+++ b/config/gfortran_mkl.cfg
@@ -0,0 +1,62 @@
+# Common flags
+##############
+#
+# -ffree-line-length-none : Needed for IRPF90 which produces long lines
+# -lblas -llapack : Link with libblas and liblapack libraries provided by the system
+# -I . : Include the curent directory (Mandatory)
+#
+# --ninja : Allow the utilisation of ninja. (Mandatory)
+# --align=32 : Align all provided arrays on a 32-byte boundary
+#
+#
+[COMMON]
+FC : gfortran -ffree-line-length-none -I . -mavx -g -fPIC -std=legacy
+LAPACK_LIB : -I${MKLROOT}/include -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_core -lpthread -lm -ldl -lmkl_gnu_thread -lgomp -fopenmp
+IRPF90 : irpf90
+IRPF90_FLAGS : --ninja --align=32 -DSET_NESTED
+
+# Global options
+################
+#
+# 1 : Activate
+# 0 : Deactivate
+#
+[OPTION]
+MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below
+CACHE : 0 ; Enable cache_compile.py
+OPENMP : 1 ; Append OpenMP flags
+
+# Optimization flags
+####################
+#
+# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations.
+# It also enables optimizations that are not valid
+# for all standard-compliant programs. It turns on
+# -ffast-math and the Fortran-specific
+# -fno-protect-parens and -fstack-arrays.
+[OPT]
+FCFLAGS : -Ofast -mavx
+
+# Profiling flags
+#################
+#
+[PROFILE]
+FC : -p -g
+FCFLAGS : -Ofast
+
+# Debugging flags
+#################
+#
+# -fcheck=all : Checks uninitialized variables, array subscripts, etc...
+# -g : Extra debugging information
+#
+[DEBUG]
+FCFLAGS : -fcheck=all -g
+
+# OpenMP flags
+#################
+#
+[OPENMP]
+FC : -fopenmp
+IRPF90_FLAGS : --openmp
+
From cc334b34b736af8a9ec2aa31a714f8a5d201956f Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Fri, 26 Jan 2024 19:50:18 +0100
Subject: [PATCH 009/140] opt in 1e-Jast & fixed bug in pseudo_inv
---
.../local/non_h_ints_mu/jast_1e_utils.irp.f | 99 ++++++++-----------
.../local/non_h_ints_mu/test_non_h_ints.irp.f | 37 ++++---
src/utils/linear_algebra.irp.f | 42 ++++----
3 files changed, 85 insertions(+), 93 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 90fcb5bb..79f780b1 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -127,8 +127,8 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
integer :: info, n_svd, LWORK
double precision :: g
double precision :: t0, t1
- double precision :: cutoff_svd
- double precision, allocatable :: A(:,:,:,:), b(:,:)
+ double precision :: cutoff_svd, D1_inv
+ double precision, allocatable :: A(:,:,:,:), b(:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
@@ -140,7 +140,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
PROVIDE mo_coef
- cutoff_svd = 5d-8
+ cutoff_svd = 1d-10
call wall_time(t0)
print*, ' PROVIDING the representation of 1e-Jastrow in AOs x AOs ... '
@@ -175,31 +175,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! get A
- !!$OMP PARALLEL &
- !!$OMP DEFAULT (NONE) &
- !!$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
- !!$OMP SHARED (n_points_final_grid, ao_num, &
- !!$OMP final_weight_at_r_vector, aos_in_r_array_transp, A)
- !!$OMP DO COLLAPSE(2)
- !do k = 1, ao_num
- ! do l = 1, ao_num
- ! kl = (k-1)*ao_num + l
- ! do i = 1, ao_num
- ! do j = 1, ao_num
- ! ij = (i-1)*ao_num + j
- ! A(ij,kl) = 0.d0
- ! do ipoint = 1, n_points_final_grid
- ! A(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
- ! * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
- ! enddo
- ! enddo
- ! enddo
- ! enddo
- !enddo
- !!$OMP END DO
- !!$OMP END PARALLEL
-
- allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ allocate(tmp(n_points_final_grid,ao_num,ao_num))
allocate(A(ao_num,ao_num,ao_num,ao_num))
!$OMP PARALLEL &
@@ -210,47 +186,41 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
, 0.d0, A(1,1,1,1), ao_num*ao_num)
- deallocate(tmp)
-
-
! --- --- ---
! get b
- allocate(b(ao_num,ao_num))
+ allocate(b(ao_num*ao_num))
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, u1e_tmp, b)
- !$OMP DO COLLAPSE(2)
- do i = 1, ao_num
- do j = 1, ao_num
- b(j,i) = 0.d0
- do ipoint = 1, n_points_final_grid
- b(j,i) = b(j,i) + final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) * u1e_tmp(ipoint)
- enddo
- enddo
+ do ipoint = 1, n_points_final_grid
+ u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
enddo
- !$OMP END DO
- !$OMP END PARALLEL
+
+ call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
+ !call dgemm( "T", "N", ao_num*ao_num, 1, n_points_final_grid, 1.d0 &
+ ! , tmp(1,1,1), n_points_final_grid, u1e_tmp(1), n_points_final_grid &
+ ! , 0.d0, b(1), ao_num*ao_num)
deallocate(u1e_tmp)
+ deallocate(tmp)
! --- --- ---
! solve Ax = b
- !call get_pseudo_inverse(A, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv, ao_num*ao_num, cutoff_svd)
+! double precision, allocatable :: A_inv(:,:,:,:)
+! allocate(A_inv(ao_num,ao_num,ao_num,ao_num))
+! call get_pseudo_inverse(A(1,1,1,1), ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv(1,1,1,1), ao_num*ao_num, cutoff_svd)
+! A = A_inv
allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
@@ -275,15 +245,21 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
deallocate(work)
- n_svd = 0
- do ij = 1, ao_num*ao_num
- if(D(ij)/D(1) > cutoff_svd) then
- D(ij) = 1.d0 / D(ij)
- n_svd = n_svd + 1
- else
- D(ij) = 0.d0
- endif
- enddo
+ if(D(1) .lt. 1d-14) then
+ print*, ' largest singular value is very small:', D(1)
+ n_svd = 1
+ else
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
+ do ij = 1, ao_num*ao_num
+ if(D(ij)*D1_inv > cutoff_svd) then
+ D(ij) = 1.d0 / D(ij)
+ n_svd = n_svd + 1
+ else
+ D(ij) = 0.d0
+ endif
+ enddo
+ endif
print*, ' n_svd = ', n_svd
!$OMP PARALLEL &
@@ -310,7 +286,10 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! ---
! coef_fit = A_inv x b
- call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A(1,1,1,1), ao_num*ao_num, b(1,1), 1, 0.d0, coef_fit(1,1), 1)
+ call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A(1,1,1,1), ao_num*ao_num, b(1), 1, 0.d0, coef_fit(1,1), 1)
+ !call dgemm( "N", "N", ao_num*ao_num, 1, ao_num*ao_num, 1.d0 &
+ ! , A(1,1,1,1), ao_num*ao_num, b(1), ao_num*ao_num &
+ ! , 0.d0, coef_fit(1,1), ao_num*ao_num)
deallocate(A, b)
diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
index 2b96591b..c3fde334 100644
--- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
+++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
@@ -1232,8 +1232,8 @@ subroutine test_fit_coef_inv()
integer :: n_svd, info, lwork, mn
double precision :: t1, t2
double precision :: accu, norm, diff
- double precision :: cutoff_svd
- double precision, allocatable :: A1(:,:), A1_inv(:,:)
+ double precision :: cutoff_svd, D1_inv
+ double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
@@ -1285,7 +1285,7 @@ subroutine test_fit_coef_inv()
call wall_time(t1)
- allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ allocate(tmp(n_points_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
@@ -1294,7 +1294,7 @@ subroutine test_fit_coef_inv()
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
@@ -1303,8 +1303,8 @@ subroutine test_fit_coef_inv()
allocate(A2(ao_num,ao_num,ao_num,ao_num))
- call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
deallocate(tmp)
@@ -1312,6 +1312,8 @@ subroutine test_fit_coef_inv()
call wall_time(t2)
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
+ allocate(A1_tmp(ao_num*ao_num,ao_num*ao_num))
+ A1_tmp = A1
allocate(A2_tmp(ao_num,ao_num,ao_num,ao_num))
A2_tmp = A2
@@ -1322,7 +1324,8 @@ subroutine test_fit_coef_inv()
allocate(work(1))
lwork = -1
- call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A1_tmp(1,1), ao_num*ao_num &
+ !call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
, D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
if(info /= 0) then
print *, info, ': SVD failed'
@@ -1333,7 +1336,8 @@ subroutine test_fit_coef_inv()
deallocate(work)
allocate(work(lwork))
- call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
+ call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A1_tmp(1,1), ao_num*ao_num &
+ !call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A2_tmp(1,1,1,1), ao_num*ao_num &
, D(1), U(1,1), ao_num*ao_num, Vt(1,1), ao_num*ao_num, work, lwork, info)
if(info /= 0) then
print *, info, ':: SVD failed'
@@ -1343,9 +1347,10 @@ subroutine test_fit_coef_inv()
deallocate(A2_tmp)
deallocate(work)
- n_svd = 0
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
do ij = 1, ao_num*ao_num
- if(D(ij)/D(1) > cutoff_svd) then
+ if(D(ij)*D1_inv > cutoff_svd) then
D(ij) = 1.d0 / D(ij)
n_svd = n_svd + 1
else
@@ -1416,12 +1421,12 @@ subroutine test_fit_coef_inv()
ij = (i-1)*ao_num + j
diff = dabs(A2_inv(j,i,l,k) - A1_inv(ij,kl))
- !if(diff .gt. cutoff_svd) then
- ! print *, ' problem in A2_inv on:', i, i, l, k
- ! print *, ' A1_inv :', A1_inv(ij,kl)
- ! print *, ' A2_inv :', A2_inv(j,i,l,k)
- ! stop
- !endif
+ if(diff .gt. cutoff_svd) then
+ print *, ' problem in A2_inv on:', i, i, l, k
+ print *, ' A1_inv :', A1_inv(ij,kl)
+ print *, ' A2_inv :', A2_inv(j,i,l,k)
+ stop
+ endif
accu += diff
norm += dabs(A1_inv(ij,kl))
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index a67a219c..c897140e 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1335,6 +1335,7 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
integer :: info, lwork
integer :: i, j, k, n_svd
+ double precision :: D1_inv
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A_tmp(:,:)
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n))
@@ -1358,15 +1359,22 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
stop 1
endif
- n_svd = 0
- do i = 1, n
- if(D(i)/D(1) > cutoff) then
- D(i) = 1.d0 / D(i)
- n_svd = n_svd + 1
- else
- D(i) = 0.d0
- endif
- enddo
+ if(D(1) .lt. 1d-14) then
+ print*, ' largest singular value is very small:', D(1)
+ n_svd = 1
+ else
+ n_svd = 0
+ D1_inv = 1.d0 / D(1)
+ do i = 1, n
+ if(D(i)*D1_inv > cutoff) then
+ D(i) = 1.d0 / D(i)
+ n_svd = n_svd + 1
+ else
+ D(i) = 0.d0
+ endif
+ enddo
+ endif
+
print*, ' n_svd = ', n_svd
!$OMP PARALLEL &
@@ -1384,14 +1392,14 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
call dgemm("N", "N", m, n, n_svd, 1.d0, U, m, Vt, n, 0.d0, C, LDC)
- !C = 0.d0
- !do i=1,m
- ! do j=1,n
- ! do k=1,n
- ! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
- ! enddo
- ! enddo
- !enddo
+! C = 0.d0
+! do i=1,m
+! do j=1,n
+! do k=1,n
+! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
+! enddo
+! enddo
+! enddo
deallocate(U,D,Vt,work,A_tmp)
From 9e1b2f35d31dbdfc22fb43638b2c75105517cc8a Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 1 Feb 2024 08:57:07 +0100
Subject: [PATCH 010/140] added Charge_Harmonizer for numerical integrals
---
.../local/non_h_ints_mu/jast_2e_utils.irp.f | 226 +++++++++++++-----
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 78 ++++++
2 files changed, 245 insertions(+), 59 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
index 8c25b377..34c45df9 100644
--- a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
@@ -98,14 +98,20 @@ BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_f
END_DOC
implicit none
- integer :: ipoint, i, j, m, jpoint
- double precision :: time0, time1
- double precision :: x, y, z, r2
- double precision :: dx, dy, dz
- double precision :: tmp_ct
- double precision :: tmp0, tmp1, tmp2
- double precision :: tmp0_x, tmp0_y, tmp0_z
- double precision :: tmp1_x, tmp1_y, tmp1_z
+ integer :: ipoint, i, j, m, jpoint
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision :: time0, time1
+ double precision :: x, y, z, r2
+ double precision :: dx, dy, dz
+ double precision :: tmp_ct
+ double precision :: tmp0, tmp1, tmp2
+ double precision :: tmp0_x, tmp0_y, tmp0_z
+ double precision :: tmp1_x, tmp1_y, tmp1_z
+ double precision, allocatable :: tmp(:,:,:)
+ double precision, allocatable :: tmp_grad1_u12(:,:,:)
+
PROVIDE j2e_type
PROVIDE Env_type
@@ -113,70 +119,172 @@ BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_f
call wall_time(time0)
print*, ' providing int2_grad1_u2e_ao ...'
- if( (j2e_type .eq. "Mu") .and. &
- ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+ if(tc_integ_type .eq. "numeric") then
- PROVIDE mu_erf
- PROVIDE env_type env_val env_grad
- PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- PROVIDE Ir2_Mu_gauss_Du
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
- tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, &
- !$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) &
- !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
- !$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, &
- !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
- !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
- !$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao)
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
- do ipoint = 1, n_points_final_grid
-
- x = final_grid_points(1,ipoint)
- y = final_grid_points(2,ipoint)
- z = final_grid_points(3,ipoint)
- r2 = x*x + y*y + z*z
-
- dx = env_grad(1,ipoint)
- dy = env_grad(2,ipoint)
- dz = env_grad(3,ipoint)
-
- tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx)
- tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy)
- tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz)
-
- tmp1 = 0.5d0 * env_val(ipoint)
-
- tmp1_x = tmp_ct * dx
- tmp1_y = tmp_ct * dy
- tmp1_z = tmp_ct * dz
-
- do j = 1, ao_num
- do i = 1, ao_num
-
- tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint)
-
- int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint)
- int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint)
- int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- FREE Ir2_Mu_gauss_Du
+ ! n_points_final_grid = n_blocks * n_pass + n_rest
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
+
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
+
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
+ !$OMP final_grid_points, tmp_grad1_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1) &
+ , tmp_grad1_u12(1,i_blocks,2) &
+ , tmp_grad1_u12(1,i_blocks,3))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u2e_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+ enddo
+
+ deallocate(tmp_grad1_u12)
+
+ if(n_rest .gt. 0) then
+
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
+
+ ii = n_pass*n_blocks + 1
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
+ !$OMP final_grid_points, tmp_grad1_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1) &
+ , tmp_grad1_u12(1,i_rest,2) &
+ , tmp_grad1_u12(1,i_rest,3))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u2e_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+
+ deallocate(tmp_grad1_u12)
+ endif
+
+ deallocate(tmp)
+
+ elseif(tc_integ_type .eq. "semi-analytic") then
+
+ if( (j2e_type .eq. "Mu") .and. &
+ ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+
+ PROVIDE mu_erf
+ PROVIDE env_type env_val env_grad
+ PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ PROVIDE Ir2_Mu_gauss_Du
+
+ tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, tmp1, tmp2, &
+ !$OMP tmp0_x, tmp0_y, tmp0_z, tmp1_x, tmp1_y, tmp1_z) &
+ !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
+ !$OMP tmp_ct, env_val, env_grad, Ir2_Mu_long_Du_0, &
+ !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
+ !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
+ !$OMP Ir2_Mu_long_Du_2, int2_grad1_u2e_ao)
+ !$OMP DO SCHEDULE (static)
+ do ipoint = 1, n_points_final_grid
+
+ x = final_grid_points(1,ipoint)
+ y = final_grid_points(2,ipoint)
+ z = final_grid_points(3,ipoint)
+ r2 = x*x + y*y + z*z
+
+ dx = env_grad(1,ipoint)
+ dy = env_grad(2,ipoint)
+ dz = env_grad(3,ipoint)
+
+ tmp0_x = 0.5d0 * (env_val(ipoint) * x + r2 * dx)
+ tmp0_y = 0.5d0 * (env_val(ipoint) * y + r2 * dy)
+ tmp0_z = 0.5d0 * (env_val(ipoint) * z + r2 * dz)
+
+ tmp1 = 0.5d0 * env_val(ipoint)
+
+ tmp1_x = tmp_ct * dx
+ tmp1_y = tmp_ct * dy
+ tmp1_z = tmp_ct * dz
+
+ do j = 1, ao_num
+ do i = 1, ao_num
+
+ tmp2 = 0.5d0 * Ir2_Mu_long_Du_2(i,j,ipoint) - x * Ir2_Mu_long_Du_x(i,j,ipoint) - y * Ir2_Mu_long_Du_y(i,j,ipoint) - z * Ir2_Mu_long_Du_z(i,j,ipoint)
+
+ int2_grad1_u2e_ao(i,j,ipoint,1) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_x - tmp1 * Ir2_Mu_long_Du_x(i,j,ipoint) + dx * tmp2 - tmp1_x * Ir2_Mu_gauss_Du(i,j,ipoint)
+ int2_grad1_u2e_ao(i,j,ipoint,2) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_y - tmp1 * Ir2_Mu_long_Du_y(i,j,ipoint) + dy * tmp2 - tmp1_y * Ir2_Mu_gauss_Du(i,j,ipoint)
+ int2_grad1_u2e_ao(i,j,ipoint,3) = Ir2_Mu_long_Du_0(i,j,ipoint) * tmp0_z - tmp1 * Ir2_Mu_long_Du_z(i,j,ipoint) + dz * tmp2 - tmp1_z * Ir2_Mu_gauss_Du(i,j,ipoint)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ FREE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ FREE Ir2_Mu_gauss_Du
+
+ else
+
+ print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
else
-
- print *, ' Error in int2_grad1_u2e_ao: Unknown Jastrow'
+
+ print *, ' Error in int2_grad1_u2e_ao: Unknown tc_integ_type'
stop
- endif ! j2e_type
+ endif ! tc_integ_type
call wall_time(time1)
print*, ' wall time for int2_grad1_u2e_ao (min) =', (time1-time0)/60.d0
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index b58d8c17..9a5e35c6 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -395,3 +395,81 @@ end
! ---
+subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
+
+ BEGIN_DOC
+ !
+ ! grad_1 u_2e(r1,r2)
+ !
+ ! we use grid for r1 and extra_grid for r2
+ !
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: ipoint, n_grid2
+ double precision, intent(out) :: resx(n_grid2), resy(n_grid2), resz(n_grid2)
+
+ integer :: jpoint
+ double precision :: env_r1, tmp
+ double precision :: grad1_env(3), r1(3)
+ double precision, allocatable :: env_r2(:)
+ double precision, allocatable :: u2b_r12(:)
+ double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, external :: env_nucl
+
+ PROVIDE j1e_type j2e_type env_type
+ PROVIDE final_grid_points
+ PROVIDE final_grid_points_extra
+
+ r1(1) = final_grid_points(1,ipoint)
+ r1(2) = final_grid_points(2,ipoint)
+ r1(3) = final_grid_points(3,ipoint)
+
+ if( (j2e_type .eq. "Mu") .or. &
+ (j2e_type .eq. "Mur") .or. &
+ (j2e_type .eq. "Boys") ) then
+
+ if(env_type .eq. "None") then
+
+ call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+ ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_r12(n_grid2))
+ allocate(gradx1_u2b(n_grid2))
+ allocate(grady1_u2b(n_grid2))
+ allocate(gradz1_u2b(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+
+ call env_nucl_r1_seq(n_grid2, env_r2)
+ call j12_r1_seq(r1, n_grid2, u2b_r12)
+ call grad1_j12_r1_seq(r1, n_grid2, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = (gradx1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = (grady1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = (gradz1_u2b(jpoint) * env_r1 + u2b_r12(jpoint) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2, u2b_r12, gradx1_u2b, grady1_u2b, gradz1_u2b)
+
+ endif ! env_type
+
+ else
+
+ print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ return
+end
+
+! ---
+
From c9caec5f7e8c9faa8b503553bb7895f48b04bcb2 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 4 Feb 2024 13:22:26 +0100
Subject: [PATCH 011/140] added Mu_Nu Jastrow
---
plugins/local/jastrow/EZFIO.cfg | 7 +
plugins/local/non_h_ints_mu/jast_1e.irp.f | 145 +----------
.../local/non_h_ints_mu/jast_1e_utils.irp.f | 38 ++-
.../local/non_h_ints_mu/jast_2e_utils.irp.f | 195 +++++++++++----
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 225 +++++++++++++++++-
.../local/non_h_ints_mu/test_non_h_ints.irp.f | 92 ++++++-
.../local/non_h_ints_mu/total_tc_int.irp.f | 9 +-
7 files changed, 494 insertions(+), 217 deletions(-)
diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg
index c3ed29a3..23dde8ea 100644
--- a/plugins/local/jastrow/EZFIO.cfg
+++ b/plugins/local/jastrow/EZFIO.cfg
@@ -144,3 +144,10 @@ interface: ezfio,provider,ocaml
default: 1.0
ezfio_name: a_boys
+[nu_erf]
+type: double precision
+doc: e-e correlation in the core
+interface: ezfio,provider,ocaml
+default: 1.0
+ezfio_name: nu_erf
+
diff --git a/plugins/local/non_h_ints_mu/jast_1e.irp.f b/plugins/local/non_h_ints_mu/jast_1e.irp.f
index 1fc2fd2b..e994d27a 100644
--- a/plugins/local/non_h_ints_mu/jast_1e.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e.irp.f
@@ -78,7 +78,7 @@ END_PROVIDER
double precision :: cx, cy, cz
double precision :: time0, time1
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
- double precision, allocatable :: coef_fit(:), coef_fit2(:,:), coef_fit3(:,:)
+ double precision, allocatable :: coef_fit2(:,:)
PROVIDE j1e_type
@@ -163,75 +163,6 @@ END_PROVIDER
deallocate(Pa, Pb, Pt)
-! elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
-!
-! ! \grad_1 \sum_{\eta} C_{\eta} \chi_{\eta}
-! ! where
-! ! \chi_{\eta} are the AOs
-! ! C_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
-! !
-! ! The - sign is in the parameters C_{\eta}
-!
-! PROVIDE aos_grad_in_r_array
-!
-! allocate(coef_fit(ao_num))
-!
-! if(mpi_master) then
-! call ezfio_has_jastrow_j1e_coef_ao(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'
-! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao with MPI'
-! endif
-! IRP_ENDIF
-! if(exists) then
-! if(mpi_master) then
-! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao ] <<<<< ..'
-! call ezfio_get_jastrow_j1e_coef_ao(coef_fit)
-! IRP_IF MPI
-! call MPI_BCAST(coef_fit, ao_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao with MPI'
-! endif
-! IRP_ENDIF
-! endif
-! else
-!
-! call get_j1e_coef_fit_ao(ao_num, coef_fit)
-! call ezfio_set_jastrow_j1e_coef_ao(coef_fit)
-!
-! endif
-!
-! !$OMP PARALLEL &
-! !$OMP DEFAULT (NONE) &
-! !$OMP PRIVATE (i, ipoint, c) &
-! !$OMP SHARED (n_points_final_grid, ao_num, &
-! !$OMP aos_grad_in_r_array, coef_fit, &
-! !$OMP j1e_gradx, j1e_grady, j1e_gradz)
-! !$OMP DO SCHEDULE (static)
-! do ipoint = 1, n_points_final_grid
-!
-! j1e_gradx(ipoint) = 0.d0
-! j1e_grady(ipoint) = 0.d0
-! j1e_gradz(ipoint) = 0.d0
-! do i = 1, ao_num
-! c = coef_fit(i)
-! j1e_gradx(ipoint) = j1e_gradx(ipoint) + c * aos_grad_in_r_array(i,ipoint,1)
-! j1e_grady(ipoint) = j1e_grady(ipoint) + c * aos_grad_in_r_array(i,ipoint,2)
-! j1e_gradz(ipoint) = j1e_gradz(ipoint) + c * aos_grad_in_r_array(i,ipoint,3)
-! enddo
-! enddo
-! !$OMP END DO
-! !$OMP END PARALLEL
-!
-! deallocate(coef_fit)
-
elseif(j1e_type .eq. "Charge_Harmonizer_AO") then
! \grad_1 \sum_{\eta,\beta} C_{\eta,\beta} \chi_{\eta} \chi_{\beta}
@@ -271,10 +202,8 @@ END_PROVIDER
IRP_ENDIF
endif
else
-
call get_j1e_coef_fit_ao2(ao_num, coef_fit2)
call ezfio_set_jastrow_j1e_coef_ao2(coef_fit2)
-
endif
!$OMP PARALLEL &
@@ -305,78 +234,6 @@ END_PROVIDER
deallocate(coef_fit2)
-! elseif(j1e_type .eq. "Charge_Harmonizer_AO3") then
-!
-! ! \sum_{\eta} \vec{C}_{\eta} \chi_{\eta}
-! ! where
-! ! \chi_{\eta} are the AOs
-! ! \vec{C}_{\eta} are fitted to mimic (j1e_type .eq. "Charge_Harmonizer")
-! !
-! ! The - sign is in the parameters \vec{C}_{\eta}
-!
-! PROVIDE aos_grad_in_r_array
-!
-! allocate(coef_fit3(ao_num,3))
-!
-! if(mpi_master) then
-! call ezfio_has_jastrow_j1e_coef_ao3(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'
-! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao3 with MPI'
-! endif
-! IRP_ENDIF
-! if(exists) then
-! if(mpi_master) then
-! write(6,'(A)') '.. >>>>> [ IO READ: j1e_coef_ao3 ] <<<<< ..'
-! call ezfio_get_jastrow_j1e_coef_ao3(coef_fit3)
-! IRP_IF MPI
-! call MPI_BCAST(coef_fit3, (ao_num*3), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
-! if (ierr /= MPI_SUCCESS) then
-! stop 'Unable to read j1e_coef_ao3 with MPI'
-! endif
-! IRP_ENDIF
-! endif
-! else
-!
-! call get_j1e_coef_fit_ao3(ao_num, coef_fit3)
-! call ezfio_set_jastrow_j1e_coef_ao3(coef_fit3)
-!
-! endif
-!
-! !$OMP PARALLEL &
-! !$OMP DEFAULT (NONE) &
-! !$OMP PRIVATE (i, ipoint, cx, cy, cz) &
-! !$OMP SHARED (n_points_final_grid, ao_num, &
-! !$OMP aos_grad_in_r_array, coef_fit3, &
-! !$OMP aos_in_r_array, j1e_gradx, j1e_grady, j1e_gradz)
-! !$OMP DO SCHEDULE (static)
-! do ipoint = 1, n_points_final_grid
-!
-! j1e_gradx(ipoint) = 0.d0
-! j1e_grady(ipoint) = 0.d0
-! j1e_gradz(ipoint) = 0.d0
-! do i = 1, ao_num
-! cx = coef_fit3(i,1)
-! cy = coef_fit3(i,2)
-! cz = coef_fit3(i,3)
-!
-! j1e_gradx(ipoint) += cx * aos_in_r_array(i,ipoint)
-! j1e_grady(ipoint) += cy * aos_in_r_array(i,ipoint)
-! j1e_gradz(ipoint) += cz * aos_in_r_array(i,ipoint)
-! enddo
-! enddo
-! !$OMP END DO
-! !$OMP END PARALLEL
-!
-! deallocate(coef_fit3)
-
else
print *, ' Error in j1e_grad: Unknown j1e_type = ', j1e_type
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 79f780b1..7aa85148 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -128,7 +128,8 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
double precision :: g
double precision :: t0, t1
double precision :: cutoff_svd, D1_inv
- double precision, allocatable :: A(:,:,:,:), b(:)
+ double precision :: accu, norm, diff
+ double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
@@ -197,6 +198,9 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
, tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
, 0.d0, A(1,1,1,1), ao_num*ao_num)
+ allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
+ A_tmp = A
+
! --- --- ---
! get b
@@ -217,11 +221,6 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! solve Ax = b
-! double precision, allocatable :: A_inv(:,:,:,:)
-! allocate(A_inv(ao_num,ao_num,ao_num,ao_num))
-! call get_pseudo_inverse(A(1,1,1,1), ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A_inv(1,1,1,1), ao_num*ao_num, cutoff_svd)
-! A = A_inv
-
allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
allocate(work(1))
@@ -287,9 +286,30 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! coef_fit = A_inv x b
call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A(1,1,1,1), ao_num*ao_num, b(1), 1, 0.d0, coef_fit(1,1), 1)
- !call dgemm( "N", "N", ao_num*ao_num, 1, ao_num*ao_num, 1.d0 &
- ! , A(1,1,1,1), ao_num*ao_num, b(1), ao_num*ao_num &
- ! , 0.d0, coef_fit(1,1), ao_num*ao_num)
+
+ ! ---
+
+ accu = 0.d0
+ norm = 0.d0
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+ diff = 0.d0
+ do i = 1, ao_num
+ do j = 1, ao_num
+ diff += A_tmp(k,l,i,j) * coef_fit(j,i)
+ enddo
+ enddo
+
+ !print*, kl, b(kl)
+ accu += dabs(diff - b(kl))
+ norm += dabs(b(kl))
+ enddo
+ enddo
+ print*, ' accu total on Ax = b (%) = ', 100.d0*accu/norm
+ deallocate(A_tmp)
+
+ ! ---
deallocate(A, b)
diff --git a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
index 34c45df9..34d01fb2 100644
--- a/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_2e_utils.irp.f
@@ -12,12 +12,17 @@ BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_g
END_DOC
implicit none
- integer :: ipoint, i, j, jpoint
- double precision :: time0, time1
- double precision :: x, y, z, r2
- double precision :: dx, dy, dz
- double precision :: tmp_ct
- double precision :: tmp0, tmp1, tmp2, tmp3
+ integer :: ipoint, i, j, jpoint
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision :: time0, time1
+ double precision :: x, y, z, r2
+ double precision :: dx, dy, dz
+ double precision :: tmp_ct
+ double precision :: tmp0, tmp1, tmp2, tmp3
+ double precision, allocatable :: tmp(:,:,:)
+ double precision, allocatable :: tmp_u12(:,:)
PROVIDE j2e_type
PROVIDE Env_type
@@ -25,59 +30,152 @@ BEGIN_PROVIDER [double precision, int2_u2e_ao, (ao_num, ao_num, n_points_final_g
call wall_time(time0)
print*, ' providing int2_u2e_ao ...'
- if( (j2e_type .eq. "Mu") .and. &
- ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+ if(tc_integ_type .eq. "numeric") then
- PROVIDE mu_erf
- PROVIDE env_type env_val
- PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
- PROVIDE Ir2_Mu_gauss_Du
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
- tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, &
- !$OMP tmp0, tmp1, tmp2, tmp3) &
- !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
- !$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, &
- !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
- !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
- !$OMP Ir2_Mu_long_Du_2, int2_u2e_ao)
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
!$OMP DO SCHEDULE (static)
- do ipoint = 1, n_points_final_grid
-
- x = final_grid_points(1,ipoint)
- y = final_grid_points(2,ipoint)
- z = final_grid_points(3,ipoint)
- r2 = x*x + y*y + z*z
-
- dx = x * env_val(ipoint)
- dy = y * env_val(ipoint)
- dz = z * env_val(ipoint)
-
- tmp0 = 0.5d0 * env_val(ipoint) * r2
- tmp1 = 0.5d0 * env_val(ipoint)
- tmp3 = tmp_ct * env_val(ipoint)
-
- do j = 1, ao_num
- do i = 1, ao_num
-
- tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint)
-
- int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- else
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 1.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
- print *, ' Error in int2_u2e_ao: Unknown Jastrow'
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+
+ allocate(tmp_u12(n_points_extra_final_grid,n_blocks))
+
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
+ !$OMP final_grid_points, tmp_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_u12(1,i_blocks))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_u12(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_u2e_ao(1,1,ii), ao_num*ao_num)
+ enddo
+
+ deallocate(tmp_u12)
+
+ if(n_rest .gt. 0) then
+
+ allocate(tmp_u12(n_points_extra_final_grid,n_rest))
+
+ ii = n_pass*n_blocks + 1
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
+ !$OMP final_grid_points, tmp_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_u12_2e_r1_seq(ipoint, n_points_extra_final_grid, tmp_u12(1,i_rest))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_u12(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_u2e_ao(1,1,ii), ao_num*ao_num)
+
+ deallocate(tmp_u12)
+ endif
+
+ deallocate(tmp)
+
+ elseif(tc_integ_type .eq. "semi-analytic") then
+
+ if( (j2e_type .eq. "Mu") .and. &
+ ( (env_type .eq. "None") .or. (env_type .eq. "Prod_Gauss") .or. (env_type .eq. "Sum_Gauss") ) ) then
+
+ PROVIDE mu_erf
+ PROVIDE env_type env_val
+ PROVIDE Ir2_Mu_long_Du_0 Ir2_Mu_long_Du_x Ir2_Mu_long_Du_y Ir2_Mu_long_Du_z Ir2_Mu_long_Du_2
+ PROVIDE Ir2_Mu_gauss_Du
+
+ tmp_ct = 0.5d0 / (dsqrt(dacos(-1.d0)) * mu_erf)
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, x, y, z, r2, dx, dy, dz, &
+ !$OMP tmp0, tmp1, tmp2, tmp3) &
+ !$OMP SHARED (ao_num, n_points_final_grid, final_grid_points, &
+ !$OMP tmp_ct, env_val, Ir2_Mu_long_Du_0, &
+ !$OMP Ir2_Mu_long_Du_x, Ir2_Mu_long_Du_y, &
+ !$OMP Ir2_Mu_long_Du_z, Ir2_Mu_gauss_Du, &
+ !$OMP Ir2_Mu_long_Du_2, int2_u2e_ao)
+ !$OMP DO SCHEDULE (static)
+ do ipoint = 1, n_points_final_grid
+
+ x = final_grid_points(1,ipoint)
+ y = final_grid_points(2,ipoint)
+ z = final_grid_points(3,ipoint)
+ r2 = x*x + y*y + z*z
+
+ dx = x * env_val(ipoint)
+ dy = y * env_val(ipoint)
+ dz = z * env_val(ipoint)
+
+ tmp0 = 0.5d0 * env_val(ipoint) * r2
+ tmp1 = 0.5d0 * env_val(ipoint)
+ tmp3 = tmp_ct * env_val(ipoint)
+
+ do j = 1, ao_num
+ do i = 1, ao_num
+
+ tmp2 = tmp1 * Ir2_Mu_long_Du_2(i,j,ipoint) - dx * Ir2_Mu_long_Du_x(i,j,ipoint) - dy * Ir2_Mu_long_Du_y(i,j,ipoint) - dz * Ir2_Mu_long_Du_z(i,j,ipoint)
+
+ int2_u2e_ao(i,j,ipoint) = tmp0 * Ir2_Mu_long_Du_0(i,j,ipoint) + tmp2 - tmp3 * Ir2_Mu_gauss_Du(i,j,ipoint)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ else
+
+ print *, ' Error in int2_u2e_ao: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ else
+
+ print *, ' Error in int2_u2e_ao: Unknown tc_integ_type'
stop
- endif ! j2e_type
+ endif ! tc_integ_type
call wall_time(time1)
print*, ' wall time for int2_u2e_ao (min) =', (time1-time0)/60.d0
@@ -139,11 +237,10 @@ BEGIN_PROVIDER [double precision, int2_grad1_u2e_ao, (ao_num, ao_num, n_points_f
!$OMP END DO
!$OMP END PARALLEL
- ! n_points_final_grid = n_blocks * n_pass + n_rest
call total_memory(mem)
mem = max(1.d0, qp_max_mem - mem)
n_double = mem * 1.d8
- n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 3.d0), 1.d0*n_points_final_grid))
n_rest = int(mod(n_points_final_grid, n_blocks))
n_pass = int((n_points_final_grid - n_rest) / n_blocks)
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 9a5e35c6..ffb7b513 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -19,11 +19,13 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
double precision :: env_r1, tmp
double precision :: grad1_env(3), r1(3)
double precision, allocatable :: env_r2(:)
- double precision, allocatable :: u2b_r12(:)
- double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_r12(:), gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_mu(:), gradx1_mu(:), grady1_mu(:), gradz1_mu(:)
+ double precision, allocatable :: u2b_nu(:), gradx1_nu(:), grady1_nu(:), gradz1_nu(:)
double precision, external :: env_nucl
PROVIDE j1e_type j2e_type env_type
+ PROVIDE mu_erf nu_erf a_boys
PROVIDE final_grid_points
PROVIDE final_grid_points_extra
@@ -41,8 +43,8 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
else
- ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
- ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+ ! grad1 u(r1, r2) = [(grad1 j12_mu) v(r1) + j12_mu grad1 v(r1)] v(r2)
allocate(env_r2(n_grid2))
allocate(u2b_r12(n_grid2))
@@ -67,6 +69,46 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
endif ! env_type
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+ allocate(gradx1_mu(n_grid2), grady1_mu(n_grid2), gradz1_mu(n_grid2))
+ allocate(gradx1_nu(n_grid2), grady1_nu(n_grid2), gradz1_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, gradx1_mu, grady1_mu, gradz1_mu)
+ call grad1_jmu_r1_seq(nu_erf, r1, n_grid2, gradx1_nu, grady1_nu, gradz1_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = gradx1_nu(jpoint) + ((gradx1_mu(jpoint) - gradx1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = grady1_nu(jpoint) + ((grady1_mu(jpoint) - grady1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = gradz1_nu(jpoint) + ((gradz1_mu(jpoint) - gradz1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+ deallocate(gradx1_mu, grady1_mu, gradz1_mu)
+ deallocate(gradx1_nu, grady1_nu, gradz1_nu)
+
+ endif ! env_type
+
else
print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
@@ -99,6 +141,9 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
BEGIN_DOC
!
+ ! d/dx1 j_2e(1,2)
+ ! d/dy1 j_2e(1,2)
+ ! d/dz1 j_2e(1,2)
!
END_DOC
@@ -116,10 +161,13 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
+ PROVIDE j2e_type
+
if(j2e_type .eq. "Mu") then
- ! d/dx1 j(mu,r12) = 0.5 * (1 - erf(mu *r12))/r12 * (x1 - x2)
- !
+ ! d/dx1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (x1 - x2)
+ ! d/dy1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
+ ! d/dz1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
do jpoint = 1, n_points_extra_final_grid ! r2
@@ -185,7 +233,12 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Boys") then
- ! j(r12) = 0.5 r12 / (1 + a_boys r_12)
+ !
+ ! j(r12) = 0.5 r12 / (1 + a_boys r_12)
+ !
+ ! d/dx1 j(r12) = 0.5 (x1 - x2) / [r12 * (1 + b r12^2)^2]
+ ! d/dy1 j(r12) = 0.5 (y1 - y2) / [r12 * (1 + b r12^2)^2]
+ ! d/dz1 j(r12) = 0.5 (z1 - z2) / [r12 * (1 + b r12^2)^2]
PROVIDE a_boys
@@ -226,6 +279,58 @@ end
! ---
+subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
+
+ BEGIN_DOC
+ !
+ ! d/dx1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (x1 - x2)
+ ! d/dy1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
+ ! d/dz1 jmu(r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
+ !
+ END_DOC
+
+ implicit none
+ integer , intent(in) :: n_grid2
+ double precision, intent(in) :: mu, r1(3)
+ double precision, intent(out) :: gradx(n_grid2)
+ double precision, intent(out) :: grady(n_grid2)
+ double precision, intent(out) :: gradz(n_grid2)
+
+ integer :: jpoint
+ double precision :: r2(3)
+ double precision :: dx, dy, dz, r12, tmp
+
+
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
+ r2(1) = final_grid_points_extra(1,jpoint)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ dx = r1(1) - r2(1)
+ dy = r1(2) - r2(2)
+ dz = r1(3) - r2(3)
+
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ if(r12 .lt. 1d-10) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+ cycle
+ endif
+
+ tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
+
+ gradx(jpoint) = tmp * dx
+ grady(jpoint) = tmp * dy
+ gradz(jpoint) = tmp * dz
+ enddo
+
+ return
+end
+
+! ---
+
subroutine j12_r1_seq(r1, n_grid2, res)
include 'constants.include.F'
@@ -294,6 +399,44 @@ end
! ---
+subroutine jmu_r1_seq(mu, r1, n_grid2, res)
+
+ include 'constants.include.F'
+
+ implicit none
+ integer, intent(in) :: n_grid2
+ double precision, intent(in) :: mu, r1(3)
+ double precision, intent(out) :: res(n_grid2)
+
+ integer :: jpoint
+ double precision :: r2(3)
+ double precision :: dx, dy, dz
+ double precision :: r12, tmp1, tmp2
+
+ tmp1 = inv_sq_pi_2 / mu
+
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
+ r2(1) = final_grid_points_extra(1,jpoint)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ dx = r1(1) - r2(1)
+ dy = r1(2) - r2(2)
+ dz = r1(3) - r2(3)
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+
+ tmp2 = mu * r12
+
+ res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(tmp2)) - tmp1 * dexp(-tmp2*tmp2)
+ enddo
+
+ return
+end
+
+! ---
+
+
subroutine env_nucl_r1_seq(n_grid2, res)
! TODO
@@ -473,3 +616,71 @@ end
! ---
+subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
+
+ BEGIN_DOC
+ !
+ ! u_2e(r1,r2)
+ !
+ ! we use grid for r1 and extra_grid for r2
+ !
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: ipoint, n_grid2
+ double precision, intent(out) :: res(n_grid2)
+
+ integer :: jpoint
+ double precision :: env_r1, tmp
+ double precision :: grad1_env(3), r1(3)
+ double precision, allocatable :: env_r2(:)
+ double precision, allocatable :: u2b_r12(:)
+ double precision, external :: env_nucl
+
+ PROVIDE j1e_type j2e_type env_type
+ PROVIDE final_grid_points
+ PROVIDE final_grid_points_extra
+
+ r1(1) = final_grid_points(1,ipoint)
+ r1(2) = final_grid_points(2,ipoint)
+ r1(3) = final_grid_points(3,ipoint)
+
+ if( (j2e_type .eq. "Mu") .or. &
+ (j2e_type .eq. "Mur") .or. &
+ (j2e_type .eq. "Boys") ) then
+
+ if(env_type .eq. "None") then
+
+ call j12_r1_seq(r1, n_grid2, res)
+
+ else
+
+ ! u(r1,r2) = j12_mu(r12) x v(r1) x v(r2)
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_r12(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call j12_r1_seq(r1, n_grid2, u2b_r12)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ do jpoint = 1, n_points_extra_final_grid
+ res(jpoint) = env_r1 * u2b_r12(jpoint) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2, u2b_r12)
+
+ endif ! env_type
+
+ else
+
+ print *, ' Error in get_u12_withsq_r1_seq: Unknown Jastrow'
+ stop
+
+ endif ! j2e_type
+
+ return
+end
+
+! ---
+
diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
index c3fde334..464a1c1f 100644
--- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
+++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
@@ -43,7 +43,9 @@ program test_non_h
!call test_tc_grad_square_ao_new()
!call test_fit_coef_A1()
- call test_fit_coef_inv()
+ !call test_fit_coef_inv()
+
+ call test_fit_coef_testinvA()
end
! ---
@@ -1229,7 +1231,7 @@ subroutine test_fit_coef_inv()
implicit none
integer :: i, j, k, l, ij, kl, ipoint
- integer :: n_svd, info, lwork, mn
+ integer :: n_svd, info, lwork, mn, m, n
double precision :: t1, t2
double precision :: accu, norm, diff
double precision :: cutoff_svd, D1_inv
@@ -1237,7 +1239,6 @@ subroutine test_fit_coef_inv()
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
-
cutoff_svd = 5d-8
! ---
@@ -1435,11 +1436,92 @@ subroutine test_fit_coef_inv()
enddo
enddo
+ print*, ' accuracy on A_inv (%) = ', 100.d0 * accu / norm
+
deallocate(A1_inv, A2_inv)
deallocate(A1, A2)
- print*, ' accuracy on A_inv (%) = ', 100.d0 * accu / norm
-
+ return
+end
+
+! ---
+
+subroutine test_fit_coef_testinvA()
+
+ implicit none
+ integer :: i, j, k, l, m, n, ij, kl, mn, ipoint
+ double precision :: t1, t2
+ double precision :: accu, norm, diff
+ double precision :: cutoff_svd
+ double precision, allocatable :: A1(:,:), A1_inv(:,:)
+
+ cutoff_svd = 1d-17
+
+ ! ---
+
+ call wall_time(t1)
+
+ allocate(A1(ao_num*ao_num,ao_num*ao_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ij, kl, ipoint) &
+ !$OMP SHARED (n_points_final_grid, ao_num, &
+ !$OMP final_weight_at_r_vector, aos_in_r_array_transp, A1)
+ !$OMP DO COLLAPSE(2)
+ do k = 1, ao_num
+ do l = 1, ao_num
+ kl = (k-1)*ao_num + l
+
+ do i = 1, ao_num
+ do j = 1, ao_num
+ ij = (i-1)*ao_num + j
+
+ A1(ij,kl) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ A1(ij,kl) += final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j) &
+ * aos_in_r_array_transp(ipoint,k) * aos_in_r_array_transp(ipoint,l)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print*, ' WALL TIME FOR A1 (min) =', (t2-t1)/60.d0
+
+ allocate(A1_inv(ao_num*ao_num,ao_num*ao_num))
+ call get_pseudo_inverse(A1, ao_num*ao_num, ao_num*ao_num, ao_num*ao_num, A1_inv, ao_num*ao_num, cutoff_svd)
+
+ call wall_time(t1)
+ print*, ' WALL TIME FOR A1_inv (min) =', (t1-t2)/60.d0
+
+ ! ---
+
+ print*, ' check inv'
+
+ do kl = 1, ao_num*ao_num
+ do ij = 1, ao_num*ao_num
+
+ diff = 0.d0
+ do mn = 1, ao_num*ao_num
+ diff += A1(kl,mn) * A1_inv(mn,ij)
+ enddo
+
+ if(kl .eq. ij) then
+ accu += dabs(diff - 1.d0)
+ else
+ accu += dabs(diff - 0.d0)
+ endif
+ enddo
+ enddo
+
+ print*, ' accuracy (%) = ', accu * 100.d0
+
+ deallocate(A1, A1_inv)
+
return
end
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index 38da4047..9d3cf565 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -125,7 +125,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
- , 1.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
FREE int2_u2_env2
endif ! use_ipp
@@ -166,12 +166,15 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
do m = 1, 3
call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
, int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
- , 1.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
enddo
deallocate(b_mat)
FREE int2_grad1_u12_ao
- FREE int2_grad1_u2e_ao
+
+ if(tc_integ_type .eq. "semi-analytic") then
+ FREE int2_grad1_u2e_ao
+ endif
endif ! var_tc
From acd26fdeb0b1ace9b1a06a72498b8f9709e0283b Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 4 Feb 2024 13:29:10 +0100
Subject: [PATCH 012/140] doc for Mu_Nu
---
plugins/local/jastrow/README.md | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/plugins/local/jastrow/README.md b/plugins/local/jastrow/README.md
index 67898e23..089aa72d 100644
--- a/plugins/local/jastrow/README.md
+++ b/plugins/local/jastrow/README.md
@@ -20,6 +20,12 @@ The main keywords are:
+3. **Mu_Nu:** A valence and a core correlation terms are used
+
+
+
+ with envelop \(v\).
+
## env_type Options
From 824336d939a90c652b371e2890c53424d261608a Mon Sep 17 00:00:00 2001
From: AbdAmmar <59544987+AbdAmmar@users.noreply.github.com>
Date: Sun, 4 Feb 2024 13:30:55 +0100
Subject: [PATCH 013/140] Update README.md
---
plugins/local/jastrow/README.md | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/plugins/local/jastrow/README.md b/plugins/local/jastrow/README.md
index 089aa72d..a9e568db 100644
--- a/plugins/local/jastrow/README.md
+++ b/plugins/local/jastrow/README.md
@@ -22,7 +22,7 @@ The main keywords are:
3. **Mu_Nu:** A valence and a core correlation terms are used
-
+
with envelop \(v\).
From da2ee2072305b36a9dc2b555566483d67c611a74 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 4 Feb 2024 19:56:23 +0100
Subject: [PATCH 014/140] added 1e-term to Mu_Nu
---
.../local/non_h_ints_mu/jast_1e_utils.irp.f | 34 +++------
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 73 +++++++++++++++++++
.../local/non_h_ints_mu/tc_integ_num.irp.f | 1 -
3 files changed, 85 insertions(+), 23 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 7aa85148..9cfabf58 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -126,9 +126,9 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
integer :: ij, kl, mn
integer :: info, n_svd, LWORK
double precision :: g
- double precision :: t0, t1
+ double precision :: t0, t1, svd_t0, svd_t1
double precision :: cutoff_svd, D1_inv
- double precision :: accu, norm, diff
+ double precision, allocatable :: diff(:)
double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
@@ -211,9 +211,6 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
enddo
call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
- !call dgemm( "T", "N", ao_num*ao_num, 1, n_points_final_grid, 1.d0 &
- ! , tmp(1,1,1), n_points_final_grid, u1e_tmp(1), n_points_final_grid &
- ! , 0.d0, b(1), ao_num*ao_num)
deallocate(u1e_tmp)
deallocate(tmp)
@@ -223,6 +220,8 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
allocate(D(ao_num*ao_num), U(ao_num*ao_num,ao_num*ao_num), Vt(ao_num*ao_num,ao_num*ao_num))
+ call wall_time(svd_t0)
+
allocate(work(1))
lwork = -1
call dgesvd( 'S', 'A', ao_num*ao_num, ao_num*ao_num, A(1,1,1,1), ao_num*ao_num &
@@ -244,6 +243,9 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
deallocate(work)
+ call wall_time(svd_t1)
+ print*, ' SVD time (min) ', (svd_t1-svd_t0)/60.d0
+
if(D(1) .lt. 1d-14) then
print*, ' largest singular value is very small:', D(1)
n_svd = 1
@@ -289,24 +291,12 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! ---
- accu = 0.d0
- norm = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- kl = (k-1)*ao_num + l
- diff = 0.d0
- do i = 1, ao_num
- do j = 1, ao_num
- diff += A_tmp(k,l,i,j) * coef_fit(j,i)
- enddo
- enddo
+ allocate(diff(ao_num*ao_num))
- !print*, kl, b(kl)
- accu += dabs(diff - b(kl))
- norm += dabs(b(kl))
- enddo
- enddo
- print*, ' accu total on Ax = b (%) = ', 100.d0*accu/norm
+ call dgemv("N", ao_num*ao_num, ao_num*ao_num, 1.d0, A_tmp(1,1,1,1), ao_num*ao_num, coef_fit(1,1), 1, 0.d0, diff(1), 1)
+ print*, ' accu total on Ax = b (%) = ', 100.d0*sum(dabs(diff-b))/sum(dabs(b))
+
+ deallocate(diff)
deallocate(A_tmp)
! ---
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index ffb7b513..5777a44a 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -558,6 +558,8 @@ subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
double precision, allocatable :: env_r2(:)
double precision, allocatable :: u2b_r12(:)
double precision, allocatable :: gradx1_u2b(:), grady1_u2b(:), gradz1_u2b(:)
+ double precision, allocatable :: u2b_mu(:), gradx1_mu(:), grady1_mu(:), gradz1_mu(:)
+ double precision, allocatable :: u2b_nu(:), gradx1_nu(:), grady1_nu(:), gradz1_nu(:)
double precision, external :: env_nucl
PROVIDE j1e_type j2e_type env_type
@@ -604,6 +606,46 @@ subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
endif ! env_type
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, resx, resy, resz)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+ allocate(gradx1_mu(n_grid2), grady1_mu(n_grid2), gradz1_mu(n_grid2))
+ allocate(gradx1_nu(n_grid2), grady1_nu(n_grid2), gradz1_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call grad1_env_nucl(r1, grad1_env)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ call grad1_jmu_r1_seq(mu_erf, r1, n_grid2, gradx1_mu, grady1_mu, gradz1_mu)
+ call grad1_jmu_r1_seq(nu_erf, r1, n_grid2, gradx1_nu, grady1_nu, gradz1_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ resx(jpoint) = gradx1_nu(jpoint) + ((gradx1_mu(jpoint) - gradx1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(1)) * env_r2(jpoint)
+ resy(jpoint) = grady1_nu(jpoint) + ((grady1_mu(jpoint) - grady1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(2)) * env_r2(jpoint)
+ resz(jpoint) = gradz1_nu(jpoint) + ((gradz1_mu(jpoint) - gradz1_nu(jpoint)) * env_r1 + (u2b_mu(jpoint) - u2b_nu(jpoint)) * grad1_env(3)) * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+ deallocate(gradx1_mu, grady1_mu, gradz1_mu)
+ deallocate(gradx1_nu, grady1_nu, gradz1_nu)
+
+ endif ! env_type
+
else
print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
@@ -635,6 +677,7 @@ subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
double precision :: grad1_env(3), r1(3)
double precision, allocatable :: env_r2(:)
double precision, allocatable :: u2b_r12(:)
+ double precision, allocatable :: u2b_mu(:), u2b_nu(:)
double precision, external :: env_nucl
PROVIDE j1e_type j2e_type env_type
@@ -672,6 +715,36 @@ subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
endif ! env_type
+ elseif(j2e_type .eq. "Mu_Nu") then
+
+ if(env_type .eq. "None") then
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, res)
+
+ else
+
+ ! u(r1,r2) = jmu(r12) x v(r1) x v(r2) + jnu(r12) x [1 - v(r1) x v(r2)]
+
+ allocate(env_r2(n_grid2))
+ allocate(u2b_mu(n_grid2))
+ allocate(u2b_nu(n_grid2))
+
+ env_r1 = env_nucl(r1)
+ call env_nucl_r1_seq(n_grid2, env_r2)
+
+ call jmu_r1_seq(mu_erf, r1, n_grid2, u2b_mu)
+ call jmu_r1_seq(nu_erf, r1, n_grid2, u2b_nu)
+
+ do jpoint = 1, n_points_extra_final_grid
+ res(jpoint) = u2b_nu(jpoint) + (u2b_mu(jpoint) - u2b_nu(jpoint)) * env_r1 * env_r2(jpoint)
+ enddo
+
+ deallocate(env_r2)
+ deallocate(u2b_mu)
+ deallocate(u2b_nu)
+
+ endif ! env_type
+
else
print *, ' Error in get_u12_withsq_r1_seq: Unknown Jastrow'
diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
index 6b6e755d..e5d75c3d 100644
--- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
@@ -45,7 +45,6 @@
!$OMP END DO
!$OMP END PARALLEL
- ! n_points_final_grid = n_blocks * n_pass + n_rest
call total_memory(mem)
mem = max(1.d0, qp_max_mem - mem)
n_double = mem * 1.d8
From b5b0cdb27a734162c2f0ab90e0aa83b33d13d490 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 8 Feb 2024 08:50:14 +0100
Subject: [PATCH 015/140] README.md
---
README.md | 4 ++++
external/ezfio | 2 +-
external/irpf90 | 2 +-
src/ao_one_e_ints/spread_dipole_ao.irp.f | 2 +-
4 files changed, 7 insertions(+), 3 deletions(-)
diff --git a/README.md b/README.md
index b03f2ecc..5a35f63d 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,7 @@
+**Important**: The Intel ifx compiler is not able to produce correct
+executables for Quantum Package. Please use ifort as long as you can, and
+consider switching to gfortran in the long term.
+
# Quantum Package 2.2
diff --git a/external/ezfio b/external/ezfio
index d5805497..dba01c4f 160000
--- a/external/ezfio
+++ b/external/ezfio
@@ -1 +1 @@
-Subproject commit d5805497fa0ef30e70e055cde1ecec2963303e93
+Subproject commit dba01c4fe0ff7b84c5ecfb1c7c77ec68781311b3
diff --git a/external/irpf90 b/external/irpf90
index 0007f72f..4ab1b175 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 0007f72f677fe7d61c5e1ed461882cb239517102
+Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
diff --git a/src/ao_one_e_ints/spread_dipole_ao.irp.f b/src/ao_one_e_ints/spread_dipole_ao.irp.f
index c52d0548..86469a3f 100644
--- a/src/ao_one_e_ints/spread_dipole_ao.irp.f
+++ b/src/ao_one_e_ints/spread_dipole_ao.irp.f
@@ -224,7 +224,7 @@
subroutine overlap_bourrin_spread(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx)
BEGIN_DOC
! Computes the following integral :
-! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) * x ]
+! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) * x^2 ]
! needed for the dipole and those things
END_DOC
implicit none
From 5296ce031d6707b9d4587ac8abb38a2ccd36d4c3 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 8 Feb 2024 08:51:00 +0100
Subject: [PATCH 016/140] Update README.md
---
README.md | 3 +++
1 file changed, 3 insertions(+)
diff --git a/README.md b/README.md
index 5a35f63d..7a9503d7 100644
--- a/README.md
+++ b/README.md
@@ -2,6 +2,9 @@
executables for Quantum Package. Please use ifort as long as you can, and
consider switching to gfortran in the long term.
+---
+
+
# Quantum Package 2.2
From 5b5df61960aad048452bd398c1ec584fffa9c267 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 8 Feb 2024 14:13:10 +0100
Subject: [PATCH 017/140] Fixed linear algebra
---
config/ifort_2021_avx.cfg | 2 +-
config/ifort_2021_avx_mpi.cfg | 2 +-
config/ifort_2021_avx_notz.cfg | 2 +-
config/ifort_2021_debug.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/utils/linear_algebra.irp.f | 3 ++-
10 files changed, 11 insertions(+), 10 deletions(-)
diff --git a/config/ifort_2021_avx.cfg b/config/ifort_2021_avx.cfg
index 6c34cf47..55fe0ee7 100644
--- a/config/ifort_2021_avx.cfg
+++ b/config/ifort_2021_avx.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
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 4c893c73..362f482a 100644
--- a/config/ifort_2021_avx_mpi.cfg
+++ b/config/ifort_2021_avx_mpi.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 -DMPI -DINTEL
diff --git a/config/ifort_2021_avx_notz.cfg b/config/ifort_2021_avx_notz.cfg
index 1fa595d7..3cd80236 100644
--- a/config/ifort_2021_avx_notz.cfg
+++ b/config/ifort_2021_avx_notz.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --define=WITHOUT_TRAILZ --define=WITHOUT_SHIFTRL
diff --git a/config/ifort_2021_debug.cfg b/config/ifort_2021_debug.cfg
index 80802f33..2e30642c 100644
--- a/config/ifort_2021_debug.cfg
+++ b/config/ifort_2021_debug.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 --assert -DINTEL
diff --git a/config/ifort_2021_mpi_rome.cfg b/config/ifort_2021_mpi_rome.cfg
index e47a466e..b7341388 100644
--- a/config/ifort_2021_mpi_rome.cfg
+++ b/config/ifort_2021_mpi_rome.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
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 504438c9..1d2d8c77 100644
--- a/config/ifort_2021_rome.cfg
+++ b/config/ifort_2021_rome.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
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 07c3ebb8..e43147ba 100644
--- a/config/ifort_2021_sse4.cfg
+++ b/config/ifort_2021_sse4.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic
+FC : ifort -fpic -diag-disable=10448
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 f3fa0eaa..1914988b 100644
--- a/config/ifort_2021_sse4_mpi.cfg
+++ b/config/ifort_2021_sse4_mpi.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : mpiifort -fpic
+FC : mpiifort -fpic -diag-disable=10448
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 9170b059..0dfce550 100644
--- a/config/ifort_2021_xHost.cfg
+++ b/config/ifort_2021_xHost.cfg
@@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary
#
[COMMON]
-FC : ifort -fpic -diag-disable 5462
+FC : ifort -fpic -diag-disable=5462 -diag-disable=10448
LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=64 -DINTEL
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 075525d1..c9d0be72 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -645,13 +645,14 @@ subroutine get_pseudo_inverse_complex(A,LDA,m,n,C,LDC,cutoff)
END_DOC
integer, intent(in) :: m,n, LDA, LDC
complex*16, intent(in) :: A(LDA,n)
- double precision, intent(in) :: cutoff, d1
+ double precision, intent(in) :: cutoff
complex*16, intent(out) :: C(LDC,m)
double precision, allocatable :: D(:), rwork(:)
complex*16, allocatable :: U(:,:), Vt(:,:), work(:), A_tmp(:,:)
integer :: info, lwork
integer :: i,j,k
+ double precision :: d1
allocate (D(n),U(m,n),Vt(n,n),work(1),A_tmp(m,n),rwork(5*n))
do j=1,n
do i=1,m
From 419ed79c49a89382f3e473df647c9624a4f3e759 Mon Sep 17 00:00:00 2001
From: eginer
Date: Sat, 10 Feb 2024 12:48:29 +0100
Subject: [PATCH 018/140] added transition two rdm
---
src/davidson/u0_wee_u0.irp.f | 22 +
src/two_body_rdm/act_2_transition_rdm.irp.f | 39 +
src/two_body_rdm/example.irp.f | 88 ++
src/two_body_rdm/io_two_rdm.irp.f | 34 +
src/two_body_rdm/test_2_rdm.irp.f | 1 +
.../davidson_like_trans_2rdm.irp.f | 585 ++++++++++
src/two_rdm_routines/update_trans_rdm.irp.f | 1002 +++++++++++++++++
7 files changed, 1771 insertions(+)
create mode 100644 src/two_body_rdm/act_2_transition_rdm.irp.f
create mode 100644 src/two_rdm_routines/davidson_like_trans_2rdm.irp.f
create mode 100644 src/two_rdm_routines/update_trans_rdm.irp.f
diff --git a/src/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f
index 0c543aca..bd3525e1 100644
--- a/src/davidson/u0_wee_u0.irp.f
+++ b/src/davidson/u0_wee_u0.irp.f
@@ -492,3 +492,25 @@ subroutine u_0_H_u_0_two_e(e_0,u_0,n,keys_tmp,Nint,N_st,sze)
deallocate (s_0, v_0)
end
+BEGIN_PROVIDER [double precision, psi_energy_two_e_trans, (N_states, N_states)]
+ implicit none
+ BEGIN_DOC
+! psi_energy_two_e_trans(istate,jstate) =
+ END_dOC
+ integer :: i,j,istate,jstate
+ double precision :: hij, coef_i, coef_j
+ psi_energy_two_e_trans = 0.d0
+ do i = 1, N_det
+ do j = 1, N_det
+ call i_H_j_two_e(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
+ do istate = 1, N_states
+ coef_i = psi_coef(i,istate)
+ do jstate = 1, N_states
+ coef_j = psi_coef(j,jstate)
+ psi_energy_two_e_trans(jstate,istate) += coef_i * coef_j * hij
+ enddo
+ enddo
+ enddo
+ enddo
+
+END_PROVIDER
diff --git a/src/two_body_rdm/act_2_transition_rdm.irp.f b/src/two_body_rdm/act_2_transition_rdm.irp.f
new file mode 100644
index 00000000..3d08b084
--- /dev/null
+++ b/src/two_body_rdm/act_2_transition_rdm.irp.f
@@ -0,0 +1,39 @@
+ BEGIN_PROVIDER [double precision, act_2_rdm_trans_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states,N_states)]
+ implicit none
+ BEGIN_DOC
+! act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2rdm_trans
+!
+! \sum_{\sigma,\sigma'}
+!
+! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
+!
+! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec}^{act} * (N_{elec}^{act} - 1)
+!
+! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act"
+ END_DOC
+ integer :: ispin
+ double precision :: wall_1, wall_2
+ ! condition for beta/beta spin
+ print*,''
+ print*,'Providing act_2_rdm_trans_spin_trace_mo '
+ character*(128) :: name_file
+ name_file = 'act_2_rdm_trans_spin_trace_mo'
+ ispin = 4
+ act_2_rdm_trans_spin_trace_mo = 0.d0
+ call wall_time(wall_1)
+! if(read_two_body_rdm_trans_spin_trace)then
+! print*,'Reading act_2_rdm_trans_spin_trace_mo from disk ...'
+! call read_array_two_rdm_trans(n_act_orb,N_states,act_2_rdm_trans_spin_trace_mo,name_file)
+! else
+ call orb_range_2_trans_rdm_openmp(act_2_rdm_trans_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1))
+! endif
+! if(write_two_body_rdm_trans_spin_trace)then
+! print*,'Writing act_2_rdm_trans_spin_trace_mo on disk ...'
+! call write_array_two_rdm_trans(n_act_orb,n_states,act_2_rdm_trans_spin_trace_mo,name_file)
+! call ezfio_set_two_body_rdm_trans_io_two_body_rdm_trans_spin_trace("Read")
+! endif
+
+ act_2_rdm_trans_spin_trace_mo *= 2.d0
+ call wall_time(wall_2)
+ print*,'Wall time to provide act_2_rdm_trans_spin_trace_mo',wall_2 - wall_1
+ END_PROVIDER
diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f
index 30e2685a..38510fe9 100644
--- a/src/two_body_rdm/example.irp.f
+++ b/src/two_body_rdm/example.irp.f
@@ -365,3 +365,91 @@ subroutine routine_full_mos
end
+
+subroutine routine_active_only_trans
+ implicit none
+ integer :: i,j,k,l,iorb,jorb,korb,lorb,istate,jstate
+ BEGIN_DOC
+! This routine computes the two electron repulsion within the active space using various providers
+!
+ END_DOC
+
+ double precision :: vijkl,get_two_e_integral
+ double precision :: wee_tot(N_states,N_states),rdm_transtot
+ double precision :: spin_trace
+ double precision :: accu_tot
+
+ wee_tot = 0.d0
+
+
+ iorb = 1
+ jorb = 1
+ korb = 1
+ lorb = 1
+ vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
+ provide act_2_rdm_trans_spin_trace_mo
+ i = 1
+ j = 2
+
+ print*,'**************************'
+ print*,'**************************'
+ do jstate = 1, N_states
+ do istate = 1, N_states
+ !! PURE ACTIVE PART
+ !!
+ accu_tot = 0.d0
+ do i = 1, n_act_orb
+ iorb = list_act(i)
+ do j = 1, n_act_orb
+ jorb = list_act(j)
+ do k = 1, n_act_orb
+ korb = list_act(k)
+ do l = 1, n_act_orb
+ lorb = list_act(l)
+ ! 1 2 1 2 2 1 2 1
+! if(dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate)).gt.1.d-10)then
+! print*,'Error in act_2_rdm_trans_spin_trace_mo'
+! print*,"dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l) - act_2_rdm_trans_spin_trace_mo(j,i,l,k)).gt.1.d-10"
+! print*,i,j,k,l
+! print*,act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate),act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate),dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(j,i,l,k,istate,jstate))
+! endif
+
+ ! 1 2 1 2 1 2 1 2
+! if(dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate)).gt.1.d-10)then
+! print*,'Error in act_2_rdm_trans_spin_trace_mo'
+! print*,"dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate)).gt.1.d-10"
+! print*,i,j,k,l
+! print*,act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate),act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate),dabs(act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) - act_2_rdm_trans_spin_trace_mo(k,l,i,j,istate,jstate))
+! endif
+
+ vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map)
+
+
+ rdm_transtot = act_2_rdm_trans_spin_trace_mo(l,k,j,i,istate,jstate)
+
+ wee_tot(istate,jstate) += 0.5d0 * vijkl * rdm_transtot
+
+ enddo
+ enddo
+ enddo
+ enddo
+ print*,''
+ print*,''
+ print*,'Active space only energy for state ',istate,jstate
+ print*,'wee_tot = ',wee_tot(istate,jstate)
+ print*,'Full energy '
+ print*,'psi_energy_two_e(istate,jstate)= ',psi_energy_two_e_trans(istate,jstate)
+ print*,'--------------------------'
+ enddo
+ enddo
+ print*,'Wee from DM '
+ do istate = 1,N_states
+ write(*,'(100(F16.10,X))')wee_tot(1:N_states,istate)
+ enddo
+ print*,'Wee from Psi det'
+ do istate = 1,N_states
+ write(*,'(100(F16.10,X))')psi_energy_two_e_trans(1:N_states,istate)
+ enddo
+
+end
+
diff --git a/src/two_body_rdm/io_two_rdm.irp.f b/src/two_body_rdm/io_two_rdm.irp.f
index bdd8a4f9..0b30d76f 100644
--- a/src/two_body_rdm/io_two_rdm.irp.f
+++ b/src/two_body_rdm/io_two_rdm.irp.f
@@ -31,3 +31,37 @@ subroutine read_array_two_rdm(n_orb,nstates,array_tmp,name_file)
close(unit=i_unit_output)
end
+
+subroutine write_array_two_trans_rdm(n_orb,nstates,array_tmp,name_file)
+ implicit none
+ integer, intent(in) :: n_orb,nstates
+ character*(128), intent(in) :: name_file
+ double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,nstates,nstates)
+
+ 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')
+ call lock_io()
+ write(i_unit_output)array_tmp
+ call unlock_io()
+ close(unit=i_unit_output)
+end
+
+subroutine read_array_two_trans_rdm(n_orb,nstates,array_tmp,name_file)
+ implicit none
+ character*(128) :: output
+ integer :: i_unit_output,getUnitAndOpen
+ integer, intent(in) :: n_orb,nstates
+ character*(128), intent(in) :: name_file
+ double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,N_states,nstates)
+ PROVIDE ezfio_filename
+ output=trim(ezfio_filename)//'/work/'//trim(name_file)
+ i_unit_output = getUnitAndOpen(output,'R')
+ call lock_io()
+ read(i_unit_output)array_tmp
+ call unlock_io()
+ close(unit=i_unit_output)
+end
+
diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f
index 123261d8..de2606a7 100644
--- a/src/two_body_rdm/test_2_rdm.irp.f
+++ b/src/two_body_rdm/test_2_rdm.irp.f
@@ -4,5 +4,6 @@ program test_2_rdm
touch read_wf
call routine_active_only
call routine_full_mos
+ call routine_active_only_trans
end
diff --git a/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f b/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f
new file mode 100644
index 00000000..9e68a0e1
--- /dev/null
+++ b/src/two_rdm_routines/davidson_like_trans_2rdm.irp.f
@@ -0,0 +1,585 @@
+subroutine orb_range_2_trans_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze)
+ use bitmasks
+ implicit none
+ BEGIN_DOC
+ ! if ispin == 1 :: alpha/alpha 2_rdm
+ ! == 2 :: beta /beta 2_rdm
+ ! == 3 :: alpha/beta + beta/alpha 2trans_rdm
+ ! == 4 :: spin traced 2_rdm :: aa + bb + ab + ba
+ !
+ ! notice that here it is the TRANSITION RDM THAT IS COMPUTED
+ !
+ ! THE DIAGONAL PART IS THE USUAL ONE FOR A GIVEN STATE
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+ integer, intent(in) :: N_st,sze
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+ double precision, intent(in) :: u_0(sze,N_st)
+
+ integer :: k
+ double precision, allocatable :: u_t(:,:)
+ !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
+ PROVIDE mo_two_e_integrals_in_map
+ allocate(u_t(N_st,N_det))
+ do k=1,N_st
+ call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
+ enddo
+ call dtranspose( &
+ u_0, &
+ size(u_0, 1), &
+ u_t, &
+ size(u_t, 1), &
+ N_det, N_st)
+
+ call orb_range_2_trans_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1)
+ deallocate(u_t)
+
+ do k=1,N_st
+ call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+ enddo
+
+end
+
+subroutine orb_range_2_trans_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ use bitmasks
+ implicit none
+ BEGIN_DOC
+ ! Computes two-trans_rdm
+ !
+ ! Default should be 1,N_det,0,1
+ END_DOC
+ integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+ double precision, intent(in) :: u_t(N_st,N_det)
+
+ integer :: k
+
+ PROVIDE N_int
+
+ select case (N_int)
+ case (1)
+ call orb_range_2_trans_rdm_openmp_work_1(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (2)
+ call orb_range_2_trans_rdm_openmp_work_2(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (3)
+ call orb_range_2_trans_rdm_openmp_work_3(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case (4)
+ call orb_range_2_trans_rdm_openmp_work_4(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ case default
+ call orb_range_2_trans_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ end select
+end
+
+
+ BEGIN_TEMPLATE
+subroutine orb_range_2_trans_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep)
+ use bitmasks
+ use omp_lib
+ implicit none
+ BEGIN_DOC
+ ! Computes the two trans_rdm for the N_st vectors |u_t>
+ ! if ispin == 1 :: alpha/alpha 2trans_rdm
+ ! == 2 :: beta /beta 2trans_rdm
+ ! == 3 :: alpha/beta 2trans_rdm
+ ! == 4 :: spin traced 2trans_rdm :: aa + bb + 0.5 (ab + ba))
+ ! The 2trans_rdm will be computed only on the list of orbitals list_orb, which contains norb
+ ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep
+ END_DOC
+ integer, intent(in) :: N_st,sze,istart,iend,ishift,istep
+ double precision, intent(in) :: u_t(N_st,N_det)
+ integer, intent(in) :: dim1,norb,list_orb(norb),ispin
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st,N_st)
+
+ integer(omp_lock_kind) :: lock_2trans_rdm
+ integer :: i,j,k,l
+ integer :: k_a, k_b, l_a, l_b
+ integer :: krow, kcol
+ integer :: lrow, lcol
+ integer(bit_kind) :: spindet($N_int)
+ integer(bit_kind) :: tmp_det($N_int,2)
+ integer(bit_kind) :: tmp_det2($N_int,2)
+ integer(bit_kind) :: tmp_det3($N_int,2)
+ integer(bit_kind), allocatable :: buffer(:,:)
+ integer :: n_doubles
+ integer, allocatable :: doubles(:)
+ integer, allocatable :: singles_a(:)
+ integer, allocatable :: singles_b(:)
+ integer, allocatable :: idx(:), idx0(:)
+ integer :: maxab, n_singles_a, n_singles_b, kcol_prev
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ integer(bit_kind) :: orb_bitmask($N_int)
+ integer :: list_orb_reverse(mo_num)
+ integer, allocatable :: keys(:,:)
+ double precision, allocatable :: values(:,:,:)
+ integer :: nkeys,sze_buff
+ integer :: ll
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ else
+ print*,'Wrong parameter for ispin in general_2_trans_rdm_state_av_openmp_work'
+ print*,'ispin = ',ispin
+ stop
+ endif
+
+
+ PROVIDE N_int
+
+ call list_to_bitstring( orb_bitmask, list_orb, norb, N_int)
+ sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60
+ list_orb_reverse = -1000
+ do i = 1, norb
+ list_orb_reverse(list_orb(i)) = i
+ enddo
+ maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
+ allocate(idx0(maxab))
+
+ do i=1,maxab
+ idx0(i) = i
+ enddo
+ call omp_init_lock(lock_2trans_rdm)
+
+ ! Prepare the array of all alpha single excitations
+ ! -------------------------------------------------
+
+ PROVIDE N_int nthreads_davidson elec_alpha_num
+ !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) &
+ !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2trans_rdm,&
+ !$OMP psi_bilinear_matrix_columns, &
+ !$OMP psi_det_alpha_unique, psi_det_beta_unique,&
+ !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,&
+ !$OMP psi_bilinear_matrix_transp_rows, &
+ !$OMP psi_bilinear_matrix_transp_columns, &
+ !$OMP psi_bilinear_matrix_transp_order, N_st, &
+ !$OMP psi_bilinear_matrix_order_transp_reverse, &
+ !$OMP psi_bilinear_matrix_columns_loc, &
+ !$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, &
+ !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, dim1, &
+ !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) &
+ !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, &
+ !$OMP lcol, lrow, l_a, l_b, &
+ !$OMP buffer, doubles, n_doubles, &
+ !$OMP tmp_det2, idx, l, kcol_prev, &
+ !$OMP singles_a, n_singles_a, singles_b, &
+ !$OMP n_singles_b, nkeys, keys, values)
+
+ ! Alpha/Beta double excitations
+ ! =============================
+ nkeys = 0
+ allocate( keys(4,sze_buff), values(n_st,n_st,sze_buff))
+ allocate( buffer($N_int,maxab), &
+ singles_a(maxab), &
+ singles_b(maxab), &
+ doubles(maxab), &
+ idx(maxab))
+
+ kcol_prev=-1
+
+ ASSERT (iend <= N_det)
+ ASSERT (istart > 0)
+ ASSERT (istep > 0)
+
+ !$OMP DO SCHEDULE(dynamic,64)
+ do k_a=istart+ishift,iend,istep
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ if (kcol /= kcol_prev) then
+ call get_all_spin_singles_$N_int( &
+ psi_det_beta_unique, idx0, &
+ tmp_det(1,2), N_det_beta_unique, &
+ singles_b, n_singles_b)
+ endif
+ kcol_prev = kcol
+
+ ! Loop over singly excited beta columns
+ ! -------------------------------------
+
+ do i=1,n_singles_b
+ lcol = singles_b(i)
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
+
+ l_a = psi_bilinear_matrix_columns_loc(lcol)
+ ASSERT (l_a <= N_det)
+
+ do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow)
+
+ ASSERT (l_a <= N_det)
+ idx(j) = l_a
+ l_a = l_a+1
+ enddo
+ j = j-1
+
+ call get_all_spin_singles_$N_int( &
+ buffer, idx, tmp_det(1,1), j, &
+ singles_a, n_singles_a )
+
+ ! Loop over alpha singles
+ ! -----------------------
+
+ if(alpha_beta.or.spin_trace)then
+ do k = 1,n_singles_a
+ l_a = singles_a(k)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+! print*,'nkeys before = ',nkeys
+ do ll = 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta)then
+ ! only ONE contribution
+ if (nkeys+1 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ else if (spin_trace)then
+ ! TWO contributions
+ if (nkeys+2 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ endif
+ call orb_range_off_diag_double_to_all_states_ab_trans_rdm_buffer(tmp_det,tmp_det2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+
+ enddo
+ endif
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ enddo
+
+ enddo
+ !$OMP END DO
+
+ !$OMP DO SCHEDULE(dynamic,64)
+ do k_a=istart+ishift,iend,istep
+
+
+ ! Single and double alpha exitations
+ ! ===================================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ ! Initial determinant is at k_b in beta-major representation
+ ! ----------------------------------------------------------------------
+
+ k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+ ASSERT (k_b <= N_det)
+
+ spindet(1:$N_int) = tmp_det(1:$N_int,1)
+
+ ! Loop inside the beta column to gather all the connected alphas
+ lcol = psi_bilinear_matrix_columns(k_a)
+ l_a = psi_bilinear_matrix_columns_loc(lcol)
+ do i=1,N_det_alpha_unique
+ if (l_a > N_det) exit
+ lcol = psi_bilinear_matrix_columns(l_a)
+ if (lcol /= kcol) exit
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow)
+ idx(i) = l_a
+ l_a = l_a+1
+ enddo
+ i = i-1
+
+ call get_all_spin_singles_and_doubles_$N_int( &
+ buffer, idx, spindet, i, &
+ singles_a, doubles, n_singles_a, n_doubles )
+
+ ! Compute Hij for all alpha singles
+ ! ----------------------------------
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+ do i=1,n_singles_a
+ l_a = singles_a(i)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta.or.spin_trace.or.alpha_alpha)then
+ ! increment the alpha/beta part for single excitations
+ if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ ! increment the alpha/alpha part for single excitations
+ if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_aa_trans_rdm_buffer(tmp_det,tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ endif
+
+ enddo
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ ! Compute Hij for all alpha doubles
+ ! ----------------------------------
+
+ if(alpha_alpha.or.spin_trace)then
+ do i=1,n_doubles
+ l_a = doubles(i)
+ ASSERT (l_a <= N_det)
+
+ lrow = psi_bilinear_matrix_rows(l_a)
+ ASSERT (lrow <= N_det_alpha_unique)
+
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if (nkeys+4 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_double_to_all_states_aa_trans_rdm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ enddo
+ endif
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+
+ ! Single and double beta excitations
+ ! ==================================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ kcol = psi_bilinear_matrix_columns(k_a)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ spindet(1:$N_int) = tmp_det(1:$N_int,2)
+
+ ! Initial determinant is at k_b in beta-major representation
+ ! -----------------------------------------------------------------------
+
+ k_b = psi_bilinear_matrix_order_transp_reverse(k_a)
+ ASSERT (k_b <= N_det)
+
+ ! Loop inside the alpha row to gather all the connected betas
+ lrow = psi_bilinear_matrix_transp_rows(k_b)
+ l_b = psi_bilinear_matrix_transp_rows_loc(lrow)
+ do i=1,N_det_beta_unique
+ if (l_b > N_det) exit
+ lrow = psi_bilinear_matrix_transp_rows(l_b)
+ if (lrow /= krow) exit
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol)
+ idx(i) = l_b
+ l_b = l_b+1
+ enddo
+ i = i-1
+
+ call get_all_spin_singles_and_doubles_$N_int( &
+ buffer, idx, spindet, i, &
+ singles_b, doubles, n_singles_b, n_doubles )
+
+ ! Compute Hij for all beta singles
+ ! ----------------------------------
+
+ tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ do i=1,n_singles_b
+ l_b = singles_b(i)
+ ASSERT (l_b <= N_det)
+
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol)
+ l_a = psi_bilinear_matrix_transp_order(l_b)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if(alpha_beta.or.spin_trace.or.beta_beta)then
+ ! increment the alpha/beta part for single excitations
+ if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ ! increment the beta /beta part for single excitations
+ if (nkeys+4 * elec_alpha_num .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_single_to_all_states_bb_trans_rdm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ endif
+ enddo
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ ! Compute Hij for all beta doubles
+ ! ----------------------------------
+
+ if(beta_beta.or.spin_trace)then
+ do i=1,n_doubles
+ l_b = doubles(i)
+ ASSERT (l_b <= N_det)
+
+ lcol = psi_bilinear_matrix_transp_columns(l_b)
+ ASSERT (lcol <= N_det_beta_unique)
+
+ l_a = psi_bilinear_matrix_transp_order(l_b)
+ do ll= 1, N_states
+ do l= 1, N_states
+ c_1(l,ll) = u_t(ll,l_a) * u_t(l,k_a)
+ enddo
+ enddo
+ if (nkeys+4 .ge. sze_buff) then
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ endif
+ call orb_range_off_diag_double_to_all_states_trans_rdm_bb_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+! print*,'to do orb_range_off_diag_double_to_2_trans_rdm_bb_dm_buffer'
+ ASSERT (l_a <= N_det)
+
+ enddo
+ endif
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+
+ ! Diagonal contribution
+ ! =====================
+
+
+ ! Initial determinant is at k_a in alpha-major representation
+ ! -----------------------------------------------------------------------
+
+ krow = psi_bilinear_matrix_rows(k_a)
+ ASSERT (krow <= N_det_alpha_unique)
+
+ kcol = psi_bilinear_matrix_columns(k_a)
+ ASSERT (kcol <= N_det_beta_unique)
+
+ tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow)
+ tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+
+ double precision, external :: diag_wee_mat_elem, diag_S_mat_elem
+
+ double precision :: c_1(N_states,N_states)
+ do ll = 1, N_states
+ do l = 1, N_states
+ c_1(l,ll) = u_t(ll,k_a) * u_t(l,k_a)
+ enddo
+ enddo
+
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+ call orb_range_diag_to_all_states_2_rdm_trans_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ call update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2trans_rdm)
+ nkeys = 0
+
+ end do
+ !$OMP END DO
+ deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values)
+ !$OMP END PARALLEL
+
+end
+
+ SUBST [ N_int ]
+
+ 1;;
+ 2;;
+ 3;;
+ 4;;
+ N_int;;
+
+ END_TEMPLATE
+
+subroutine update_keys_values_n_states_trans(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm)
+ use omp_lib
+ implicit none
+ integer, intent(in) :: n_st,nkeys,dim1
+ integer, intent(in) :: keys(4,nkeys)
+ double precision, intent(in) :: values(n_st,n_st,nkeys)
+ double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,n_st,n_st)
+
+ integer(omp_lock_kind),intent(inout):: lock_2rdm
+
+ integer :: i,h1,h2,p1,p2,istate,jstate
+ call omp_set_lock(lock_2rdm)
+
+! print*,'*************'
+! print*,'updating'
+! print*,'nkeys',nkeys
+ do i = 1, nkeys
+ h1 = keys(1,i)
+ h2 = keys(2,i)
+ p1 = keys(3,i)
+ p2 = keys(4,i)
+ do jstate = 1, N_st
+ do istate = 1, N_st
+!! print*,h1,h2,p1,p2,values(istate,i)
+ big_array(h1,h2,p1,p2,istate,jstate) += values(istate,jstate,i)
+ enddo
+ enddo
+ enddo
+ call omp_unset_lock(lock_2rdm)
+
+end
+
diff --git a/src/two_rdm_routines/update_trans_rdm.irp.f b/src/two_rdm_routines/update_trans_rdm.irp.f
new file mode 100644
index 00000000..9f7077a2
--- /dev/null
+++ b/src/two_rdm_routines/update_trans_rdm.irp.f
@@ -0,0 +1,1002 @@
+ subroutine orb_range_diag_to_all_states_2_rdm_trans_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for a given determinant det_1
+ !
+ ! c_1 is the array of the contributions to the trans_rdm for all states
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: det_1(N_int,2)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2
+ integer(bit_kind) :: det_1_act(N_int,2)
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ do i = 1, N_int
+ det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i))
+ det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i))
+ enddo
+
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int)
+ logical :: is_integer_in_string
+ integer :: i1,i2,istate
+ integer :: jstate
+ if(alpha_beta)then
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ ! If alpha/beta, electron 1 is alpha, electron 2 is beta
+ ! Therefore you don't necessayr have symmetry between electron 1 and 2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+
+ else if (alpha_alpha)then
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(1)
+ i2 = occ(j,1)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ else if (beta_beta)then
+ do i = 1, n_occ_ab(2)
+ i1 = occ(i,2)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ else if(spin_trace)then
+ ! 0.5 * (alpha beta + beta alpha)
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ do i = 1, n_occ_ab(1)
+ i1 = occ(i,1)
+ do j = 1, n_occ_ab(1)
+ i2 = occ(j,1)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ do i = 1, n_occ_ab(2)
+ i1 = occ(i,2)
+ do j = 1, n_occ_ab(2)
+ i2 = occ(j,2)
+ h1 = list_orb_reverse(i1)
+ h2 = list_orb_reverse(i2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = -0.5d0 * c_1(istate,jstate)
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = h1
+ enddo
+ enddo
+ endif
+ end
+
+
+ subroutine orb_range_off_diag_double_to_all_states_ab_trans_rdm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+!
+! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another
+!
+! c_1 is the array of the contributions to the trans_rdm for all states
+!
+! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+!
+! ispin determines which spin-spin component of the two-trans_rdm you will update
+!
+! ispin == 1 :: alpha/ alpha
+! ispin == 2 :: beta / beta
+! ispin == 3 :: alpha/ beta
+! ispin == 4 :: spin traced <=> total two-trans_rdm
+!
+! here, only ispin == 3 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ integer :: jstate
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call get_double_excitation(det_1,det_2,exc,phase,N_int)
+ h1 = exc(1,1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 = exc(1,1,2)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 = exc(1,2,1)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 = exc(1,2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(alpha_beta)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+ else if(spin_trace)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_ab_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 3 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(alpha_beta)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ endif
+ else if(spin_trace)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+ enddo
+ endif
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_aa_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 1 or 4 will do something
+ END_DOC
+ use bitmasks
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(alpha_alpha.or.spin_trace)then
+ if (exc(0,1,1) == 1) then
+ ! Mono alpha
+ h1 = exc(1,1,1)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,1)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(1)
+ h2 = occ(i,1)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ enddo
+ else
+ return
+ endif
+ endif
+ end
+
+ subroutine orb_range_off_diag_single_to_all_states_bb_trans_rdm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 2 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ integer(bit_kind), intent(in) :: orb_bitmask(N_int)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab(2)
+ integer :: i,j,h1,h2,p1,istate
+ integer :: exc(0:2,2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+
+ call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int)
+ call get_single_excitation(det_1,det_2,exc,phase,N_int)
+ if(beta_beta.or.spin_trace)then
+ if (exc(0,1,1) == 1) then
+ return
+ else
+ ! Mono beta
+ h1 = exc(1,1,2)
+ if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return
+ h1 = list_orb_reverse(h1)
+ p1 = exc(1,2,2)
+ if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return
+ p1 = list_orb_reverse(p1)
+ do i = 1, n_occ_ab(2)
+ h2 = occ(i,2)
+ if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle
+ h2 = list_orb_reverse(h2)
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = h2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = h2
+ enddo
+ endif
+ endif
+ end
+
+
+ subroutine orb_range_off_diag_double_to_all_states_aa_trans_rdm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 1 or 4 will do something
+ END_DOC
+ implicit none
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2)
+ double precision :: phase
+
+ integer :: jstate
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+ call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
+ h1 =exc(1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 =exc(2,1)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 =exc(1,2)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 =exc(2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(alpha_alpha.or.spin_trace)then
+ nkeys += 1
+
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ endif
+ end
+
+ subroutine orb_range_off_diag_double_to_all_states_trans_rdm_bb_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values)
+ use bitmasks
+ BEGIN_DOC
+ ! routine that update the OFF DIAGONAL PART of the two body trans_rdms in a specific range of orbitals for
+ !
+ ! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another
+ !
+ ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1
+ !
+ ! big_array(dim1,dim1,dim1,dim1) is the two-body trans_rdm to be updated in physicist notation
+ !
+ ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals
+ !
+ ! ispin determines which spin-spin component of the two-trans_rdm you will update
+ !
+ ! ispin == 1 :: alpha/ alpha
+ ! ispin == 2 :: beta / beta
+ ! ispin == 3 :: alpha/ beta
+ ! ispin == 4 :: spin traced <=> total two-trans_rdm
+ !
+ ! here, only ispin == 2 or 4 will do something
+ END_DOC
+ implicit none
+
+ integer, intent(in) :: ispin,sze_buff,N_st
+ integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int)
+ integer, intent(in) :: list_orb_reverse(mo_num)
+ double precision, intent(in) :: c_1(N_st,N_st)
+ double precision, intent(out) :: values(N_st,N_st,sze_buff)
+ integer , intent(out) :: keys(4,sze_buff)
+ integer , intent(inout):: nkeys
+
+ integer :: jstate
+ integer :: i,j,h1,h2,p1,p2,istate
+ integer :: exc(0:2,2)
+ double precision :: phase
+ logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace
+ logical :: is_integer_in_string
+ alpha_alpha = .False.
+ beta_beta = .False.
+ alpha_beta = .False.
+ spin_trace = .False.
+ if( ispin == 1)then
+ alpha_alpha = .True.
+ else if(ispin == 2)then
+ beta_beta = .True.
+ else if(ispin == 3)then
+ alpha_beta = .True.
+ else if(ispin == 4)then
+ spin_trace = .True.
+ endif
+
+ call get_double_excitation_spin(det_1,det_2,exc,phase,N_int)
+ h1 =exc(1,1)
+ if(list_orb_reverse(h1).lt.0)return
+ h1 = list_orb_reverse(h1)
+ h2 =exc(2,1)
+ if(list_orb_reverse(h2).lt.0)return
+ h2 = list_orb_reverse(h2)
+ p1 =exc(1,2)
+ if(list_orb_reverse(p1).lt.0)return
+ p1 = list_orb_reverse(p1)
+ p2 =exc(2,2)
+ if(list_orb_reverse(p2).lt.0)return
+ p2 = list_orb_reverse(p2)
+ if(beta_beta.or.spin_trace)then
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h1
+ keys(2,nkeys) = h2
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p2
+ keys(4,nkeys) = p1
+
+ nkeys += 1
+ do jstate = 1, N_st
+ do istate = 1, N_st
+ values(istate,jstate,nkeys) = - 0.5d0 * c_1(istate,jstate) * phase
+ enddo
+ enddo
+ keys(1,nkeys) = h2
+ keys(2,nkeys) = h1
+ keys(3,nkeys) = p1
+ keys(4,nkeys) = p2
+ endif
+ end
+
From 1b9a75f4886a4112920da3c4f611e19bf35cae12 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 12 Feb 2024 18:18:53 +0100
Subject: [PATCH 019/140] Fixed pseudo-inverse (extrapolations)
---
src/mol_properties/EZFIO.cfg | 7 +++
.../print_e_components.irp.f | 0
src/mol_properties/print_mol_properties.irp.f | 7 ++-
src/utils/linear_algebra.irp.f | 44 +++++++++----------
4 files changed, 34 insertions(+), 24 deletions(-)
rename src/{two_body_rdm => mol_properties}/print_e_components.irp.f (100%)
diff --git a/src/mol_properties/EZFIO.cfg b/src/mol_properties/EZFIO.cfg
index 35a095fb..3ddba227 100644
--- a/src/mol_properties/EZFIO.cfg
+++ b/src/mol_properties/EZFIO.cfg
@@ -21,3 +21,10 @@ type: logical
doc: If true and N_states > 1, the oscillator strength will be computed
interface: ezfio,provider,ocaml
default: false
+
+[calc_energy_components]
+type: logical
+doc: If true, the components of the energy (1e, 2e, kinetic) will be computed
+interface: ezfio,provider,ocaml
+default: false
+
diff --git a/src/two_body_rdm/print_e_components.irp.f b/src/mol_properties/print_e_components.irp.f
similarity index 100%
rename from src/two_body_rdm/print_e_components.irp.f
rename to src/mol_properties/print_e_components.irp.f
diff --git a/src/mol_properties/print_mol_properties.irp.f b/src/mol_properties/print_mol_properties.irp.f
index 3753a3dd..00ccb826 100644
--- a/src/mol_properties/print_mol_properties.irp.f
+++ b/src/mol_properties/print_mol_properties.irp.f
@@ -6,6 +6,11 @@ subroutine print_mol_properties()
! Run the propertie calculations
END_DOC
+ ! Energy components
+ if (calc_energy_components) then
+ call print_energy_components
+ endif
+
! Electric dipole moment
if (calc_dipole_moment) then
call print_dipole_moment
@@ -18,7 +23,7 @@ subroutine print_mol_properties()
! Oscillator strength
if (calc_osc_str .and. N_states > 1) then
- call print_oscillator_strength
+ call print_oscillator_strength
endif
end
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index c9d0be72..76b280b7 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1377,31 +1377,29 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
enddo
endif
- print*, ' n_svd = ', n_svd
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, j) &
- !$OMP SHARED (n, n_svd, D, Vt)
- !$OMP DO
- do j = 1, n
- do i = 1, n_svd
- Vt(i,j) = D(i) * Vt(i,j)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call dgemm("N", "N", m, n, n_svd, 1.d0, U, m, Vt, n, 0.d0, C, LDC)
-
-! C = 0.d0
-! do i=1,m
-! do j=1,n
-! do k=1,n
-! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
-! enddo
+! !$OMP PARALLEL &
+! !$OMP DEFAULT (NONE) &
+! !$OMP PRIVATE (i, j) &
+! !$OMP SHARED (n, n_svd, D, Vt)
+! !$OMP DO
+! do j = 1, n
+! do i = 1, n_svd
+! Vt(i,j) = D(i) * Vt(i,j)
! enddo
! enddo
+! !$OMP END DO
+! !$OMP END PARALLEL
+
+! call dgemm('N', 'N', n, m, n_svd, 1.d0, Vt, size(Vt,1), U, size(U,1), 0.d0, C, size(C,1))
+
+ C = 0.d0
+ do i=1,m
+ do j=1,n
+ do k=1,n_svd
+ C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
+ enddo
+ enddo
+ enddo
deallocate(U,D,Vt,work,A_tmp)
From d619c621fcd00e35d8bb8c2f956486044366a6d0 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 12 Feb 2024 18:21:59 +0100
Subject: [PATCH 020/140] DGEMM in pseudo-inverse
---
src/utils/linear_algebra.irp.f | 42 +++++++++++++++++-----------------
1 file changed, 21 insertions(+), 21 deletions(-)
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 76b280b7..2db47092 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1377,29 +1377,29 @@ subroutine get_pseudo_inverse(A, LDA, m, n, C, LDC, cutoff)
enddo
endif
-! !$OMP PARALLEL &
-! !$OMP DEFAULT (NONE) &
-! !$OMP PRIVATE (i, j) &
-! !$OMP SHARED (n, n_svd, D, Vt)
-! !$OMP DO
-! do j = 1, n
-! do i = 1, n_svd
-! Vt(i,j) = D(i) * Vt(i,j)
-! enddo
-! enddo
-! !$OMP END DO
-! !$OMP END PARALLEL
-
-! call dgemm('N', 'N', n, m, n_svd, 1.d0, Vt, size(Vt,1), U, size(U,1), 0.d0, C, size(C,1))
-
- C = 0.d0
- do i=1,m
- do j=1,n
- do k=1,n_svd
- C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
- enddo
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j) &
+ !$OMP SHARED (n, n_svd, D, Vt)
+ !$OMP DO
+ do j = 1, n
+ do i = 1, n_svd
+ Vt(i,j) = D(i) * Vt(i,j)
enddo
enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm('T', 'T', n, m, n_svd, 1.d0, Vt, size(Vt,1), U, size(U,1), 0.d0, C, size(C,1))
+
+! C = 0.d0
+! do i=1,m
+! do j=1,n
+! do k=1,n_svd
+! C(j,i) = C(j,i) + U(i,k) * D(k) * Vt(k,j)
+! enddo
+! enddo
+! enddo
deallocate(U,D,Vt,work,A_tmp)
From fbb946d8f44161bb8de5c752060e82980265717b Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 15 Feb 2024 16:46:05 +0100
Subject: [PATCH 021/140] removed the systematic save of MOs in casscf
---
src/casscf_cipsi/casscf.irp.f | 2 +-
src/two_body_rdm/act_2_transition_rdm.irp.f | 4 ++--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/src/casscf_cipsi/casscf.irp.f b/src/casscf_cipsi/casscf.irp.f
index addca236..c0cd361d 100644
--- a/src/casscf_cipsi/casscf.irp.f
+++ b/src/casscf_cipsi/casscf.irp.f
@@ -99,8 +99,8 @@ subroutine run
mo_coef = NewOrbs
mo_occ = occnum
- call save_mos
if(.not.converged)then
+ call save_mos
iteration += 1
if(norm_grad_vec2.gt.0.01d0)then
N_det = N_states
diff --git a/src/two_body_rdm/act_2_transition_rdm.irp.f b/src/two_body_rdm/act_2_transition_rdm.irp.f
index 3d08b084..612213e2 100644
--- a/src/two_body_rdm/act_2_transition_rdm.irp.f
+++ b/src/two_body_rdm/act_2_transition_rdm.irp.f
@@ -1,9 +1,9 @@
BEGIN_PROVIDER [double precision, act_2_rdm_trans_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states,N_states)]
implicit none
BEGIN_DOC
-! act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2rdm_trans
+! act_2_rdm_trans_spin_trace_mo(i,j,k,l,istate,jstate) = STATE SPECIFIC physicist notation for 2rdm_trans
!
-! \sum_{\sigma,\sigma'}
+! \sum_{\sigma,\sigma'}
!
! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act"
!
From 22c99a0484eb75ed85c789fa7e39bc965c7fd591 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 15 Feb 2024 19:32:15 +0100
Subject: [PATCH 022/140] done some cleaning in the casscf and added a detailed
example of Multi state CASSCF
---
src/casscf_cipsi/README.rst | 9 ++-
src/casscf_cipsi/casscf.irp.f | 16 ++++-
src/casscf_cipsi/example_casscf_multistate.sh | 66 +++++++++++++++++++
3 files changed, 85 insertions(+), 6 deletions(-)
create mode 100755 src/casscf_cipsi/example_casscf_multistate.sh
diff --git a/src/casscf_cipsi/README.rst b/src/casscf_cipsi/README.rst
index f84cde75..75c99de2 100644
--- a/src/casscf_cipsi/README.rst
+++ b/src/casscf_cipsi/README.rst
@@ -4,13 +4,15 @@ casscf
|CASSCF| program with the CIPSI algorithm.
-Example of inputs
------------------
+
+Example of inputs for GROUND STATE calculations
+-----------------------------------------------
+NOTICE :: FOR EXCITED STATES CALCULATIONS SEE THE FILE "example_casscf_multistate.sh"
a) Small active space : standard CASSCF
---------------------------------------
Let's do O2 (triplet) in aug-cc-pvdz with the following geometry (xyz format, Bohr units)
-3
+2
O 0.0000000000 0.0000000000 -1.1408000000
O 0.0000000000 0.0000000000 1.1408000000
@@ -45,3 +47,4 @@ qp set casscf_cipsi small_active_space False
qp run casscf | tee ${EZFIO_FILE}.casscf_large.out
# you should find around -149.9046
+
diff --git a/src/casscf_cipsi/casscf.irp.f b/src/casscf_cipsi/casscf.irp.f
index c0cd361d..d0a26d36 100644
--- a/src/casscf_cipsi/casscf.irp.f
+++ b/src/casscf_cipsi/casscf.irp.f
@@ -54,14 +54,24 @@ subroutine run
call write_time(6)
call write_int(6,iteration,'CAS-SCF iteration = ')
- call write_double(6,energy,'CAS-SCF energy = ')
+ call write_double(6,energy,'State-average CAS-SCF energy = ')
! if(n_states == 1)then
! call ezfio_get_casscf_cipsi_energy_pt2(E_PT2)
! call ezfio_get_casscf_cipsi_energy(PT2)
+ double precision :: delta_E_istate, e_av
+ e_av = 0.d0
do istate=1,N_states
- call write_double(6,E_PT2(istate),'E + PT2 energy = ')
- call write_double(6,PT2(istate),' PT2 = ')
+ e_av += state_average_weight(istate) * Ev(istate)
+ if(istate.gt.1)then
+ delta_E_istate = E_PT2(istate) - E_PT2(1)
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' Delta E+PT2 = ',delta_E_istate
+ endif
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' E + PT2 energy = ',E_PT2(istate)
+ write(*,'(A6,I2,A18,F16.10)')'state ',istate,' PT2 energy = ',PT2(istate)
+! call write_double(6,E_PT2(istate),'E + PT2 energy = ')
+! call write_double(6,PT2(istate),' PT2 = ')
enddo
+ call write_double(6,e_av,'State-average CAS-SCF energy bis = ')
call write_double(6,pt2_max,' PT2_MAX = ')
! endif
diff --git a/src/casscf_cipsi/example_casscf_multistate.sh b/src/casscf_cipsi/example_casscf_multistate.sh
new file mode 100755
index 00000000..368c0440
--- /dev/null
+++ b/src/casscf_cipsi/example_casscf_multistate.sh
@@ -0,0 +1,66 @@
+# This is an example for MULTI STATE CALCULATION STATE AVERAGE CASSCF
+# We will compute 3 states on the O2 molecule
+# The Ground state and 2 degenerate excited states
+# Please follow carefully the tuto :)
+
+##### PREPARING THE EZFIO
+# Set the path to your QP2 directory
+QP_ROOT=my_fancy_path
+source ${QP_ROOT}/quantum_package.rc
+# Create the EZFIO folder
+qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz_multi_state
+# Start with ROHF orbitals
+qp run scf
+# Freeze the 1s orbitals of the two oxygen
+qp set_frozen_core
+
+##### PREPARING THE ORBITALS WITH NATURAL ORBITALS OF A CIS
+# Tell that you want 3 states in your WF
+qp set determinants n_states 3
+# Run a CIS wave function to start your calculation
+qp run cis | tee ${EZFIO_FILE}.cis_3_states.out
+# Save the STATE AVERAGE natural orbitals for having a balanced description
+# This will also order the orbitals according to their occupation number
+# Which makes the active space selection easyer !
+qp run save_natorb | tee ${EZFIO_FILE}.natorb_3states.out
+
+##### PREPARING A CIS GUESS WITHIN THE ACTIVE SPACE
+# Set an active space which has the most of important excitations
+# and that maintains symmetry : the ACTIVE ORBITALS are from """6 to 13"""
+
+# YOU FIRST FREEZE THE VIRTUALS THAT ARE NOT IN THE ACTIVE SPACE
+# !!!!! WE SET TO "-D" for DELETED !!!!
+qp set_mo_class -c "[1-5]" -a "[6-13]" -d "[14-46]"
+# You create a guess of CIS type WITHIN THE ACTIVE SPACE
+qp run cis | tee ${EZFIO_FILE}.cis_3_states_active_space.out
+# You tell to read the WFT stored (i.e. the guess we just created)
+qp set determinants read_wf True
+
+##### DOING THE CASSCF
+### SETTING PROPERLY THE ACTIVE SPACE FOR CASSCF
+# You set the active space WITH THE VIRTUAL ORBITALS !!!
+# !!!!! NOW WE SET TO "-v" for VIRTUALS !!!!!
+qp set_mo_class -c "[1-5]" -a "[6-13]" -v "[14-46]"
+
+# You tell that it is a small actice space so the CIPSI can take all Slater determinants
+qp set casscf_cipsi small_active_space True
+# You specify the output file
+output=${EZFIO_FILE}.casscf_3states.out
+# You run the CASSCF calculation
+qp run casscf | tee ${output}
+
+# Some grep in order to get some numbers useful to check convergence
+# State average energy
+grep "State-average CAS-SCF energy =" $output | cut -d "=" -f 2 > data_e_average
+# Delta E anticipated for State-average energy, only usefull to check convergence
+grep "Predicted energy improvement =" $output | cut -d "=" -f 2 > data_improve
+# Ground state energy
+grep "state 1 E + PT2 energy" $output | cut -d "=" -f 2 > data_1
+# First excited state energy
+grep "state 2 E + PT2 energy" $output | cut -d "=" -f 2 > data_2
+# First excitation energy
+grep "state 2 Delta E+PT2" $output | cut -d "=" -f 2 > data_delta_E2
+# Second excited state energy
+grep "state 3 E + PT2 energy" $output | cut -d "=" -f 2 > data_3
+# Second excitation energy
+grep "state 3 Delta E+PT2" $output | cut -d "=" -f 2 > data_delta_E3
From 9dc8c0653d4f74aa3165884d4996111c93519bbb Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Thu, 15 Feb 2024 20:37:56 +0100
Subject: [PATCH 023/140] added Boys & Handy's Jastrow
---
plugins/local/jastrow/EZFIO.cfg | 46 +++-
plugins/local/jastrow/bh_param.irp.f | 252 ++++++++++++++++++
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 96 +++++++
3 files changed, 392 insertions(+), 2 deletions(-)
create mode 100644 plugins/local/jastrow/bh_param.irp.f
diff --git a/plugins/local/jastrow/EZFIO.cfg b/plugins/local/jastrow/EZFIO.cfg
index 23dde8ea..8fd2d05a 100644
--- a/plugins/local/jastrow/EZFIO.cfg
+++ b/plugins/local/jastrow/EZFIO.cfg
@@ -1,13 +1,13 @@
[j2e_type]
type: character*(32)
-doc: type of the 2e-Jastrow: [ None | Mu | Mur | Qmckl ]
+doc: type of the 2e-Jastrow: [ None | Mu | Mu_Nu | Mur | Boys | Boys_Handy | Qmckl ]
interface: ezfio,provider,ocaml
default: Mu
[j1e_type]
type: character*(32)
-doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer ]
+doc: type of the 1e-Jastrow: [ None | Gauss | Charge_Harmonizer | Charge_Harmonizer_AO ]
interface: ezfio,provider,ocaml
default: None
@@ -151,3 +151,45 @@ interface: ezfio,provider,ocaml
default: 1.0
ezfio_name: nu_erf
+[jBH_size]
+type: integer
+doc: number of terms per atom in Boys-Handy-Jastrow
+interface: ezfio,provider,ocaml
+default: 1
+
+[jBH_c]
+type: double precision
+doc: coefficients of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_m]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_n]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_o]
+type: integer
+doc: powers of terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (jastrow.jBH_size,nuclei.nucl_num)
+
+[jBH_ee]
+type: double precision
+doc: parameters of e-e terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (nuclei.nucl_num)
+
+[jBH_en]
+type: double precision
+doc: parameters of e-n terms in Boys-Handy-Jastrow
+interface: ezfio
+size: (nuclei.nucl_num)
+
diff --git a/plugins/local/jastrow/bh_param.irp.f b/plugins/local/jastrow/bh_param.irp.f
new file mode 100644
index 00000000..790cf97c
--- /dev/null
+++ b/plugins/local/jastrow/bh_param.irp.f
@@ -0,0 +1,252 @@
+
+ BEGIN_PROVIDER [double precision, jBH_ee, (nucl_num)]
+&BEGIN_PROVIDER [double precision, jBH_en, (nucl_num)]
+&BEGIN_PROVIDER [double precision, jBH_c , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_m , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_n , (jBH_size, nucl_num)]
+&BEGIN_PROVIDER [integer , jBH_o , (jBH_size, nucl_num)]
+
+ BEGIN_DOC
+ !
+ ! parameters of Boys-Handy-Jastrow
+ !
+ END_DOC
+
+ implicit none
+ logical :: exists
+ integer :: i_nucl, p
+ integer :: ierr
+
+ PROVIDE ezfio_filename
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_ee(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'
+ call MPI_BCAST(jBH_ee, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy e-e param with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_ee ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_ee(jBH_ee)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_ee, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_ee with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_ee = 1.d0
+ call ezfio_set_jastrow_jBH_ee(jBH_ee)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_en(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_en, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy e-n param with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_en ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_en(jBH_en)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_en, (nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if (ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_en with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_en = 1.d0
+ call ezfio_set_jastrow_jBH_en(jBH_en)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_c(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_c, (jBH_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy coeff with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_c ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_c(jBH_c)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_c, (jBH_size*nucl_num), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_c with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_c = 0.d0
+ call ezfio_set_jastrow_jBH_c(jBH_c)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_m(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_m, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy m powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_m ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_m(jBH_m)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_m, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_m with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_m = 0
+ call ezfio_set_jastrow_jBH_m(jBH_m)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_n(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_n, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy n powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_n ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_n(jBH_n)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_n, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_n with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_n = 0
+ call ezfio_set_jastrow_jBH_n(jBH_n)
+ endif
+
+ ! ---
+
+ if(mpi_master) then
+ call ezfio_has_jastrow_jBH_o(exists)
+ endif
+
+ IRP_IF MPI_DEBUG
+ print *, irp_here, mpi_rank
+ call MPI_BARRIER(MPI_COMM_WORLD, ierr)
+ IRP_ENDIF
+
+ IRP_IF MPI
+ call MPI_BCAST(jBH_o, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read Boys-Handy o powers with MPI'
+ endif
+ IRP_ENDIF
+
+ if(exists) then
+ if(mpi_master) then
+ write(6,'(A)') '.. >>>>> [ IO READ: jBH_o ] <<<<< ..'
+ call ezfio_get_jastrow_jBH_o(jBH_o)
+ IRP_IF MPI
+ call MPI_BCAST(jBH_o, (jBH_size*nucl_num), MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
+ if(ierr /= MPI_SUCCESS) then
+ stop 'Unable to read jBH_o with MPI'
+ endif
+ IRP_ENDIF
+ endif
+ else
+
+ jBH_o = 0
+ call ezfio_set_jastrow_jBH_o(jBH_o)
+ endif
+
+ ! ---
+
+ print *, ' parameters for Boys-Handy Jastrow'
+ print *, ' nb of terms per nucleus = ', jBH_size
+
+ do i_nucl = 1, nucl_num
+ print *, ' i_nucl = ', i_nucl
+ print *, ' ee-term = ', jBH_ee(i_nucl)
+ print *, ' en-term = ', jBH_en(i_nucl)
+ print *, 'm n o c'
+ do p = 1, jBH_size
+ write(*,'(3(I4,2x), E15.7)') jBH_m(p,i_nucl), jBH_n(p,i_nucl), jBH_o(p,i_nucl), jBH_c(p,i_nucl)
+ enddo
+ enddo
+
+
+END_PROVIDER
+
+! ---
+
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 5777a44a..88778ee0 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -109,6 +109,16 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
endif ! env_type
+ elseif(j2e_type .eq. "Boys_Handy") then
+
+ PROVIDE jBH_size jBH_en jBH_ee jBH_m jBH_n jBH_o jBH_c
+
+ if(env_type .ne. "None") then
+
+ call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
+
+ endif ! env_type
+
else
print *, ' Error in get_grad1_u12_withsq_r1_seq: Unknown Jastrow'
@@ -157,9 +167,13 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
double precision, intent(out) :: gradz(n_grid2)
integer :: jpoint
+ integer :: i_nucl, p, mpA, npA, opA
double precision :: r2(3)
double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
+ double precision :: rn(3), f1A, gard1_f1A(3), f2A, gard2_f2A(3), g12, gard1_g12(3)
+ double precision :: tmp1, tmp2
+
PROVIDE j2e_type
@@ -267,6 +281,57 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
gradz(jpoint) = tmp * dz
enddo
+ elseif(j2e_type .eq. "Boys_Handy") then
+
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
+ r2(1) = final_grid_points_extra(1,jpoint)
+ r2(2) = final_grid_points_extra(2,jpoint)
+ r2(3) = final_grid_points_extra(3,jpoint)
+
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+ do i_nucl = 1, nucl_num
+
+ rn(1) = nucl_coord(i_nucl,1)
+ rn(2) = nucl_coord(i_nucl,2)
+ rn(3) = nucl_coord(i_nucl,3)
+
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r1, rn, f1A, gard1_f1A)
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, gard2_f2A)
+ call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, gard1_g12)
+
+ do p = 1, jBH_size
+ mpA = jBH_m(p,i_nucl)
+ npA = jBH_n(p,i_nucl)
+ opA = jBH_o(p,i_nucl)
+ tmp = jBH_c(p,i_nucl)
+ if(mpA .eq. npA) then
+ tmp = tmp * 0.5d0
+ endif
+
+ tmp1 = 0.d0
+ if(mpA .gt. 0) then
+ tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
+ endif
+ if(npA .gt. 0) then
+ tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
+ endif
+ tmp1 = tmp1 * g12**dble(opA)
+
+ tmp2 = 0.d0
+ if(opA .gt. 0) then
+ tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
+ endif
+
+ gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * gard1_f1A(1) + tmp2 * gard1_g12(1))
+ grady(jpoint) = grady(jpoint) + tmp * (tmp1 * gard1_f1A(2) + tmp2 * gard1_g12(2))
+ gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * gard1_f1A(3) + tmp2 * gard1_g12(3))
+ enddo ! p
+ enddo ! i_nucl
+ enddo ! jpoint
+
else
print *, ' Error in grad1_j12_r1_seq: Unknown j2e_type = ', j2e_type
@@ -757,3 +822,34 @@ end
! ---
+subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, gard1_fct)
+
+ implicit none
+ double precision, intent(in) :: alpha, r1(3), r2(3)
+ double precision, intent(out) :: fct, gard1_fct(3)
+ double precision :: dist, tmp1, tmp2
+
+ dist = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
+ + (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ + (r1(3) - r2(3)) * (r1(3) - r2(3)) )
+
+ tmp1 = 1.d0 / (1.d0 + alpha * dist)
+
+ fct = alpha * dist * tmp1
+
+ if(dist .lt. 1d-10) then
+ gard1_fct(1) = 0.d0
+ gard1_fct(2) = 0.d0
+ gard1_fct(3) = 0.d0
+ else
+ tmp2 = alpha * tmp1 * tmp1 / dist
+ gard1_fct(1) = tmp2 * (r1(1) - r2(1))
+ gard1_fct(2) = tmp2 * (r1(2) - r2(2))
+ gard1_fct(3) = tmp2 * (r1(3) - r2(3))
+ endif
+
+ return
+end
+
+! ---
+
From 6fa207a9fbebf79d3f0e36f2196bc3260878d45d Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Fri, 16 Feb 2024 16:45:54 +0100
Subject: [PATCH 024/140] Boys & Handy Jastrow: OK
---
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 4 +---
plugins/local/tc_scf/rh_tcscf_diis.irp.f | 23 ++++++-------------
2 files changed, 8 insertions(+), 19 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 88778ee0..31ad5756 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -113,10 +113,8 @@ subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
PROVIDE jBH_size jBH_en jBH_ee jBH_m jBH_n jBH_o jBH_c
- if(env_type .ne. "None") then
-
+ if(env_type .eq. "None") then
call grad1_j12_r1_seq(r1, n_grid2, resx, resy, resz)
-
endif ! env_type
else
diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
index 12678500..431b6e08 100644
--- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
@@ -22,6 +22,9 @@ subroutine rh_tcscf_diis()
logical, external :: qp_stop
+ PROVIDE level_shift_TCSCF
+ PROVIDE mo_l_coef mo_r_coef
+
it = 0
e_save = 0.d0
dim_DIIS = 0
@@ -41,19 +44,6 @@ subroutine rh_tcscf_diis()
! ---
- PROVIDE level_shift_TCSCF
- PROVIDE mo_l_coef mo_r_coef
-
- !write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ! '====', '================', '================', '================', '================', '================' &
- ! , '================', '================', '================', '====', '========'
- !write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ! ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- ! , ' gradient ', ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
- !write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ! '====', '================', '================', '================', '================', '================' &
- ! , '================', '================', '================', '====', '========'
-
write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
'====', '================', '================', '================', '================', '================' &
, '================', '================', '====', '========'
@@ -81,8 +71,6 @@ subroutine rh_tcscf_diis()
er_save = er_DIIS
call wall_time(t1)
- !write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- ! it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
@@ -91,6 +79,8 @@ subroutine rh_tcscf_diis()
PROVIDE FQS_SQF_ao Fock_matrix_tc_ao_tot
converged = .false.
+ call ezfio_set_tc_scf_converged_tcscf(converged)
+
!do while((tc_grad .gt. dsqrt(thresh_tcscf)) .and. (er_DIIS .gt. dsqrt(thresh_tcscf)))
do while(.not. converged)
@@ -253,8 +243,9 @@ subroutine rh_tcscf_diis()
endif
call lock_io
- if (converged) then
+ if(converged) then
write(json_unit, json_true_fmtx) 'converged'
+ call ezfio_set_tc_scf_converged_tcscf(converged)
else
write(json_unit, json_false_fmtx) 'converged'
endif
From fa877df399a918750c28a0a262d27823c0cbd3c6 Mon Sep 17 00:00:00 2001
From: eginer
Date: Sun, 18 Feb 2024 15:12:39 +0100
Subject: [PATCH 025/140] added exponential of anti-hermitian matrices using
the Helgaker's book formulation, and of general matrices using the Taylor
expansion. Replaced in casscf_cipsi Umat variable
---
src/casscf_cipsi/neworbs.irp.f | 41 +++++-----
src/utils/linear_algebra.irp.f | 137 +++++++++++++++++++++++++++++++++
2 files changed, 158 insertions(+), 20 deletions(-)
diff --git a/src/casscf_cipsi/neworbs.irp.f b/src/casscf_cipsi/neworbs.irp.f
index a7cebbb2..ca2deebb 100644
--- a/src/casscf_cipsi/neworbs.irp.f
+++ b/src/casscf_cipsi/neworbs.irp.f
@@ -226,27 +226,28 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
end do
! Form the exponential
+ call exp_matrix_taylor(Tmat,mo_num,Umat,converged)
- Tpotmat(:,:)=0.D0
- Umat(:,:) =0.D0
- do i=1,mo_num
- Tpotmat(i,i)=1.D0
- Umat(i,i) =1.d0
- end do
- iter=0
- converged=.false.
- do while (.not.converged)
- iter+=1
- f = 1.d0 / dble(iter)
- Tpotmat2(:,:) = Tpotmat(:,:) * f
- call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
- Tpotmat2, size(Tpotmat2,1), &
- Tmat, size(Tmat,1), 0.d0, &
- Tpotmat, size(Tpotmat,1))
- Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
-
- converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
- end do
+! Tpotmat(:,:)=0.D0
+! Umat(:,:) =0.D0
+! do i=1,mo_num
+! Tpotmat(i,i)=1.D0
+! Umat(i,i) =1.d0
+! end do
+! iter=0
+! converged=.false.
+! do while (.not.converged)
+! iter+=1
+! f = 1.d0 / dble(iter)
+! Tpotmat2(:,:) = Tpotmat(:,:) * f
+! call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
+! Tpotmat2, size(Tpotmat2,1), &
+! Tmat, size(Tmat,1), 0.d0, &
+! Tpotmat, size(Tpotmat,1))
+! Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
+!
+! converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
+! end do
END_PROVIDER
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 2db47092..175beff3 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1897,3 +1897,140 @@ end do
end subroutine pivoted_cholesky
+subroutine exp_matrix(X,n,exp_X)
+ implicit none
+ double precision, intent(in) :: X(n,n)
+ integer, intent(in):: n
+ double precision, intent(out):: exp_X(n,n)
+ BEGIN_DOC
+ ! exponential of the matrix X: X has to be ANTI HERMITIAN !!
+ !
+ ! taken from Hellgaker, jorgensen, Olsen book
+ !
+ ! section evaluation of matrix exponential (Eqs. 3.1.29 to 3.1.31)
+ END_DOC
+ integer :: i
+ double precision, allocatable :: r2_mat(:,:),eigvalues(:),eigvectors(:,:)
+ double precision, allocatable :: matrix_tmp1(:,:),eigvalues_mat(:,:),matrix_tmp2(:,:)
+ include 'constants.include.F'
+ allocate(r2_mat(n,n),eigvalues(n),eigvectors(n,n))
+ allocate(eigvalues_mat(n,n),matrix_tmp1(n,n),matrix_tmp2(n,n))
+
+ ! r2_mat = X^2 in the 3.1.30
+ call get_A_squared(X,n,r2_mat)
+ call lapack_diagd(eigvalues,eigvectors,r2_mat,n,n)
+ eigvalues=-eigvalues
+
+ if(.False.)then
+ !!! For debugging and following the book intermediate
+ ! rebuilding the matrix : X^2 = -W t^2 W^T as in 3.1.30
+ ! matrix_tmp1 = W t^2
+ print*,'eigvalues = '
+ do i = 1, n
+ print*,i,eigvalues(i)
+ write(*,'(100(F16.10,X))')eigvectors(:,i)
+ enddo
+ eigvalues_mat=0.d0
+ do i = 1,n
+ ! t = dsqrt(t^2) where t^2 are eigenvalues of X^2
+ eigvalues(i) = dsqrt(eigvalues(i))
+ eigvalues_mat(i,i) = eigvalues(i)*eigvalues(i)
+ enddo
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ print*,'r2_mat new = '
+ do i = 1, n
+ write(*,'(100(F16.10,X))')matrix_tmp2(:,i)
+ enddo
+ endif
+
+ ! building the exponential
+ ! exp(X) = W cos(t) W^T + W t^-1 sin(t) W^T X as in Eq. 3.1.31
+ ! matrix_tmp1 = W cos(t)
+ do i = 1,n
+ eigvalues_mat(i,i) = dcos(eigvalues(i))
+ enddo
+ ! matrix_tmp2 = W cos(t)
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ ! matrix_tmp2 = W cos(t) W^T
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ exp_X = matrix_tmp2
+ ! matrix_tmp2 = W t^-1 sin(t) W^T X
+ do i = 1,n
+ if(dabs(eigvalues(i)).gt.1.d-4)then
+ eigvalues_mat(i,i) = dsin(eigvalues(i))/eigvalues(i)
+ else ! Taylor development of sin(x)/x near x=0 = 1 - x^2/6
+ eigvalues_mat(i,i) = 1.d0 - eigvalues(i)*eigvalues(i)*c_1_3*0.5d0
+ endif
+ enddo
+ ! matrix_tmp1 = W t^-1 sin(t)
+ call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
+ eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
+ ! matrix_tmp2 = W t^-1 sin(t) W^T
+ call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
+ eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ ! exp_X += matrix_tmp2 X
+ call dgemm('N','N',n,n,n,1.d0,matrix_tmp2,size(matrix_tmp2,1), &
+ X,size(X,1),1.d0,exp_X,size(exp_X,1))
+
+end
+
+
+subroutine exp_matrix_taylor(X,n,exp_X,converged)
+ implicit none
+ BEGIN_DOC
+ ! exponential of a general real matrix X using the Taylor expansion of exp(X)
+ !
+ ! returns the logical converged which checks the convergence
+ END_DOC
+ double precision, intent(in) :: X(n,n)
+ integer, intent(in):: n
+ double precision, intent(out):: exp_X(n,n)
+ logical :: converged
+ double precision :: f
+ integer :: i,iter
+ double precision, allocatable :: Tpotmat(:,:),Tpotmat2(:,:)
+ allocate(Tpotmat(n,n),Tpotmat2(n,n))
+ BEGIN_DOC
+ ! exponential of X using Taylor expansion
+ END_DOC
+ Tpotmat(:,:)=0.D0
+ exp_X(:,:) =0.D0
+ do i=1,n
+ Tpotmat(i,i)=1.D0
+ exp_X(i,i) =1.d0
+ end do
+ iter=0
+ converged=.false.
+ do while (.not.converged)
+ iter+=1
+ f = 1.d0 / dble(iter)
+ Tpotmat2(:,:) = Tpotmat(:,:) * f
+ call dgemm('N','N', n,n,n,1.d0, &
+ Tpotmat2, size(Tpotmat2,1), &
+ X, size(X,1), 0.d0, &
+ Tpotmat, size(Tpotmat,1))
+ exp_X(:,:) = exp_X(:,:) + Tpotmat(:,:)
+
+ converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
+ end do
+ if(.not.converged)then
+ print*,'Warning !! exp_matrix_taylor did not converge !'
+ endif
+
+end
+
+subroutine get_A_squared(A,n,A2)
+ implicit none
+ BEGIN_DOC
+! A2 = A A where A is n x n matrix. Use the dgemm routine
+ END_DOC
+ double precision, intent(in) :: A(n,n)
+ integer, intent(in) :: n
+ double precision, intent(out):: A2(n,n)
+ call dgemm('N','N',n,n,n,1.d0,A,size(A,1),A,size(A,1),0.d0,A2,size(A2,1))
+end
From ac805f9f016ab5b035557642e19602144d845c6f Mon Sep 17 00:00:00 2001
From: eginer
Date: Sun, 18 Feb 2024 15:25:38 +0100
Subject: [PATCH 026/140] added some reference numbers in the
example_casscf_multistate.sh
---
src/casscf_cipsi/example_casscf_multistate.sh | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/src/casscf_cipsi/example_casscf_multistate.sh b/src/casscf_cipsi/example_casscf_multistate.sh
index 368c0440..716c211a 100755
--- a/src/casscf_cipsi/example_casscf_multistate.sh
+++ b/src/casscf_cipsi/example_casscf_multistate.sh
@@ -10,7 +10,7 @@ source ${QP_ROOT}/quantum_package.rc
# Create the EZFIO folder
qp create_ezfio -b aug-cc-pvdz O2.xyz -m 3 -a -o O2_avdz_multi_state
# Start with ROHF orbitals
-qp run scf
+qp run scf # ROHF energy : -149.619992871398
# Freeze the 1s orbitals of the two oxygen
qp set_frozen_core
@@ -18,7 +18,7 @@ qp set_frozen_core
# Tell that you want 3 states in your WF
qp set determinants n_states 3
# Run a CIS wave function to start your calculation
-qp run cis | tee ${EZFIO_FILE}.cis_3_states.out
+qp run cis | tee ${EZFIO_FILE}.cis_3_states.out # -149.6652601409258 -149.4714726176746 -149.4686165431939
# Save the STATE AVERAGE natural orbitals for having a balanced description
# This will also order the orbitals according to their occupation number
# Which makes the active space selection easyer !
@@ -32,7 +32,7 @@ qp run save_natorb | tee ${EZFIO_FILE}.natorb_3states.out
# !!!!! WE SET TO "-D" for DELETED !!!!
qp set_mo_class -c "[1-5]" -a "[6-13]" -d "[14-46]"
# You create a guess of CIS type WITHIN THE ACTIVE SPACE
-qp run cis | tee ${EZFIO_FILE}.cis_3_states_active_space.out
+qp run cis | tee ${EZFIO_FILE}.cis_3_states_active_space.out # -149.6515472533511 -149.4622878024821 -149.4622878024817
# You tell to read the WFT stored (i.e. the guess we just created)
qp set determinants read_wf True
@@ -47,7 +47,7 @@ qp set casscf_cipsi small_active_space True
# You specify the output file
output=${EZFIO_FILE}.casscf_3states.out
# You run the CASSCF calculation
-qp run casscf | tee ${output}
+qp run casscf | tee ${output} # -149.7175867510 -149.5059010227 -149.5059010226
# Some grep in order to get some numbers useful to check convergence
# State average energy
From fcde51ea002e01e6b2d109c17320b2a877673845 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 22 Feb 2024 08:15:01 +0100
Subject: [PATCH 027/140] small modif
---
plugins/local/jastrow/bh_param.irp.f | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/plugins/local/jastrow/bh_param.irp.f b/plugins/local/jastrow/bh_param.irp.f
index 790cf97c..167d8814 100644
--- a/plugins/local/jastrow/bh_param.irp.f
+++ b/plugins/local/jastrow/bh_param.irp.f
@@ -236,7 +236,7 @@
print *, ' nb of terms per nucleus = ', jBH_size
do i_nucl = 1, nucl_num
- print *, ' i_nucl = ', i_nucl
+ print *, ' nucl = ', nucl_label(i_nucl)
print *, ' ee-term = ', jBH_ee(i_nucl)
print *, ' en-term = ', jBH_en(i_nucl)
print *, 'm n o c'
From ad1fd55fe9b969f1476e43a2010cc59f57ac9a8c Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 23 Feb 2024 13:08:02 +0100
Subject: [PATCH 028/140] Add mo_symmetry
---
src/mo_basis/EZFIO.cfg | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/src/mo_basis/EZFIO.cfg b/src/mo_basis/EZFIO.cfg
index 4c4f1eca..8349c006 100644
--- a/src/mo_basis/EZFIO.cfg
+++ b/src/mo_basis/EZFIO.cfg
@@ -32,6 +32,12 @@ doc: |MO| occupation numbers
interface: ezfio
size: (mo_basis.mo_num)
+[mo_symmetry]
+type: integer
+doc: MOs with the same integer belong to the same irrep.
+interface: ezfio
+size: (mo_basis.mo_num)
+
[mo_class]
type: MO_class
doc: [ Core | Inactive | Active | Virtual | Deleted ], as defined by :ref:`qp_set_mo_class`
From 9c49be2f593a53db6eb9dca3ace347559d307a68 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 23 Feb 2024 13:16:55 +0100
Subject: [PATCH 029/140] Added mo_symmetry in qp_convert
---
bin/qp_convert_output_to_ezfio | 12 +++++++++++-
1 file changed, 11 insertions(+), 1 deletion(-)
diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio
index 0523b6a7..0b8484f6 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -309,10 +309,19 @@ def write_ezfio(res, filename):
MoMatrix = []
sym0 = [i.sym for i in res.mo_sets[MO_type]]
- sym = [i.sym for i in res.mo_sets[MO_type]]
+ sym = [i.sym for i in res.mo_sets[MO_type]]
for i in range(len(sym)):
sym[MOmap[i]] = sym0[i]
+ irrep = {}
+ for i in sym:
+ irrep[i] = 0
+
+ for i, j in enumerate(irrep.keys()):
+ irrep[j] = i+1
+
+ sym = [ irrep[k] for k in sym ]
+
MoMatrix = []
for i in range(len(MOs)):
m = MOs[i]
@@ -329,6 +338,7 @@ def write_ezfio(res, filename):
ezfio.set_mo_basis_mo_num(mo_num)
ezfio.set_mo_basis_mo_coef(MoMatrix)
ezfio.set_mo_basis_mo_occ(OccNum)
+ ezfio.set_mo_basis_mo_symmetry(sym)
print("OK")
From 7fc4c8148552105b08088b2e3c79c59f48c86f50 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Fri, 23 Feb 2024 23:51:03 +0100
Subject: [PATCH 030/140] few modif
---
plugins/local/jastrow/bh_param.irp.f | 2 +-
plugins/local/tc_scf/EZFIO.cfg | 7 +++++++
2 files changed, 8 insertions(+), 1 deletion(-)
diff --git a/plugins/local/jastrow/bh_param.irp.f b/plugins/local/jastrow/bh_param.irp.f
index 167d8814..1ed871bc 100644
--- a/plugins/local/jastrow/bh_param.irp.f
+++ b/plugins/local/jastrow/bh_param.irp.f
@@ -239,7 +239,7 @@
print *, ' nucl = ', nucl_label(i_nucl)
print *, ' ee-term = ', jBH_ee(i_nucl)
print *, ' en-term = ', jBH_en(i_nucl)
- print *, 'm n o c'
+ print *, ' m n o c'
do p = 1, jBH_size
write(*,'(3(I4,2x), E15.7)') jBH_m(p,i_nucl), jBH_n(p,i_nucl), jBH_o(p,i_nucl), jBH_c(p,i_nucl)
enddo
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 313d6f2b..3dfa9a71 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -2,3 +2,10 @@
type: Threshold
doc: Energy bi-tc HF
interface: ezfio
+
+[converged_tcscf]
+type: logical
+doc: If |true|, tc-scf has converged
+interface: ezfio,provider,ocaml
+default: False
+
From b9932c0e77b1b07e242e4d55c4679603b7bb964a Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 26 Feb 2024 15:33:36 +0100
Subject: [PATCH 031/140] added swaping between Left/Right MOs when large
angles
---
plugins/local/tc_scf/routines_rotates.irp.f | 70 +++++++++++++++++++--
src/mo_one_e_ints/spread_dipole_mo.irp.f | 18 ++++++
src/utils/linear_algebra.irp.f | 15 +++--
3 files changed, 94 insertions(+), 9 deletions(-)
diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f
index cc825429..c42e846e 100644
--- a/plugins/local/tc_scf/routines_rotates.irp.f
+++ b/plugins/local/tc_scf/routines_rotates.irp.f
@@ -103,7 +103,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
double precision, allocatable :: stmp(:,:), T(:,:), Snew(:,:), smat2(:,:)
double precision, allocatable :: mo_l_coef_tmp(:,:), mo_r_coef_tmp(:,:), mo_l_coef_new(:,:)
- E_thr = 1d-8
+ E_thr = 1d-04
E_old = TC_HF_energy
allocate(mo_l_coef_old(ao_num,mo_num), mo_r_coef_old(ao_num,mo_num))
mo_r_coef_old = mo_r_coef
@@ -164,10 +164,42 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen))
allocate(T(n_degen,n_degen), Snew(n_degen,n_degen))
- do j = 1, n_degen
- mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
- mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
- enddo
+ print*,'Right orbitals before'
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j))
+ enddo
+ print*,'Left orbitals before'
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))')mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
+ if(angle_left_right(list_degen(i,1)).gt.80.d0.and.n_degen==2)then
+ integer :: i_list, j_list
+ i_list = list_degen(i,1)
+ j_list = list_degen(i,2)
+ print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2))
+ print*,'i_list = ',i_list
+ print*,'i_list = ',j_list
+ print*,'Swapping left/right orbitals'
+ call print_strong_overlap(i_list, j_list)
+ mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list)
+ mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list)
+ mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list)
+ mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list)
+ else
+ do j = 1, n_degen
+ print*,'i_list = ',list_degen(i,j)
+ mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
+ mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
+ endif
+ print*,'Right orbitals '
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))')mo_r_coef_tmp(1:ao_num,j)
+ enddo
+ print*,'Left orbitals '
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))')mo_l_coef_tmp(1:ao_num,j)
+ enddo
! Orthogonalization of right functions
print *, ' Orthogonalization of RIGHT functions'
print *, ' ------------------------------------'
@@ -445,3 +477,31 @@ subroutine sort_by_tc_fock
end
+
+subroutine print_strong_overlap(i_list, j_list)
+ implicit none
+ integer, intent(in) :: i_list,j_list
+ double precision :: o_i, o_j,o_ij
+ double precision :: s_mat_r(2,2),s_mat_l(2,2)
+ o_i = dsqrt(overlap_mo_r(i_list, i_list))
+ o_j = dsqrt(overlap_mo_r(j_list, j_list))
+ o_ij = overlap_mo_r(j_list, i_list)
+ s_mat_r(1,1) = o_i*o_i
+ s_mat_r(2,1) = o_ij/(o_i * o_j)
+ s_mat_r(2,2) = o_j*o_j
+ s_mat_r(1,2) = s_mat_r(2,1)
+ print*,'Right overlap matrix '
+ write(*,'(2(F10.5,X))')s_mat_r(1:2,1)
+ write(*,'(2(F10.5,X))')s_mat_r(1:2,2)
+ o_i = dsqrt(overlap_mo_l(i_list, i_list))
+ o_j = dsqrt(overlap_mo_l(j_list, j_list))
+ o_ij = overlap_mo_l(j_list, i_list)
+ s_mat_l(1,1) = o_i*o_i
+ s_mat_l(2,1) = o_ij/(o_i * o_j)
+ s_mat_l(2,2) = o_j*o_j
+ s_mat_l(1,2) = s_mat_l(2,1)
+ print*,'Left overlap matrix '
+ write(*,'(2(F10.5,X))')s_mat_l(1:2,1)
+ write(*,'(2(F10.5,X))')s_mat_l(1:2,2)
+
+end
diff --git a/src/mo_one_e_ints/spread_dipole_mo.irp.f b/src/mo_one_e_ints/spread_dipole_mo.irp.f
index e4484433..b0a7198b 100644
--- a/src/mo_one_e_ints/spread_dipole_mo.irp.f
+++ b/src/mo_one_e_ints/spread_dipole_mo.irp.f
@@ -58,3 +58,21 @@ END_PROVIDER
)
END_PROVIDER
+ BEGIN_PROVIDER [double precision, mo_spread_centered_x, (mo_num, mo_num) ]
+&BEGIN_PROVIDER [double precision, mo_spread_centered_y, (mo_num, mo_num) ]
+&BEGIN_PROVIDER [double precision, mo_spread_centered_z, (mo_num, mo_num) ]
+ BEGIN_DOC
+ ! array of the integrals of MO_i * (x^2 - ^2) MO_j = MO_i x^2 MO_j - (MO_i x MO_j)^2
+ ! array of the integrals of MO_i * (y^2 - ^2) MO_j = MO_i y^2 MO_j - (MO_i y MO_j)^2
+ ! array of the integrals of MO_i * (z^2 - ^2) MO_j = MO_i z^2 MO_j - (MO_i z MO_j)^2
+ END_DOC
+ implicit none
+ integer :: i,j
+ do i = 1, mo_num
+ do j = 1, mo_num
+ mo_spread_centered_x(j,i) = mo_spread_x(j,i) - mo_dipole_x(j,i)**2
+ mo_spread_centered_y(j,i) = mo_spread_y(j,i) - mo_dipole_y(j,i)**2
+ mo_spread_centered_z(j,i) = mo_spread_z(j,i) - mo_dipole_z(j,i)**2
+ enddo
+ enddo
+END_PROVIDER
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 175beff3..26e390b7 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -1920,8 +1920,12 @@ subroutine exp_matrix(X,n,exp_X)
call get_A_squared(X,n,r2_mat)
call lapack_diagd(eigvalues,eigvectors,r2_mat,n,n)
eigvalues=-eigvalues
+ do i = 1,n
+ ! t = dsqrt(t^2) where t^2 are eigenvalues of X^2
+ eigvalues(i) = dsqrt(eigvalues(i))
+ enddo
- if(.False.)then
+ if(.false.)then
!!! For debugging and following the book intermediate
! rebuilding the matrix : X^2 = -W t^2 W^T as in 3.1.30
! matrix_tmp1 = W t^2
@@ -1932,14 +1936,16 @@ subroutine exp_matrix(X,n,exp_X)
enddo
eigvalues_mat=0.d0
do i = 1,n
- ! t = dsqrt(t^2) where t^2 are eigenvalues of X^2
- eigvalues(i) = dsqrt(eigvalues(i))
eigvalues_mat(i,i) = eigvalues(i)*eigvalues(i)
enddo
call dgemm('N','N',n,n,n,1.d0,eigvectors,size(eigvectors,1), &
eigvalues_mat,size(eigvalues_mat,1),0.d0,matrix_tmp1,size(matrix_tmp1,1))
call dgemm('N','T',n,n,n,-1.d0,matrix_tmp1,size(matrix_tmp1,1), &
eigvectors,size(eigvectors,1),0.d0,matrix_tmp2,size(matrix_tmp2,1))
+ print*,'r2_mat = '
+ do i = 1, n
+ write(*,'(100(F16.10,X))')r2_mat(:,i)
+ enddo
print*,'r2_mat new = '
do i = 1, n
write(*,'(100(F16.10,X))')matrix_tmp2(:,i)
@@ -1964,7 +1970,8 @@ subroutine exp_matrix(X,n,exp_X)
if(dabs(eigvalues(i)).gt.1.d-4)then
eigvalues_mat(i,i) = dsin(eigvalues(i))/eigvalues(i)
else ! Taylor development of sin(x)/x near x=0 = 1 - x^2/6
- eigvalues_mat(i,i) = 1.d0 - eigvalues(i)*eigvalues(i)*c_1_3*0.5d0
+ eigvalues_mat(i,i) = 1.d0 - eigvalues(i)*eigvalues(i)*c_1_3*0.5d0 &
+ + eigvalues(i)*eigvalues(i)*eigvalues(i)*eigvalues(i)*c_1_3*0.025d0
endif
enddo
! matrix_tmp1 = W t^-1 sin(t)
From ce43b16fc0c7f76023b1744bdfd4dcd23a8aee50 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 28 Feb 2024 14:46:23 +0100
Subject: [PATCH 032/140] Fixed bug in PT2 with fast stochastic convergence
---
src/cipsi/run_pt2_slave.irp.f | 8 +++++++-
src/tools/diagonalize_h.irp.f | 1 +
src/tools/print_energy.irp.f | 3 ++-
3 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi/run_pt2_slave.irp.f
index debae596..cb1dd1f5 100644
--- a/src/cipsi/run_pt2_slave.irp.f
+++ b/src/cipsi/run_pt2_slave.irp.f
@@ -186,6 +186,7 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
type(pt2_type) :: pt2_data
integer :: n_tasks, k, N
integer :: i_generator, subset
+ integer :: ifirst
integer :: bsize ! Size of selection buffers
logical :: sending
@@ -202,6 +203,7 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
zmq_socket_push = new_zmq_push_socket(thread)
+ ifirst = 0
b%N = 0
buffer_ready = .False.
n_tasks = 1
@@ -250,7 +252,11 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
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
+ if (ifirst /= 0 ) then
+ b%cur=0
+ else
+ ifirst = 1
+ endif
call omp_unset_lock(global_selection_buffer_lock)
if ( iproc == 1 ) then
call omp_set_lock(global_selection_buffer_lock)
diff --git a/src/tools/diagonalize_h.irp.f b/src/tools/diagonalize_h.irp.f
index c9ae2033..ffc53aa2 100644
--- a/src/tools/diagonalize_h.irp.f
+++ b/src/tools/diagonalize_h.irp.f
@@ -20,4 +20,5 @@ subroutine routine
call diagonalize_CI
print*,'N_det = ',N_det
call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
+ call print_mol_properties
end
diff --git a/src/tools/print_energy.irp.f b/src/tools/print_energy.irp.f
index 4fe1572c..0e67828e 100644
--- a/src/tools/print_energy.irp.f
+++ b/src/tools/print_energy.irp.f
@@ -14,5 +14,6 @@ end
subroutine run
implicit none
- print *, psi_energy + nuclear_repulsion
+ call print_mol_properties
+ print *, psi_energy + nuclear_repulsion
end
From 30096e07ea33720d6104c13f43f9eb5788967ddc Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 28 Feb 2024 15:02:39 +0100
Subject: [PATCH 033/140] Merging TC with cipsi
---
.../cipsi_tc_bi_ortho/run_pt2_slave.irp.f | 45 +++++++++----------
.../run_selection_slave.irp.f | 29 ++++++------
.../cipsi_tc_bi_ortho/zmq_selection.irp.f | 3 +-
src/cipsi/run_selection_slave.irp.f | 2 +-
4 files changed, 39 insertions(+), 40 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
index aa6546e7..d4f45649 100644
--- a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/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 > 100000 ) 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)
@@ -178,15 +179,12 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
type(pt2_type) :: pt2_data
integer :: n_tasks, k, N
integer :: i_generator, subset
+ integer :: ifirst
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()
@@ -198,15 +196,13 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
zmq_socket_push = new_zmq_push_socket(thread)
+ ifirst = 0
b%N = 0
buffer_ready = .False.
n_tasks = 1
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
@@ -233,28 +229,29 @@ 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)
+ if (ifirst /= 0 ) then
+ b%cur=0
+ else
+ ifirst = 1
+ endif
+ 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/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
index d351cc79..39c83c4b 100644
--- a/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
@@ -5,19 +5,22 @@ subroutine run_selection_slave(thread, iproc, energy)
implicit none
- double precision, intent(in) :: energy(N_states)
- integer, intent(in) :: thread, iproc
+ double precision, intent(in) :: energy(N_states)
+ integer, intent(in) :: thread, iproc
+ integer :: rc, i
- integer :: rc, i
- integer :: worker_id, task_id(1), ctask, ltask
- character*(512) :: task
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_socket_push
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR), external :: new_zmq_push_socket
- type(selection_buffer) :: buf, buf2
- type(pt2_type) :: pt2_data
- logical :: done, buffer_ready
+ integer :: worker_id, task_id(1), ctask, ltask
+ 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
+
+ type(selection_buffer) :: buf, buf2
+ logical :: done, buffer_ready
+ type(pt2_type) :: pt2_data
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
@@ -64,7 +67,7 @@ subroutine run_selection_slave(thread, iproc, energy)
stop '-1'
end if
end if
- call select_connected(i_generator, energy, pt2_data, buf,subset, pt2_F(i_generator))
+ call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
endif
integer, external :: task_done_to_taskserver
diff --git a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
index dc3e0f27..22db643f 100644
--- a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
@@ -11,7 +11,7 @@ subroutine ZMQ_selection(N_in, pt2_data)
integer, external :: omp_get_thread_num
type(pt2_type), intent(inout) :: pt2_data
- PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
+! PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
N = max(N_in,1)
N = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
@@ -61,7 +61,6 @@ subroutine ZMQ_selection(N_in, pt2_data)
ipos=1
task = ' '
-
do i= 1, N_det_generators
do j=1,pt2_F(i)
write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f
index 91bd3a38..87ebca40 100644
--- a/src/cipsi/run_selection_slave.irp.f
+++ b/src/cipsi/run_selection_slave.irp.f
@@ -65,7 +65,7 @@ subroutine run_selection_slave(thread,iproc,energy)
stop '-1'
end if
end if
- call select_connected(i_generator,energy,pt2_data,buf,subset,pt2_F(i_generator))
+ call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
endif
integer, external :: task_done_to_taskserver
From 992732813881397b9e854381f803f0056b6616ba Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 28 Feb 2024 18:15:25 +0100
Subject: [PATCH 034/140] Changed dummy into ghost
---
ocaml/Angmom.ml | 3 +--
ocaml/Basis.ml | 2 +-
ocaml/Element.ml | 38 ++++++++++++++++++------------------
ocaml/qp_create_ezfio.ml | 42 ++++++++++++++++++++--------------------
4 files changed, 42 insertions(+), 43 deletions(-)
diff --git a/ocaml/Angmom.ml b/ocaml/Angmom.ml
index ed13e8dc..2da09340 100644
--- a/ocaml/Angmom.ml
+++ b/ocaml/Angmom.ml
@@ -26,8 +26,7 @@ let of_string = function
| "J" | "j" -> J
| "K" | "k" -> K
| "L" | "l" -> L
- | x -> raise (Failure ("Angmom should be S|P|D|F|G|H|I|J|K|L,
-not "^x^"."))
+ | x -> raise (Failure ("Angmom should be S|P|D|F|G|H|I|J|K|L, not "^x^"."))
let of_char = function
| 'S' | 's' -> S
diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml
index 9b0c6a38..f951a5f3 100644
--- a/ocaml/Basis.ml
+++ b/ocaml/Basis.ml
@@ -17,7 +17,7 @@ let read in_channel at_number =
(** Find an element in the basis set file *)
let find in_channel element =
seek_in in_channel 0;
- let element_read = ref Element.X in
+ let element_read = ref Element.Og in
while !element_read <> element
do
let buffer = input_line in_channel in
diff --git a/ocaml/Element.ml b/ocaml/Element.ml
index f0d4455d..a794b2bb 100644
--- a/ocaml/Element.ml
+++ b/ocaml/Element.ml
@@ -4,7 +4,7 @@ open Qptypes
exception ElementError of string
type t = X
-
+
|H |He
|Li|Be |B |C |N |O |F |Ne
|Na|Mg |Al|Si|P |S |Cl|Ar
@@ -20,7 +20,7 @@ type t = X
let of_string x =
match (String.capitalize_ascii (String.lowercase_ascii x)) with
-| "X" | "Dummy" -> X
+| "X" | "Ghost" -> X
| "H" | "Hydrogen" -> H
| "He" | "Helium" -> He
| "Li" | "Lithium" -> Li
@@ -265,7 +265,7 @@ let to_string = function
let to_long_string = function
-| X -> "Dummy"
+| X -> "Ghost"
| H -> "Hydrogen"
| He -> "Helium"
| Li -> "Lithium"
@@ -492,20 +492,20 @@ let to_charge c =
| No -> 102
| Lr -> 103
| Rf -> 104
- | Db -> 105
- | Sg -> 106
- | Bh -> 107
- | Hs -> 108
- | Mt -> 109
- | Ds -> 110
- | Rg -> 111
- | Cn -> 112
- | Nh -> 113
- | Fl -> 114
- | Mc -> 115
- | Lv -> 116
- | Ts -> 117
- | Og -> 118
+ | Db -> 105
+ | Sg -> 106
+ | Bh -> 107
+ | Hs -> 108
+ | Mt -> 109
+ | Ds -> 110
+ | Rg -> 111
+ | Cn -> 112
+ | Nh -> 113
+ | Fl -> 114
+ | Mc -> 115
+ | Lv -> 116
+ | Ts -> 117
+ | Og -> 118
in Charge.of_int result
@@ -565,7 +565,7 @@ let of_charge c = match (Charge.to_int c) with
| 52 -> Te
| 53 -> I
| 54 -> Xe
-| 55 -> Cs
+| 55 -> Cs
| 56 -> Ba
| 57 -> La
| 58 -> Ce
@@ -880,7 +880,7 @@ let vdw_radius x =
| Ts -> None
| Og -> None
in
- match result x with
+ match result x with
| Some y -> Some (Positive_float.of_float @@ Units.angstrom_to_bohr *. y )
| None -> None
diff --git a/ocaml/qp_create_ezfio.ml b/ocaml/qp_create_ezfio.ml
index 8e452762..4e17c0ad 100644
--- a/ocaml/qp_create_ezfio.ml
+++ b/ocaml/qp_create_ezfio.ml
@@ -6,8 +6,8 @@ type element =
| Element of Element.t
| Int_elem of (Nucl_number.t * Element.t)
-(** Handle dummy atoms placed on bonds *)
-let dummy_centers ~threshold ~molecule ~nuclei =
+(** Handle ghost atoms placed on bonds *)
+let ghost_centers ~threshold ~molecule ~nuclei =
let d =
Molecule.distance_matrix molecule
in
@@ -68,11 +68,11 @@ let run ?o b au c d m p cart xyz_file =
(Molecule.of_file xyz_file ~charge:(Charge.of_int c)
~multiplicity:(Multiplicity.of_int m) )
in
- let dummy =
- dummy_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei
+ let ghost =
+ ghost_centers ~threshold:d ~molecule ~nuclei:molecule.Molecule.nuclei
in
let nuclei =
- molecule.Molecule.nuclei @ dummy
+ molecule.Molecule.nuclei @ ghost
in
@@ -145,8 +145,6 @@ let run ?o b au c d m p cart xyz_file =
| i :: k :: [] -> (Nucl_number.of_int @@ int_of_string i, Element.of_string k)
| _ -> failwith "Expected format is int,Element:basis"
in Int_elem result
- and basis =
- String.lowercase_ascii basis
in
let key =
match elem with
@@ -313,7 +311,7 @@ let run ?o b au c d m p cart xyz_file =
}
in
let nuclei =
- molecule.Molecule.nuclei @ dummy
+ molecule.Molecule.nuclei @ ghost
in
@@ -491,11 +489,7 @@ let run ?o b au c d m p cart xyz_file =
|> List.rev
|> list_map (fun (x,i) ->
try
- let e =
- match x.Atom.element with
- | Element.X -> Element.H
- | e -> e
- in
+ let e = x.Atom.element in
let key =
Int_elem (i,x.Atom.element)
in
@@ -507,9 +501,15 @@ let run ?o b au c d m p cart xyz_file =
in
try
Basis.read_element (basis_channel key) i e
- with Not_found ->
- failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i)
- (Element.to_string x.Atom.element) )
+ with _ ->
+ try
+ if e = Element.X then
+ Basis.read_element (basis_channel key) i (Element.H)
+ else
+ raise Not_found
+ with Not_found ->
+ failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i)
+ (Element.to_string x.Atom.element) )
with
| End_of_file -> failwith
("Element "^(Element.to_string x.Atom.element)^" not found in basis set.")
@@ -710,9 +710,9 @@ If a file with the same name as the basis set exists, this file will be read. O
arg=With_arg "";
doc="Total charge of the molecule. Default is 0. For negative values, use m instead of -, for ex m1"} ;
- { opt=Optional ; short='d'; long="dummy";
+ { opt=Optional ; short='g'; long="ghost";
arg=With_arg "";
- doc="Add dummy atoms. x * (covalent radii of the atoms)."} ;
+ doc="Add ghost atoms. x * (covalent radii of the atoms)."} ;
{ opt=Optional ; short='m'; long="multiplicity";
arg=With_arg "";
@@ -756,8 +756,8 @@ If a file with the same name as the basis set exists, this file will be read. O
int_of_string x )
in
- let dummy =
- match Command_line.get "dummy" with
+ let ghost =
+ match Command_line.get "ghost" with
| None -> 0.
| Some x -> float_of_string x
in
@@ -782,7 +782,7 @@ If a file with the same name as the basis set exists, this file will be read. O
| x::_ -> x
in
- run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
+ run ?o:output basis au charge ghost multiplicity pseudo cart xyz_filename
)
with
(* | Failure txt -> Printf.eprintf "Fatal error: %s\n%!" txt *)
From 36bae4971dc273b0aefc7d1efecd0d48b8421815 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 29 Feb 2024 18:44:40 +0100
Subject: [PATCH 035/140] added some j for plotting
---
plugins/local/tc_scf/jast_schmos_90.irp.f | 318 ++++++++++++++++++++++
plugins/local/tc_scf/plot_j_schMos.irp.f | 69 +++++
src/cipsi/selection.irp.f | 10 +
3 files changed, 397 insertions(+)
create mode 100644 plugins/local/tc_scf/jast_schmos_90.irp.f
create mode 100644 plugins/local/tc_scf/plot_j_schMos.irp.f
diff --git a/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f
new file mode 100644
index 00000000..5c5e625f
--- /dev/null
+++ b/plugins/local/tc_scf/jast_schmos_90.irp.f
@@ -0,0 +1,318 @@
+ BEGIN_PROVIDER [integer , m_max_sm_7]
+&BEGIN_PROVIDER [integer , n_max_sm_7]
+&BEGIN_PROVIDER [integer , o_max_sm_7]
+ implicit none
+ BEGIN_DOC
+! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
+! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_7 version of Table IV
+ END_DOC
+ m_max_sm_7 = 4
+ n_max_sm_7 = 0
+ o_max_sm_7 = 4
+END_PROVIDER
+
+ BEGIN_PROVIDER [integer , m_max_sm_9]
+&BEGIN_PROVIDER [integer , n_max_sm_9]
+&BEGIN_PROVIDER [integer , o_max_sm_9]
+ implicit none
+ BEGIN_DOC
+! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
+! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_9 version of Table IV
+ END_DOC
+ m_max_sm_9 = 4
+ n_max_sm_9 = 2
+ o_max_sm_9 = 4
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [integer , m_max_sm_17]
+&BEGIN_PROVIDER [integer , n_max_sm_17]
+&BEGIN_PROVIDER [integer , o_max_sm_17]
+ implicit none
+ BEGIN_DOC
+! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
+! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_17 version of Table IV
+ END_DOC
+ m_max_sm_17 = 6
+ n_max_sm_17 = 2
+ o_max_sm_17 = 6
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, c_mn_o_sm_7, (0:m_max_sm_7,0:n_max_sm_7,0:o_max_sm_7,2:10)]
+ implicit none
+ BEGIN_DOC
+ !
+ !c_mn_o_7(0:4,0:4,2:10) = coefficient for the SM_7 correlation factor as given is Table IV of
+ ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! the first index (0:4) is the "m" integer for the 1e part
+ ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_7
+ ! the third index (0:4) is the "o" integer for the 2e part
+ ! the fourth index (2:10) is the nuclear charge of the atom
+ END_DOC
+ c_mn_o_sm_7 = 0.d0
+ integer :: i
+ do i = 2, 10 ! loop over nuclear charge
+ c_mn_o_sm_7(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
+ enddo
+ ! He atom
+ ! two electron terms
+ c_mn_o_sm_7(0,0,2,2) = 0.50516d0
+ c_mn_o_sm_7(0,0,3,2) = -0.19313d0
+ c_mn_o_sm_7(0,0,4,2) = 0.30276d0
+ ! one-electron terms
+ c_mn_o_sm_7(2,0,0,2) = -0.16995d0
+ c_mn_o_sm_7(3,0,0,2) = -0.34505d0
+ c_mn_o_sm_7(4,0,0,2) = -0.54777d0
+ ! Ne atom
+ ! two electron terms
+ c_mn_o_sm_7(0,0,2,10) = -0.792d0
+ c_mn_o_sm_7(0,0,3,10) = 1.05232d0
+ c_mn_o_sm_7(0,0,4,10) = -0.65615d0
+ ! one-electron terms
+ c_mn_o_sm_7(2,0,0,10) = -0.13312d0
+ c_mn_o_sm_7(3,0,0,10) = -0.00131d0
+ c_mn_o_sm_7(4,0,0,10) = 0.09083d0
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, c_mn_o_sm_9, (0:m_max_sm_9,0:n_max_sm_9,0:o_max_sm_9,2:10)]
+ implicit none
+ BEGIN_DOC
+ !
+ !c_mn_o_9(0:4,0:4,2:10) = coefficient for the SM_9 correlation factor as given is Table IV of
+ ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! the first index (0:4) is the "m" integer for the 1e part
+ ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_9
+ ! the third index (0:4) is the "o" integer for the 2e part
+ ! the fourth index (2:10) is the nuclear charge of the atom
+ END_DOC
+ c_mn_o_sm_9 = 0.d0
+ integer :: i
+ do i = 2, 10 ! loop over nuclear charge
+ c_mn_o_sm_9(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
+ enddo
+ ! He atom
+ ! two electron terms
+ c_mn_o_sm_9(0,0,2,2) = 0.50516d0
+ c_mn_o_sm_9(0,0,3,2) = -0.19313d0
+ c_mn_o_sm_9(0,0,4,2) = 0.30276d0
+ ! one-electron terms
+ c_mn_o_sm_9(2,0,0,2) = -0.16995d0
+ c_mn_o_sm_9(3,0,0,2) = -0.34505d0
+ c_mn_o_sm_9(4,0,0,2) = -0.54777d0
+ ! Ne atom
+ ! two electron terms
+ c_mn_o_sm_9(0,0,2,10) = -0.792d0
+ c_mn_o_sm_9(0,0,3,10) = 1.05232d0
+ c_mn_o_sm_9(0,0,4,10) = -0.65615d0
+ ! one-electron terms
+ c_mn_o_sm_9(2,0,0,10) = -0.13312d0
+ c_mn_o_sm_9(3,0,0,10) = -0.00131d0
+ c_mn_o_sm_9(4,0,0,10) = 0.09083d0
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, c_mn_o_sm_17, (0:m_max_sm_17,0:n_max_sm_17,0:o_max_sm_17,2:10)]
+ implicit none
+ BEGIN_DOC
+ !
+ !c_mn_o_17(0:4,0:4,2:10) = coefficient for the SM_17 correlation factor as given is Table IV of
+ ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! the first index (0:4) is the "m" integer for the 1e part
+ ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_17
+ ! the third index (0:4) is the "o" integer for the 2e part
+ ! the fourth index (2:10) is the nuclear charge of the atom
+ END_DOC
+ c_mn_o_sm_17 = 0.d0
+ integer :: i
+ do i = 2, 10 ! loop over nuclear charge
+ c_mn_o_sm_17(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
+ enddo
+ ! He atom
+ ! two electron terms
+ c_mn_o_sm_17(0,0,2,2) = 0.09239d0
+ c_mn_o_sm_17(0,0,3,2) = -0.38664d0
+ c_mn_o_sm_17(0,0,4,2) = 0.95764d0
+ ! one-electron terms
+ c_mn_o_sm_17(2,0,0,2) = 0.23208d0
+ c_mn_o_sm_17(3,0,0,2) = -0.45032d0
+ c_mn_o_sm_17(4,0,0,2) = 0.82777d0
+ c_mn_o_sm_17(2,2,0,2) = -4.15388d0
+ ! ee-n terms
+ c_mn_o_sm_17(2,0,2,2) = 0.80622d0
+ c_mn_o_sm_17(2,2,2,2) = 10.19704d0
+ c_mn_o_sm_17(4,0,2,2) = -4.96259d0
+ c_mn_o_sm_17(2,0,4,2) = -1.35647d0
+ c_mn_o_sm_17(4,2,2,2) = -5.90907d0
+ c_mn_o_sm_17(6,0,2,2) = 0.90343d0
+ c_mn_o_sm_17(4,0,4,2) = 5.50739d0
+ c_mn_o_sm_17(2,2,4,2) = -0.03154d0
+ c_mn_o_sm_17(2,0,6,2) = -1.1051860
+
+
+ ! Ne atom
+ ! two electron terms
+ c_mn_o_sm_17(0,0,2,10) = -0.80909d0
+ c_mn_o_sm_17(0,0,3,10) = -0.00219d0
+ c_mn_o_sm_17(0,0,4,10) = 0.59188d0
+ ! one-electron terms
+ c_mn_o_sm_17(2,0,0,10) = -0.00567d0
+ c_mn_o_sm_17(3,0,0,10) = 0.14011d0
+ c_mn_o_sm_17(4,0,0,10) = -0.05671d0
+ c_mn_o_sm_17(2,2,0,10) = -3.33767d0
+ ! ee-n terms
+ c_mn_o_sm_17(2,0,2,10) = 1.95067d0
+ c_mn_o_sm_17(2,2,2,10) = 6.83340d0
+ c_mn_o_sm_17(4,0,2,10) = -3.29231d0
+ c_mn_o_sm_17(2,0,4,10) = -2.44998d0
+ c_mn_o_sm_17(4,2,2,10) = -2.13029d0
+ c_mn_o_sm_17(6,0,2,10) = 2.25768d0
+ c_mn_o_sm_17(4,0,4,10) = 1.97951d0
+ c_mn_o_sm_17(2,2,4,10) = -2.0924160
+ c_mn_o_sm_17(2,0,6,10) = 0.35493d0
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ double precision, b_I_sm_90,(2:10)]
+&BEGIN_PROVIDER [ double precision, d_I_sm_90,(2:10)]
+ implicit none
+ BEGIN_DOC
+! "b_I" and "d_I" parameters of Eqs. (4) and (5) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ END_DOC
+ b_I_sm_90 = 1.d0
+ d_I_sm_90 = 1.d0
+
+END_PROVIDER
+
+subroutine get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ implicit none
+ double precision, intent(in) :: r1(3),r2(3),rI(3)
+ integer, intent(in) :: sm_j, i_charge
+ double precision, intent(out):: j_1e,j_2e,j_een,j_tot
+ BEGIN_DOC
+ ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
+ ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
+ END_DOC
+ double precision :: r_inucl,r_jnucl,r_ij,b_I, d_I
+ b_I = b_I_sm_90(i_charge)
+ d_I = d_I_sm_90(i_charge)
+ call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
+ call jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+end
+
+subroutine get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
+ implicit none
+ BEGIN_DOC
+ ! rescaled variables of Eq. (5) and (6) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! the "b_I" and "d_I" parameters are the same as in Eqs. (5) and (6)
+ END_DOC
+ double precision, intent(in) :: r1(3),r2(3),rI(3)
+ double precision, intent(in) :: b_I, d_I
+ double precision, intent(out):: r_inucl,r_jnucl,r_ij
+ double precision :: rin, rjn, rij
+ integer :: i
+ rin = 0.d0
+ rjn = 0.d0
+ rij = 0.d0
+ do i = 1,3
+ rin += (r1(i) - rI(i)) * (r1(i) - rI(i))
+ rjn += (r2(i) - rI(i)) * (r2(i) - rI(i))
+ rij += (r2(i) - r1(i)) * (r2(i) - r1(i))
+ enddo
+ rin = dsqrt(rin)
+ rjn = dsqrt(rjn)
+ rij = dsqrt(rij)
+ r_inucl = b_I * rin/(1.d0 + b_I * rin)
+ r_jnucl = b_I * rjn/(1.d0 + b_I * rjn)
+ r_ij = d_I * rij/(1.d0 + b_I * rij)
+end
+
+subroutine jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ implicit none
+ BEGIN_DOC
+ ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+ ! Here the r_inucl, r_jnucl are the rescaled variables as defined in Eq. (5) with "b_I"
+ ! r_ij is the rescaled variable as defined in Eq. (6) with "d_I"
+ ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
+ ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
+ !
+ ! it returns the j_1e : sum of terms with "o" = "n" = 0, "m" /= 0,
+ ! j_2e : sum of terms with "m" = "n" = 0, "o" /= 0,
+ ! j_een : sum of terms with "m" /=0, "n" /= 0, "o" /= 0,
+ ! j_tot : the total sum
+ END_DOC
+ double precision, intent(in) :: r_inucl,r_jnucl,r_ij
+ integer, intent(in) :: sm_j,i_charge
+ double precision, intent(out):: j_1e,j_2e,j_een,j_tot
+ j_1e = 0.D0
+ j_2e = 0.D0
+ j_een = 0.D0
+ double precision :: delta_mn,jastrow_sm_90_atomic
+ integer :: m,n,o
+BEGIN_TEMPLATE
+ ! pure 2e part
+ n = 0
+ m = 0
+ if(sm_j == $X )then
+ do o = 1, o_max_sm_$X
+ if(dabs(c_mn_o_sm_$X(m,n,o,i_charge)).lt.1.d-10)cycle
+ j_2e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
+ enddo
+! else
+! print*,'sm_j = ',sm_j
+! print*,'not implemented, stop'
+! stop
+ endif
+ ! pure one-e part
+ o = 0
+ if(sm_j == $X)then
+ do n = 2, n_max_sm_$X
+ do m = 2, m_max_sm_$X
+ j_1e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
+ enddo
+ enddo
+! else
+! print*,'sm_j = ',sm_j
+! print*,'not implemented, stop'
+! stop
+ endif
+ ! e-e-n part
+ if(sm_j == $X)then
+ do o = 1, o_max_sm_$X
+ do m = 2, m_max_sm_$X
+ do n = 2, n_max_sm_$X
+ j_een += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
+ enddo
+ enddo
+ enddo
+ else
+! print*,'sm_j = ',sm_j
+! print*,'not implemented, stop'
+! stop
+ endif
+ j_tot = j_1e + j_2e + j_een
+SUBST [ X]
+ 7 ;;
+ 9 ;;
+ 17 ;;
+END_TEMPLATE
+end
+
+double precision function jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
+ implicit none
+ BEGIN_DOC
+! contribution to the function of Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
+! for a given m,n,o and atom
+ END_DOC
+ double precision, intent(in) :: r_inucl,r_jnucl,r_ij
+ integer , intent(in) :: m,n,o,i_charge
+ double precision :: delta_mn
+ if(m==n)then
+ delta_mn = 0.5d0
+ else
+ delta_mn = 1.D0
+ endif
+ jastrow_sm_90_atomic = delta_mn * (r_inucl**m * r_jnucl**n + r_jnucl**m * r_inucl**n)*r_ij**o
+end
diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f
new file mode 100644
index 00000000..eda0dd25
--- /dev/null
+++ b/plugins/local/tc_scf/plot_j_schMos.irp.f
@@ -0,0 +1,69 @@
+program plot_j
+ implicit none
+ double precision :: r1(3),rI(3),r2(3)
+ double precision :: r12,dx,xmax, j_1e,j_2e,j_een,j_tot
+ double precision :: j_mu_F_x_j
+ integer :: i,nx,m,i_charge,sm_j
+
+ character*(128) :: output
+ integer :: i_unit_output_He_sm_7,i_unit_output_Ne_sm_7
+ integer :: i_unit_output_He_sm_17,i_unit_output_Ne_sm_17
+ integer :: getUnitAndOpen
+ output='J_SM_7_He'
+ i_unit_output_He_sm_7 = getUnitAndOpen(output,'w')
+ output='J_SM_7_Ne'
+ i_unit_output_Ne_sm_7 = getUnitAndOpen(output,'w')
+
+ output='J_SM_17_He'
+ i_unit_output_He_sm_17 = getUnitAndOpen(output,'w')
+ output='J_SM_17_Ne'
+ i_unit_output_Ne_sm_17 = getUnitAndOpen(output,'w')
+
+ rI = 0.d0
+ r1 = 0.d0
+ r2 = 0.d0
+ r1(1) = 1.5d0
+ xmax = 20.d0
+ r2(1) = -xmax*0.5d0
+ nx = 1000
+ dx = xmax/dble(nx)
+ do i = 1, nx
+ r12 = 0.d0
+ do m = 1, 3
+ r12 += (r1(m) - r2(m))*(r1(m) - r2(m))
+ enddo
+ r12 = dsqrt(r12)
+ double precision :: jmu,env_nucl,jmu_env,jmu_scaled, jmu_scaled_env
+ double precision :: b_I,d_I,r_inucl,r_jnucl,r_ij
+ b_I = 1.D0
+ d_I = 1.D0
+ call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
+ jmu=j_mu_F_x_j(r12)
+ jmu_scaled=j_mu_F_x_j(r_ij)
+ jmu_env = jmu * env_nucl(r1) * env_nucl(r2)
+! jmu_scaled_env= jmu_scaled * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_inucl**2)) * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_jnucl**2))
+ jmu_scaled_env= jmu_scaled * env_nucl(r1) * env_nucl(r2)
+ ! He
+ i_charge = 2
+ ! SM 7 Jastrow
+ sm_j = 7
+ call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ write(i_unit_output_He_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
+ ! SM 17 Jastrow
+ sm_j = 17
+ call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ write(i_unit_output_He_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
+ ! Ne
+ i_charge = 10
+ ! SM 7 Jastrow
+ sm_j = 7
+ call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ write(i_unit_output_Ne_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
+ ! SM 17 Jastrow
+ sm_j = 17
+ call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
+ write(i_unit_output_Ne_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
+ r2(1) += dx
+ enddo
+
+end
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index b8fa2895..59cfdff8 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -845,7 +845,13 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
if (h0_type == 'CFG') then
w = min(w, e_pert(istate) * s_weight(istate,istate)) / c0_weight(istate)
else
+! if(dabs(e_pert(istate) * s_weight(istate,istate)).gt.1.d-5)then
+! print*,w,e_pert(istate) * s_weight(istate,istate)
+! endif
w = min(w, e_pert(istate) * s_weight(istate,istate))
+! if(dabs(e_pert(istate) * s_weight(istate,istate)).gt.1.d-5)then
+! print*,w
+! endif
endif
end select
@@ -883,6 +889,10 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
w *= dsqrt(dble(n))
endif
+ if(dabs(w).gt.1.d-5)then
+ print*,w,buf%mini
+ endif
+
if(w <= buf%mini) then
call add_to_selection_buffer(buf, det, w)
end if
From b0fdf35983c6458805923c1a440cff72ad7fc150 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Fri, 1 Mar 2024 13:37:46 +0100
Subject: [PATCH 036/140] PROVIDING bug
---
plugins/local/tc_bi_ortho/slater_tc_opt.irp.f | 23 +-
.../tc_bi_ortho/slater_tc_opt_diag.irp.f | 2 +
.../tc_bi_ortho/slater_tc_opt_single.irp.f | 419 ++++++++++--------
plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f | 13 +
plugins/local/tc_bi_ortho/tc_hmat.irp.f | 28 +-
5 files changed, 281 insertions(+), 204 deletions(-)
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
index 9901a853..59efc943 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
+++ b/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
@@ -8,8 +8,13 @@ subroutine provide_all_three_ints_bi_ortho()
END_DOC
implicit none
+ double precision :: t1, t2
+
PROVIDE ao_two_e_integrals_in_map
+ print *, ' start provide_all_three_ints_bi_ortho'
+ call wall_time(t1)
+
if(three_body_h_tc) then
if(three_e_3_idx_term) then
@@ -32,6 +37,9 @@ subroutine provide_all_three_ints_bi_ortho()
endif
+ call wall_time(t2)
+ print *, ' end provide_all_three_ints_bi_ortho after (min) = ', (t2-t1)/60.d0
+
return
end
@@ -83,8 +91,11 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
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
+ PROVIDE pure_three_body_h_tc
+
hmono = 0.d0
htwoe = 0.d0
htot = 0.d0
@@ -99,7 +110,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
- call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
+ call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
endif
@@ -111,7 +122,7 @@ subroutine htilde_mu_mat_opt_bi_ortho(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho (Nint, key_i, hmono, htwoe, hthree, htot)
else if (degree == 1) then
- call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i , hmono, htwoe, hthree, htot)
+ call single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
else
@@ -149,16 +160,16 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e(key_j, key_i, Nint, htot)
double precision, intent(out) :: htot
integer :: degree
- htot = 0.d0
+ htot = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.gt.2) return
- if(degree == 0)then
+ if(degree == 0) then
call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,htot)
- else if (degree == 1)then
+ else if (degree == 1) then
call single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint,key_j, key_i , htot)
- else if(degree == 2)then
+ else if(degree == 2) then
call double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
endif
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
index cc1a0603..78f9dc66 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
+++ b/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
@@ -15,6 +15,8 @@
implicit none
double precision :: hmono, htwoe, htot, hthree
+ PROVIDE N_int
+ PROVIDE HF_bitmask
PROVIDE mo_l_coef mo_r_coef
call diag_htilde_mu_mat_bi_ortho_slow(N_int, HF_bitmask, hmono, htwoe, htot)
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
index 81bf69f4..e57cb05c 100644
--- a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
+++ b/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
@@ -19,6 +19,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_j(Nint,2), key_i(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, 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)
@@ -44,27 +45,28 @@ subroutine single_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe,
call bitstring_to_list_ab(key_i, occ, Ne, Nint)
call get_single_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc, 1, h1, p1, h2, p2, s1, s2)
- call get_single_excitation_from_fock_tc(key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot)
+ call get_single_excitation_from_fock_tc(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hthree, htot)
end
! ---
-subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot)
+subroutine get_single_excitation_from_fock_tc(Nint, key_i, key_j, h, p, spin, phase, hmono, htwoe, hthree, htot)
use bitmasks
implicit none
+ integer, intent(in) :: Nint
integer, intent(in) :: h, p, spin
double precision, intent(in) :: phase
- integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
double precision, intent(out) :: hmono, htwoe, hthree, htot
- integer(bit_kind) :: differences(N_int,2)
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: partcl(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_partcl(N_int*bit_kind_size,2)
+ integer(bit_kind) :: differences(Nint,2)
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: partcl(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_partcl(Nint*bit_kind_size,2)
integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
integer :: i0,i
double precision :: buffer_c(mo_num),buffer_x(mo_num)
@@ -74,7 +76,7 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
enddo
- do i = 1, N_int
+ do i = 1, Nint
differences(i,1) = xor(key_i(i,1), ref_closed_shell_bitmask(i,1))
differences(i,2) = xor(key_i(i,2), ref_closed_shell_bitmask(i,2))
hole (i,1) = iand(differences(i,1), ref_closed_shell_bitmask(i,1))
@@ -83,8 +85,8 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
partcl (i,2) = iand(differences(i,2), key_i(i,2))
enddo
- call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
- call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint)
hmono = mo_bi_ortho_tc_one_e(p,h)
htwoe = fock_op_2_e_tc_closed_shell(p,h)
@@ -122,7 +124,7 @@ subroutine get_single_excitation_from_fock_tc(key_i, key_j, h, p, spin, phase, h
hthree = 0.d0
if (three_body_h_tc .and. elec_num.gt.2 .and. three_e_4_idx_term) then
- call three_comp_fock_elem(key_i, h, p, spin, hthree)
+ call three_comp_fock_elem(Nint, key_i, h, p, spin, hthree)
endif
htwoe = htwoe * phase
@@ -134,24 +136,27 @@ end
! ---
-subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
- implicit none
- integer,intent(in) :: h_fock,p_fock,ispin_fock
- integer(bit_kind), intent(in) :: key_i(N_int,2)
- double precision, intent(out) :: hthree
- integer :: nexc(2),i,ispin,na,nb
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: particle(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_particle(N_int*bit_kind_size,2)
- integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
- integer(bit_kind) :: det_tmp(N_int,2)
+subroutine three_comp_fock_elem(Nint, key_i, h_fock, p_fock, ispin_fock, hthree)
+ implicit none
+ integer, intent(in) :: Nint
+ integer, intent(in) :: h_fock, p_fock, ispin_fock
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ double precision, intent(out) :: hthree
+
+ integer :: nexc(2),i,ispin,na,nb
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: particle(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_particle(Nint*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_particle(2)
+ integer(bit_kind) :: det_tmp(Nint,2)
nexc(1) = 0
nexc(2) = 0
+
!! Get all the holes and particles of key_i with respect to the ROHF determinant
- do i=1,N_int
+ do i = 1, Nint
hole(i,1) = xor(key_i(i,1),ref_bitmask(i,1))
hole(i,2) = xor(key_i(i,2),ref_bitmask(i,2))
particle(i,1) = iand(hole(i,1),key_i(i,1))
@@ -161,13 +166,14 @@ subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
nexc(1) = nexc(1) + popcnt(hole(i,1))
nexc(2) = nexc(2) + popcnt(hole(i,2))
enddo
+
integer :: tmp(2)
!DIR$ FORCEINLINE
- call bitstring_to_list_ab(particle, occ_particle, tmp, N_int)
+ call bitstring_to_list_ab(particle, occ_particle, tmp, Nint)
ASSERT (tmp(1) == nexc(1)) ! Number of particles alpha
ASSERT (tmp(2) == nexc(2)) ! Number of particle beta
!DIR$ FORCEINLINE
- call bitstring_to_list_ab(hole, occ_hole, tmp, N_int)
+ call bitstring_to_list_ab(hole, occ_hole, tmp, Nint)
ASSERT (tmp(1) == nexc(1)) ! Number of holes alpha
ASSERT (tmp(2) == nexc(2)) ! Number of holes beta
@@ -181,15 +187,18 @@ subroutine three_comp_fock_elem(key_i,h_fock,p_fock,ispin_fock,hthree)
do ispin=1,2
na = elec_num_tab(ispin)
nb = elec_num_tab(iand(ispin,1)+1)
- do i=1,nexc(ispin)
+ do i = 1, nexc(ispin)
!DIR$ FORCEINLINE
- call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+ call fock_ac_tc_operator( occ_particle(i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, Nint, na, nb)
!DIR$ FORCEINLINE
- call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, N_int,na,nb)
+ call fock_a_tc_operator ( occ_hole (i,ispin), ispin, det_tmp, h_fock,p_fock, ispin_fock, hthree, Nint, na, nb)
enddo
enddo
+
end
+! ---
+
subroutine fock_ac_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,Nint,na,nb)
use bitmasks
implicit none
@@ -365,111 +374,118 @@ subroutine fock_a_tc_operator(iorb,ispin,key, h_fock,p_fock, ispin_fock,hthree,N
end
+! ---
-BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num) ]
- implicit none
- BEGIN_DOC
-! Closed-shell part of the Fock operator for the TC operator
- END_DOC
- integer :: h0,p0,h,p,k0,k,i
- integer :: n_occ_ab(2)
- integer :: occ(N_int*bit_kind_size,2)
- integer :: n_occ_ab_virt(2)
- integer :: occ_virt(N_int*bit_kind_size,2)
- integer(bit_kind) :: key_test(N_int)
- integer(bit_kind) :: key_virt(N_int,2)
- double precision :: accu
+BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num)]
- fock_op_2_e_tc_closed_shell = -1000.d0
- call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
- do i = 1, N_int
- key_virt(i,1) = full_ijkl_bitmask(i)
- key_virt(i,2) = full_ijkl_bitmask(i)
- key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
- key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
- enddo
- call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
- ! docc ---> virt single excitations
- do h0 = 1, n_occ_ab(1)
- h=occ(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p = occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+ BEGIN_DOC
+ ! Closed-shell part of the Fock operator for the TC operator
+ END_DOC
+
+ implicit none
+
+ PROVIDE N_int
+
+ integer :: h0,p0,h,p,k0,k,i
+ integer :: n_occ_ab(2)
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ double precision :: accu
+
+ fock_op_2_e_tc_closed_shell = -1000.d0
+ call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
+
+ do i = 1, N_int
+ key_virt(i,1) = full_ijkl_bitmask(i)
+ key_virt(i,2) = full_ijkl_bitmask(i)
+ key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
+ key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
enddo
- enddo
-
- do h0 = 1, n_occ_ab_virt(1)
- h = occ_virt(h0,1)
- do p0 = 1, n_occ_ab(1)
- p=occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+ call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+ ! docc ---> virt single excitations
+ do h0 = 1, n_occ_ab(1)
+ h = occ(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p = occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
enddo
- enddo
-
- ! virt ---> virt single excitations
- do h0 = 1, n_occ_ab_virt(1)
- h=occ_virt(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p = occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
- enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
+
+ do h0 = 1, n_occ_ab_virt(1)
+ h = occ_virt(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p = occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
enddo
- enddo
-
- do h0 = 1, n_occ_ab_virt(1)
- h = occ_virt(h0,1)
- do p0 = 1, n_occ_ab_virt(1)
- p=occ_virt(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+ ! virt ---> virt single excitations
+ do h0 = 1, n_occ_ab_virt(1)
+ h=occ_virt(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p = occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
-
-
- ! docc ---> docc single excitations
- do h0 = 1, n_occ_ab(1)
- h=occ(h0,1)
- do p0 = 1, n_occ_ab(1)
- p = occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+ do h0 = 1, n_occ_ab_virt(1)
+ h = occ_virt(h0,1)
+ do p0 = 1, n_occ_ab_virt(1)
+ p=occ_virt(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
-
- do h0 = 1, n_occ_ab(1)
- h = occ(h0,1)
- do p0 = 1, n_occ_ab(1)
- p=occ(p0,1)
- accu = 0.d0
- do k0 = 1, n_occ_ab(1)
- k = occ(k0,1)
- accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+
+
+ ! docc ---> docc single excitations
+ do h0 = 1, n_occ_ab(1)
+ h=occ(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p = occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
+ enddo
+ enddo
+
+ do h0 = 1, n_occ_ab(1)
+ h = occ(h0,1)
+ do p0 = 1, n_occ_ab(1)
+ p=occ(p0,1)
+ accu = 0.d0
+ do k0 = 1, n_occ_ab(1)
+ k = occ(k0,1)
+ accu += 2.d0 * tc_2e_3idx_coulomb_integrals(k,p,h) - tc_2e_3idx_exchange_integrals(k,p,h)
+ enddo
+ fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- fock_op_2_e_tc_closed_shell(p,h) = accu
enddo
- enddo
! do i = 1, mo_num
! write(*,'(100(F10.5,X))')fock_op_2_e_tc_closed_shell(:,i)
@@ -477,8 +493,10 @@ BEGIN_PROVIDER [double precision, fock_op_2_e_tc_closed_shell, (mo_num, mo_num)
END_PROVIDER
+! ---
subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
+
BEGIN_DOC
! for single excitation ONLY FOR ONE- AND TWO-BODY TERMS
!!
@@ -492,8 +510,9 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
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
+ double precision, intent(out) :: htot
+
+ double precision :: hmono, htwoe
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)
@@ -517,75 +536,85 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
call get_single_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
- call get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h1,p1,s1,phase,hmono,htwoe,htot)
-end
-
-
-subroutine get_single_excitation_from_fock_tc_no_3e(key_i,key_j,h,p,spin,phase,hmono,htwoe,htot)
- use bitmasks
- implicit none
- integer,intent(in) :: h,p,spin
- double precision, intent(in) :: phase
- integer(bit_kind), intent(in) :: key_i(N_int,2), key_j(N_int,2)
- double precision, intent(out) :: hmono,htwoe,htot
- integer(bit_kind) :: differences(N_int,2)
- integer(bit_kind) :: hole(N_int,2)
- integer(bit_kind) :: partcl(N_int,2)
- integer :: occ_hole(N_int*bit_kind_size,2)
- integer :: occ_partcl(N_int*bit_kind_size,2)
- integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
- integer :: i0,i
- double precision :: buffer_c(mo_num),buffer_x(mo_num)
- do i=1, mo_num
- buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
- buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
- enddo
- do i = 1, N_int
- differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
- differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
- hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
- hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
- partcl(i,1) = iand(differences(i,1),key_i(i,1))
- partcl(i,2) = iand(differences(i,2),key_i(i,2))
- enddo
- call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
- call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
- hmono = mo_bi_ortho_tc_one_e(p,h)
- htwoe = fock_op_2_e_tc_closed_shell(p,h)
- ! holes :: direct terms
- do i0 = 1, n_occ_ab_hole(1)
- i = occ_hole(i0,1)
- htwoe -= buffer_c(i)
- enddo
- do i0 = 1, n_occ_ab_hole(2)
- i = occ_hole(i0,2)
- htwoe -= buffer_c(i)
- enddo
-
- ! holes :: exchange terms
- do i0 = 1, n_occ_ab_hole(spin)
- i = occ_hole(i0,spin)
- htwoe += buffer_x(i)
- enddo
-
- ! particles :: direct terms
- do i0 = 1, n_occ_ab_partcl(1)
- i = occ_partcl(i0,1)
- htwoe += buffer_c(i)
- enddo
- do i0 = 1, n_occ_ab_partcl(2)
- i = occ_partcl(i0,2)
- htwoe += buffer_c(i)
- enddo
-
- ! particles :: exchange terms
- do i0 = 1, n_occ_ab_partcl(spin)
- i = occ_partcl(i0,spin)
- htwoe -= buffer_x(i)
- enddo
- htwoe = htwoe * phase
- hmono = hmono * phase
- htot = htwoe + hmono
+ call get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, htot)
+
+end
+
+! ---
+
+subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, spin, phase, hmono, htwoe, htot)
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer, intent(in) :: h, p, spin
+ double precision, intent(in) :: phase
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: hmono,htwoe,htot
+
+ integer(bit_kind) :: differences(Nint,2)
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: partcl(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_partcl(Nint*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ double precision :: buffer_c(mo_num), buffer_x(mo_num)
+
+ do i = 1, mo_num
+ buffer_c(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+ buffer_x(i) = tc_2e_3idx_exchange_integrals(i,p,h)
+ enddo
+
+ do i = 1, Nint
+ differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
+ differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
+ hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+ hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+ partcl(i,1) = iand(differences(i,1),key_i(i,1))
+ partcl(i,2) = iand(differences(i,2),key_i(i,2))
+ enddo
+
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint)
+ hmono = mo_bi_ortho_tc_one_e(p,h)
+ htwoe = fock_op_2_e_tc_closed_shell(p,h)
+
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+ i = occ_hole(i0,1)
+ htwoe -= buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+ i = occ_hole(i0,2)
+ htwoe -= buffer_c(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+ i = occ_hole(i0,spin)
+ htwoe += buffer_x(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+ i = occ_partcl(i0,1)
+ htwoe += buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+ i = occ_partcl(i0,2)
+ htwoe += buffer_c(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+ i = occ_partcl(i0,spin)
+ htwoe -= buffer_x(i)
+ enddo
+ htwoe = htwoe * phase
+ hmono = hmono * phase
+ htot = htwoe + hmono
end
diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f
index 64982ab6..398e96db 100644
--- a/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f
@@ -7,6 +7,10 @@ program tc_bi_ortho
!
END_DOC
+ implicit none
+
+ PROVIDE N_int
+
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
@@ -66,6 +70,15 @@ subroutine routine_diag()
! provide overlap_bi_ortho
! provide htilde_matrix_elmt_bi_ortho
+ if(noL_standard) then
+ PROVIDE noL_0e
+ PROVIDE noL_1e
+ PROVIDE noL_2e
+ endif
+
+ PROVIDE htilde_matrix_elmt_bi_ortho
+ return
+
if(N_states .eq. 1) then
print*,'eigval_right_tc_bi_orth = ',eigval_right_tc_bi_orth(1)
diff --git a/plugins/local/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/tc_bi_ortho/tc_hmat.irp.f
index 88652caa..abec410d 100644
--- a/plugins/local/tc_bi_ortho/tc_hmat.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_hmat.irp.f
@@ -13,16 +13,34 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
implicit none
integer :: i, j
+ double precision :: t1, t2
double precision :: htot
+
+ PROVIDE N_int
+ PROVIDE psi_det
+ PROVIDE three_e_3_idx_term
- call provide_all_three_ints_bi_ortho
+ if(noL_standard) then
+ PROVIDE noL_0e
+ PROVIDE noL_1e
+ PROVIDE noL_2e
+ endif
+
+ print *, ' PROVIDING htilde_matrix_elmt_bi_ortho ...'
+ call wall_time(t1)
+
+ call provide_all_three_ints_bi_ortho()
i = 1
j = 1
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,j), psi_det(1,1,i), N_int, htot)
- !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j, htot) &
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, htot) &
!$OMP SHARED (N_det, psi_det, N_int, htilde_matrix_elmt_bi_ortho)
+ !$OMP DO
do i = 1, N_det
do j = 1, N_det
! < J |Htilde | I >
@@ -31,7 +49,11 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
htilde_matrix_elmt_bi_ortho(j,i) = htot
enddo
enddo
- !$OMP END PARALLEL DO
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(t2)
+ print *, ' wall time for htilde_matrix_elmt_bi_ortho (min) =', (t2-t1)/60.d0
END_PROVIDER
From 590463063f9151693c4deb07b50f2dc86a61bc10 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 5 Mar 2024 15:37:09 +0100
Subject: [PATCH 037/140] Adapted trexio file for full path
---
src/trexio/export_trexio.irp.f | 2 +-
src/trexio/export_trexio_routines.irp.f | 20 ++++++++++++++++----
2 files changed, 17 insertions(+), 5 deletions(-)
diff --git a/src/trexio/export_trexio.irp.f b/src/trexio/export_trexio.irp.f
index f9ecc17f..ff12aebb 100644
--- a/src/trexio/export_trexio.irp.f
+++ b/src/trexio/export_trexio.irp.f
@@ -2,6 +2,6 @@ program export_trexio_prog
implicit none
read_wf = .True.
SOFT_TOUCH read_wf
- call export_trexio(.False.)
+ call export_trexio(.False.,.False.)
end
diff --git a/src/trexio/export_trexio_routines.irp.f b/src/trexio/export_trexio_routines.irp.f
index f25ae370..034b142e 100644
--- a/src/trexio/export_trexio_routines.irp.f
+++ b/src/trexio/export_trexio_routines.irp.f
@@ -1,18 +1,28 @@
-subroutine export_trexio(update)
+subroutine export_trexio(update,full_path)
use trexio
implicit none
BEGIN_DOC
! Exports the wave function in TREXIO format
END_DOC
- logical, intent(in) :: update
+ logical, intent(in) :: update, full_path
integer(trexio_t) :: f(N_states) ! TREXIO file handle
integer(trexio_exit_code) :: rc
- integer :: k
+ integer :: k, iunit
double precision, allocatable :: factor(:)
- character*(256) :: filenames(N_states)
+ character*(256) :: filenames(N_states), fp
character :: rw
+ integer, external :: getunitandopen
+
+ if (full_path) then
+ fp = trexio_filename
+ call system('realpath '//trim(fp)//' > '//trim(fp)//'.tmp')
+ iunit = getunitandopen(trim(fp)//'.tmp','r')
+ read(iunit,'(A)') trexio_filename
+ close(iunit, status='delete')
+ endif
+
filenames(1) = trexio_filename
do k=2,N_states
write(filenames(k),'(A,I3.3)') trim(trexio_filename)//'.', k-1
@@ -49,6 +59,8 @@ subroutine export_trexio(update)
enddo
call ezfio_set_trexio_trexio_file(trexio_filename)
+
+
! ------------------------------------------------------------------------------
! Electrons
From 92a3ecae45247bbf0d003aa71c416ceba1e6207b Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 5 Mar 2024 15:39:57 +0100
Subject: [PATCH 038/140] Fix propagation of error codes in qp command
---
etc/qp.rc | 2 ++
1 file changed, 2 insertions(+)
diff --git a/etc/qp.rc b/etc/qp.rc
index d316faf5..bd061e3e 100644
--- a/etc/qp.rc
+++ b/etc/qp.rc
@@ -120,7 +120,9 @@ function qp()
if [[ $? -eq 0 ]] ; then
COMMAND='qp_$@'
eval "$COMMAND" "${EZFIO_FILE}"
+ result=$?
unset COMMAND
+ return $result
else
_qp_usage
fi
From 72daa98fa34b13758f4ef28df61e405fc24c90d1 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 5 Mar 2024 17:24:29 +0100
Subject: [PATCH 039/140] introduced TODO comments in TC
---
plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f | 1 +
plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f | 3 ++-
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
index c767f090..5f37b11e 100644
--- a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
+++ b/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
@@ -520,6 +520,7 @@ compute_singles=.True.
ASSERT (lrow <= N_det_alpha_unique)
tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow)
+ ! TODO: i_htc "optimized" for normal ordering for single/double by spin
! call i_h_j_single_spin( tmp_det, tmp_det2, $N_int, 1, hij)
if(do_right)then
call htilde_mu_mat_opt_bi_ortho_tot(tmp_det,tmp_det2,$N_int,hij)
diff --git a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
index a9e22e03..75f3dfbe 100644
--- a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
@@ -230,6 +230,7 @@ end
allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag))
+ ! TODO : OPEN-MP
do i = 1, N_det
call htilde_mu_mat_opt_bi_ortho_tot(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
enddo
@@ -277,7 +278,6 @@ end
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, H_tc_u_0_opt)
converged = .False.
i_it = 0
do while (.not. converged)
@@ -364,6 +364,7 @@ subroutine bi_normalize(u_l, u_r, n, ld, nstates)
!!!! Normalization of right eigenvectors |Phi>
accu = 0.d0
+ ! TODO: dot product lapack
do j = 1, n
accu += u_r(j,i) * u_r(j,i)
enddo
From 89aaf304603d24faec884be10559c1a4f07cd3c3 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 5 Mar 2024 19:18:04 +0100
Subject: [PATCH 040/140] removed stupid print in fci
---
src/cipsi/selection.irp.f | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index 59cfdff8..ae84f84e 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -889,9 +889,9 @@ subroutine fill_buffer_$DOUBLE(i_generator, sp, h1, h2, bannedOrb, banned, fock_
w *= dsqrt(dble(n))
endif
- if(dabs(w).gt.1.d-5)then
- print*,w,buf%mini
- endif
+! if(dabs(w).gt.1.d-5)then
+! print*,w,buf%mini
+! endif
if(w <= buf%mini) then
call add_to_selection_buffer(buf, det, w)
From eaab1b80648bd2b4ec38aa17722a751fccf42ce0 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Thu, 7 Mar 2024 07:34:59 +0100
Subject: [PATCH 041/140] few modif for HHG
---
.../multi_s_dipole_moment.irp.f | 23 ++++++++++++++++
src/utils/constants.include.F | 27 +++++++++++++++++++
2 files changed, 50 insertions(+)
diff --git a/src/mol_properties/multi_s_dipole_moment.irp.f b/src/mol_properties/multi_s_dipole_moment.irp.f
index 913ae2f3..f21e08cd 100644
--- a/src/mol_properties/multi_s_dipole_moment.irp.f
+++ b/src/mol_properties/multi_s_dipole_moment.irp.f
@@ -91,3 +91,26 @@ BEGIN_PROVIDER [double precision, multi_s_dipole_moment, (N_states, N_states)]
enddo
END_PROVIDER
+
+! ---
+
+ BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenvec, (N_states, N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_x_dipole_moment_eigenval, (N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_y_dipole_moment_eigenval, (N_states)]
+&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenval, (N_states)]
+
+ implicit none
+
+ PROVIDE multi_s_x_dipole_moment multi_s_y_dipole_moment multi_s_z_dipole_moment
+
+ call lapack_diag(multi_s_x_dipole_moment_eigenval(1), multi_s_x_dipole_moment_eigenvec(1,1), multi_s_x_dipole_moment(1,1), N_states, N_states)
+ call lapack_diag(multi_s_y_dipole_moment_eigenval(1), multi_s_y_dipole_moment_eigenvec(1,1), multi_s_y_dipole_moment(1,1), N_states, N_states)
+ call lapack_diag(multi_s_z_dipole_moment_eigenval(1), multi_s_z_dipole_moment_eigenvec(1,1), multi_s_z_dipole_moment(1,1), N_states, N_states)
+
+END_PROVIDER
+
+! ---
+
+
diff --git a/src/utils/constants.include.F b/src/utils/constants.include.F
index 422eff95..7b01f888 100644
--- a/src/utils/constants.include.F
+++ b/src/utils/constants.include.F
@@ -18,3 +18,30 @@ double precision, parameter :: c_4_3 = 4.d0/3.d0
double precision, parameter :: c_1_3 = 1.d0/3.d0
double precision, parameter :: sq_op5 = dsqrt(0.5d0)
double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0))
+
+! physical constants and units conversion factors
+double precision, parameter :: k_boltzman_si = 1.38066d-23 ! K k^-1
+double precision, parameter :: k_boltzman_au = 3.1667d-6 ! Hartree k^-1
+double precision, parameter :: k_boltzman_m1_au = 315795.26d0 ! Hartree^-1 k
+double precision, parameter :: bohr_radius_si = 0.529177d-10 ! m
+double precision, parameter :: bohr_radius_cm = 0.529177d-8 ! cm
+double precision, parameter :: bohr_radius_angs = 0.529177d0 ! Angstrom
+double precision, parameter :: electronmass_si = 9.10953d-31 ! Kg
+double precision, parameter :: electronmass_uma = 5.4858d-4 ! uma
+double precision, parameter :: electronvolt_si = 1.6021892d-19 ! J
+double precision, parameter :: uma_si = 1.66057d-27 ! Kg
+double precision, parameter :: debye_si = 3.33564d-30 ! coulomb meter
+double precision, parameter :: debye_au = 0.393427228d0 ! e * Bohr
+double precision, parameter :: angstrom_to_au = 1.889727d0 ! au
+double precision, parameter :: au_to_ohmcmm1 = 46000.0d0 ! (ohm cm)^-1
+double precision, parameter :: au_to_kb = 294210.0d0 ! kbar
+double precision, parameter :: au_to_eV = 27.211652d0
+double precision, parameter :: uma_to_au = 1822.89d0
+double precision, parameter :: au_to_terahertz = 2.4189d-5
+double precision, parameter :: au_to_sec = 2.4189d-17
+double precision, parameter :: au_to_fsec = 2.4189d-2
+double precision, parameter :: Wcm2 = 3.5d16
+double precision, parameter :: amconv = 1.66042d-24/9.1095d-28*0.5d0 ! mass conversion: a.m.u to a.u. (ry)
+double precision, parameter :: uakbar = 147105.d0 ! pressure conversion from ry/(a.u)^3 to k
+
+
From 2ea789bee9f25306b0dd5696238045480d479e30 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 8 Mar 2024 17:25:48 +0100
Subject: [PATCH 042/140] removed STUPID stop in save_tc_natorb
---
.../tc_bi_ortho/save_tc_bi_ortho_nat.irp.f | 3 ++-
plugins/local/tc_bi_ortho/tc_natorb.irp.f | 2 --
plugins/local/tc_scf/routines_rotates.irp.f | 22 +++++++++----------
3 files changed, 13 insertions(+), 14 deletions(-)
diff --git a/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
index 6b3acce6..02e8144f 100644
--- a/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
+++ b/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
@@ -33,7 +33,8 @@ program tc_natorb_bi_ortho
read_wf = .True.
touch read_wf
- call print_energy_and_mos()
+ logical :: good_angles
+ call print_energy_and_mos(good_angles)
call save_tc_natorb()
call print_angles_tc()
!call minimize_tc_orb_angles()
diff --git a/plugins/local/tc_bi_ortho/tc_natorb.irp.f b/plugins/local/tc_bi_ortho/tc_natorb.irp.f
index b8cf5e81..cc24256f 100644
--- a/plugins/local/tc_bi_ortho/tc_natorb.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_natorb.irp.f
@@ -33,7 +33,6 @@
do i = 1, ao_num
write(*, '(100(F16.10,X))') tc_transition_matrix_ao(:,i,1,1)
enddo
- stop
thr_d = 1.d-6
thr_nd = 1.d-6
@@ -52,7 +51,6 @@
! call diag_mat_per_fock_degen( fock_diag, dm_tmp, mo_num, thr_d, thr_nd, thr_deg &
! , natorb_tc_leigvec_mo, natorb_tc_reigvec_mo, natorb_tc_eigval)
! endif
-
call non_hrmt_bieig(mo_num, dm_tmp, thresh_biorthog_diag, thresh_biorthog_nondiag &
, natorb_tc_leigvec_mo, natorb_tc_reigvec_mo &
, mo_num, natorb_tc_eigval )
diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f
index c42e846e..fbfc9beb 100644
--- a/plugins/local/tc_scf/routines_rotates.irp.f
+++ b/plugins/local/tc_scf/routines_rotates.irp.f
@@ -439,18 +439,18 @@ subroutine print_energy_and_mos(good_angles)
if(max_angle_left_right .lt. thresh_lr_angle) then
print *, ' Maximum angle BELOW 45 degrees, everthing is OK !'
good_angles = .true.
- else if(max_angle_left_right .gt. thresh_lr_angle .and. max_angle_left_right .lt. 75.d0) then
- print *, ' Maximum angle between thresh_lr_angle and 75 degrees, this is not the best for TC-CI calculations ...'
- good_angles = .false.
- else if(max_angle_left_right .gt. 75.d0) then
- print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...'
- good_angles = .false.
+! else if(max_angle_left_right .gt. thresh_lr_angle .and. max_angle_left_right .lt. 75.d0) then
+! print *, ' Maximum angle between thresh_lr_angle and 75 degrees, this is not the best for TC-CI calculations ...'
+! good_angles = .false.
+! else if(max_angle_left_right .gt. 75.d0) then
+! print *, ' Maximum angle between ABOVE 75 degrees, YOU WILL CERTAINLY FIND TROUBLES IN TC-CI calculations ...'
+! good_angles = .false.
endif
-
- print *, ' Diag Fock elem, product of left/right norm, angle left/right '
- do i = 1, mo_num
- write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i)
- enddo
+!
+! print *, ' Diag Fock elem, product of left/right norm, angle left/right '
+! do i = 1, mo_num
+! write(*, '(I3,X,100(F16.10,X))') i, Fock_matrix_tc_mo_tot(i,i), overlap_mo_l(i,i)*overlap_mo_r(i,i), angle_left_right(i)
+! enddo
end
From 3f861a41b5438d1722fa003da233642c79d96a47 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 8 Mar 2024 17:27:18 +0100
Subject: [PATCH 043/140] added the thresh_de_tc_angles keyword in minimize tc
angles
---
bin/zcat | 23 ---------------------
plugins/local/tc_keywords/EZFIO.cfg | 5 +++++
plugins/local/tc_scf/routines_rotates.irp.f | 1 +
scripts/PYSCF_EOMCC.py | 1 +
4 files changed, 7 insertions(+), 23 deletions(-)
delete mode 100755 bin/zcat
create mode 120000 scripts/PYSCF_EOMCC.py
diff --git a/bin/zcat b/bin/zcat
deleted file mode 100755
index 7ccecf07..00000000
--- a/bin/zcat
+++ /dev/null
@@ -1,23 +0,0 @@
-#!/bin/bash
-
-# On Darwin: try gzcat if available, otherwise use Python
-
-if [[ $(uname -s) = Darwin ]] ; then
- which gzcat &> /dev/null
- if [[ $? -eq 0 ]] ; then
- exec gzcat $@
- else
-
- exec python3 << EOF
-import sys
-import gzip
-with gzip.open("$1", "rt") as f:
- print(f.read())
-EOF
- fi
-else
- SCRIPTPATH="$( cd -- "$(dirname "$0")" >/dev/null 2>&1 ; pwd -P )"
- command=$(which -a zcat | grep -v "$SCRIPTPATH/" | head -1)
- exec $command $@
-fi
-
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 93ff790f..68fe9c94 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -280,3 +280,8 @@ doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic
interface: ezfio,ocaml,provider
default: semi-analytic
+[thresh_de_tc_angles]
+type: Threshold
+doc: Thresholds on delta E for changing angles between orbitals
+interface: ezfio,provider,ocaml
+default: 1.e-03
diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f
index c42e846e..92abfa44 100644
--- a/plugins/local/tc_scf/routines_rotates.irp.f
+++ b/plugins/local/tc_scf/routines_rotates.irp.f
@@ -301,6 +301,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
! check if TC energy has changed
E_new = TC_HF_energy
+ E_thr = thresh_de_tc_angles
if(dabs(E_new - E_old) .gt. E_thr) then
mo_r_coef = mo_r_coef_old
mo_l_coef = mo_l_coef_old
diff --git a/scripts/PYSCF_EOMCC.py b/scripts/PYSCF_EOMCC.py
new file mode 120000
index 00000000..8ad341da
--- /dev/null
+++ b/scripts/PYSCF_EOMCC.py
@@ -0,0 +1 @@
+/home_lct/eginer/qp2/plugins/qp_plugins_lct/dev/fcidump_for_vbarb/PYSCF_EOMCC.py
\ No newline at end of file
From d405aea95785060f7550be7901c90d133b287a65 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Mon, 11 Mar 2024 10:21:59 +0100
Subject: [PATCH 044/140] few mom opt
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 99 +++++++++++++++----
.../local/non_h_ints_mu/total_tc_int.irp.f | 2 +
src/tools/print_detweights.irp.f | 66 +++++++++++++
3 files changed, 148 insertions(+), 19 deletions(-)
create mode 100644 src/tools/print_detweights.irp.f
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 5e6a24e9..bf5cc36f 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -40,38 +40,95 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
END_DOC
implicit none
- integer :: i, j, k, l, m, n, p, q
+ integer :: i, j, k, l, m, n, p, q, s, r
+ double precision :: t1, t2
double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
+ double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:)
+
+ print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...'
+ call wall_time(t1)
+ call print_memory_usage()
PROVIDE mo_r_coef mo_l_coef
+ PROVIDe ao_two_e_tc_tot
- allocate(a2(ao_num,ao_num,ao_num,mo_num))
+ if(ao_to_mo_tc_n3) then
- call dgemm( 'T', 'N', ao_num*ao_num*ao_num, mo_num, ao_num, 1.d0 &
- , ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
- , 0.d0 , a2(1,1,1,1), ao_num*ao_num*ao_num)
+ print*, ' memory scale of TC ao -> mo: O(N3) '
- allocate(a1(ao_num,ao_num,mo_num,mo_num))
+ allocate(a_jkp(ao_num,ao_num,mo_num))
+ allocate(a_kpq(ao_num,mo_num,mo_num))
+ allocate(a_pqr(mo_num,mo_num,mo_num))
- call dgemm( 'T', 'N', ao_num*ao_num*mo_num, mo_num, ao_num, 1.d0 &
- , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
- , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
+ do s = 1, mo_num
+ mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0
- deallocate(a2)
- allocate(a2(ao_num,mo_num,mo_num,mo_num))
+ do l = 1, ao_num
- call dgemm( 'T', 'N', ao_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
- , a1(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
- , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
+ call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
+ , ao_two_e_tc_tot(1,1,1,l), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a_jkp(1,1,1), ao_num*ao_num)
+
+ call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, a_kpq(1,1,1), ao_num*mo_num)
+
+ call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a_pqr(1,1,1), mo_num*mo_num)
- deallocate(a1)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(p, q, r) &
+ !$OMP SHARED(s, l, mo_num, mo_bi_ortho_tc_two_e_chemist, mo_r_coef, a_pqr)
+ !$OMP DO COLLAPSE(2)
+ do p = 1, mo_num
+ do q = 1, mo_num
+ do r = 1, mo_num
+ mo_bi_ortho_tc_two_e_chemist(p,q,r,s) = mo_bi_ortho_tc_two_e_chemist(p,q,r,s) + mo_r_coef(l,s) * a_pqr(p,q,r)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
- call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
- , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
- , 0.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num)
+ enddo ! l
+ enddo ! s
- deallocate(a2)
+ deallocate(a_jkp, a_kpq, a_pqr)
+ else
+
+ print*, ' memory scale of TC ao -> mo: O(N4) '
+
+ 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 &
+ , ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a2(1,1,1,1), ao_num*ao_num*ao_num)
+
+ 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(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, a1(1,1,1,1), ao_num*ao_num*mo_num)
+
+ 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(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 0.d0, a2(1,1,1,1), ao_num*mo_num*mo_num)
+
+ deallocate(a1)
+
+ call dgemm( 'T', 'N', mo_num*mo_num*mo_num, mo_num, ao_num, 1.d0 &
+ , a2(1,1,1,1), ao_num, mo_r_coef(1,1), ao_num &
+ , 0.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,1), mo_num*mo_num*mo_num)
+
+ deallocate(a2)
+
+ endif
!allocate(a1(mo_num,ao_num,ao_num,ao_num))
!a1 = 0.d0
@@ -135,6 +192,10 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
!enddo
!deallocate(a1)
+ call wall_time(t2)
+ print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_chemist (min)', (t2-t1)/60.d0
+ call print_memory_usage()
+
END_PROVIDER
! ---
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index 9d3cf565..ba078d9b 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -201,6 +201,8 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
!$OMP END DO
!$OMP END PARALLEL
+ call clear_ao_map()
+
if(tc_integ_type .eq. "numeric") then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
endif
diff --git a/src/tools/print_detweights.irp.f b/src/tools/print_detweights.irp.f
new file mode 100644
index 00000000..d5b0f2c9
--- /dev/null
+++ b/src/tools/print_detweights.irp.f
@@ -0,0 +1,66 @@
+program print_detweights
+
+ implicit none
+
+ read_wf = .True.
+ touch read_wf
+
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+ integer :: i
+ integer :: degree
+ integer :: ios
+ integer, allocatable :: deg(:), ii(:), deg_sorted(:)
+ double precision, allocatable :: c(:)
+
+ PROVIDE N_int
+ PROVIDE N_det
+ PROVIDE psi_det
+ PROVIDe psi_coef
+
+ allocate(deg(N_det), ii(N_det), deg_sorted(N_det), c(N_det))
+
+ do i = 1, N_det
+
+ call debug_det(psi_det(1,1,i), N_int)
+ call get_excitation_degree(psi_det(1,1,i), psi_det(1,1,1), degree, N_int)
+
+ ii (i) = i
+ deg(i) = degree
+ c (i) = dabs(psi_coef(i,1))
+ enddo
+
+ call dsort(c, ii, N_det)
+
+ do i = 1, N_det
+ deg_sorted(i) = deg(ii(i))
+ enddo
+
+ print *, ' saving psi'
+
+ ! Writing output in binary format
+ open(unit=10, file="coef.bin", status="replace", action="write", iostat=ios, form="unformatted")
+
+ if(ios /= 0) then
+ print *, ' Error opening file!'
+ stop
+ endif
+
+ write(10) N_det
+ write(10) deg_sorted
+ write(10) c
+
+ close(10)
+
+ deallocate(deg, ii, deg_sorted, c)
+
+end
+
+
From 9175fb21c9dcbe931f89d96cf1297221693d5fde Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 14:05:38 +0100
Subject: [PATCH 045/140] modifs in json and diagonalize_ci for fci tc bi
---
.../local/cipsi_tc_bi_ortho/selection.irp.f | 7 +-
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 1 -
.../cipsi_tc_bi_ortho/write_cipsi_json.irp.f | 29 +++-
plugins/local/fci_tc_bi/diagonalize_ci.irp.f | 124 ++++++------------
.../local/tc_bi_ortho/tc_h_eigvectors.irp.f | 18 +--
5 files changed, 82 insertions(+), 97 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 06cf848b..a01d4131 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -980,8 +980,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
psi_h_alpha = mat_l(istate, p1, p2)
pt2_data % overlap(:,istate) = pt2_data % overlap(:,istate) + coef(:) * coef(istate)
- pt2_data % variance(istate) = pt2_data % variance(istate) + dabs(e_pert(istate))
- pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
+ if(e_pert(istate).gt.0.d0)then! accumulate the positive part of the pt2
+ pt2_data % variance(istate) = pt2_data % variance(istate) + e_pert(istate)
+ else ! accumulate the negative part of the pt2
+ pt2_data % pt2(istate) = pt2_data % pt2(istate) + e_pert(istate)
+ endif
select case (weight_selection)
case(5)
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 66d82964..2a7273d3 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -57,7 +57,6 @@ subroutine run_stochastic_cipsi
! endif
print_pt2 = .False.
call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
-! call routine_save_right
! if (N_det > N_det_max) then
diff --git a/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
index 98a402a2..f8c95d38 100644
--- a/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/write_cipsi_json.irp.f
@@ -9,6 +9,8 @@ subroutine write_cipsi_json(pt2_data, pt2_data_err)
call lock_io
character*(64), allocatable :: fmtk(:)
+ double precision:: pt2_minus,pt2_plus,pt2_tot, pt2_abs
+ double precision :: error_pt2_minus, error_pt2_plus, error_pt2_tot, error_pt2_abs
integer :: N_states_p, N_iter_p
N_states_p = min(N_states,N_det)
N_iter_p = min(N_iter,8)
@@ -26,15 +28,34 @@ subroutine write_cipsi_json(pt2_data, pt2_data_err)
endif
write(json_unit, json_array_open_fmt) 'states'
do k=1,N_states_p
+ pt2_plus = pt2_data % variance(k)
+ pt2_minus = pt2_data % pt2(k)
+ pt2_abs = pt2_plus - pt2_minus
+ pt2_tot = pt2_plus + pt2_minus
+ error_pt2_minus = pt2_data_err % pt2(k)
+ error_pt2_plus = pt2_data_err % variance(k)
+ error_pt2_tot = dsqrt(error_pt2_minus**2+error_pt2_plus**2)
+ error_pt2_abs = error_pt2_tot ! same variance because independent variables
write(json_unit, json_dict_uopen_fmt)
write(json_unit, json_real_fmt) 'energy', psi_energy_with_nucl_rep(k)
write(json_unit, json_real_fmt) 's2', psi_s2(k)
- write(json_unit, json_real_fmt) 'pt2', pt2_data % pt2(k)
- write(json_unit, json_real_fmt) 'pt2_err', pt2_data_err % pt2(k)
+
+ write(json_unit, json_real_fmt) 'pt2', pt2_tot
+ write(json_unit, json_real_fmt) 'pt2_err', error_pt2_tot
+
+ write(json_unit, json_real_fmt) 'pt2_minus', pt2_minus
+ write(json_unit, json_real_fmt) 'pt2_minus_err', error_pt2_minus
+
+ write(json_unit, json_real_fmt) 'pt2_abs', pt2_abs
+ write(json_unit, json_real_fmt) 'pt2_abs_err', error_pt2_abs
+
+ write(json_unit, json_real_fmt) 'pt2_plus', pt2_plus
+ write(json_unit, json_real_fmt) 'pt2_plus_err', error_pt2_plus
+
write(json_unit, json_real_fmt) 'rpt2', pt2_data % rpt2(k)
write(json_unit, json_real_fmt) 'rpt2_err', pt2_data_err % rpt2(k)
- write(json_unit, json_real_fmt) 'variance', pt2_data % variance(k)
- write(json_unit, json_real_fmt) 'variance_err', pt2_data_err % variance(k)
+! write(json_unit, json_real_fmt) 'variance', pt2_data % variance(k)
+! write(json_unit, json_real_fmt) 'variance_err', pt2_data_err % variance(k)
write(json_unit, json_array_open_fmt) 'ex_energy'
do i=2,N_iter_p
write(json_unit, fmtk(i)) extrapolated_energy(i,k)
diff --git a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
index 6c8f3431..a9ded70c 100644
--- a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
+++ b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
@@ -11,49 +11,61 @@ 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
+ double precision, intent(inout) :: E_tc(N_states), norm(N_states) ! E and norm from previous wave function
type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function
logical, intent(in) :: print_pt2
- integer :: i, j
- double precision :: pt2_tmp, pt1_norm, rpt2_tmp, abs_pt2
+ integer :: i, j,k
+ double precision:: pt2_minus,pt2_plus,pt2_tot, pt2_abs,pt1_norm,rpt2_tot
+ double precision :: error_pt2_minus, error_pt2_plus, error_pt2_tot, error_pt2_abs
PROVIDE mo_l_coef mo_r_coef
- 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
+ do k = 1, N_states
+ print*,'************'
+ print*,'State ',k
+ pt2_plus = pt2_data % variance(k)
+ pt2_minus = pt2_data % pt2(k)
+ pt2_abs = pt2_plus - pt2_minus
+ pt2_tot = pt2_plus + pt2_minus
+! error_pt2_minus = pt2_data_err % pt2(k)
+! error_pt2_plus = pt2_data_err % variance(k)
+! error_pt2_tot = dsqrt(error_pt2_minus**2+error_pt2_plus**2)
+! error_pt2_abs = error_pt2_tot ! same variance because independent variables
+
+ pt1_norm = pt2_data % overlap(k,k)
+ rpt2_tot = pt2_tot / (1.d0 + pt1_norm)
+
+
+ print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth(k)
+ print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(k)
+ 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_tot
+ print*,'rPT2 = ',rpt2_tot
+ print*,'|PT2| = ',pt2_abs
+ print*,'Positive PT2 = ',pt2_plus
+ print*,'Negative PT2 = ',pt2_minus
+ print*,'E(before) + PT2 = ',E_tc + pt2_tot/norm
+ print*,'E(before) +rPT2 = ',E_tc + rpt2_tot/norm
+ write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tot/norm,E_tc + rpt2_tot/norm,pt2_minus, pt2_plus
+ print*,'*****'
+ endif
+ E_tc(k) = eigval_right_tc_bi_orth(k)
+ norm(k) = norm_ground_left_right_bi_orth(k)
+ enddo
psi_energy(1:N_states) = eigval_right_tc_bi_orth(1:N_states) - nuclear_repulsion
psi_s2(1:N_states) = s2_eigvec_tc_bi_orth(1:N_states)
- 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
@@ -71,53 +83,3 @@ end
! ---
-subroutine print_CI_dressed(ndet, E_tc, norm, pt2_data, print_pt2)
-
- BEGIN_DOC
- ! Replace the coefficients of the CI states by the coefficients of the
- ! eigenstates of the CI matrix
- END_DOC
-
- 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
- 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/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
index 75f3dfbe..c90c84c5 100644
--- a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
@@ -45,12 +45,12 @@ end
! ---
- 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, s2_eigvec_tc_bi_orth , (N_states) ]
-&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth ]
+ 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, s2_eigvec_tc_bi_orth , (N_states) ]
+&BEGIN_PROVIDER [double precision, norm_ground_left_right_bi_orth , (N_states) ]
BEGIN_DOC
! eigenvalues, right and left eigenvectors of the transcorrelated Hamiltonian on the BI-ORTHO basis
@@ -309,13 +309,13 @@ end
deallocate(Stmp)
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 i = 1, N_states
- norm_ground_left_right_bi_orth = 0.d0
do j = 1, N_det
- norm_ground_left_right_bi_orth += leigvec_tc_bi_orth(j,i) * reigvec_tc_bi_orth(j,i)
+ norm_ground_left_right_bi_orth(i) += leigvec_tc_bi_orth(j,i) * reigvec_tc_bi_orth(j,i)
enddo
print*,' state ', i
- print*,' norm l/r = ', norm_ground_left_right_bi_orth
+ print*,' norm l/r = ', norm_ground_left_right_bi_orth(i)
print*,' = ', s2_eigvec_tc_bi_orth(i)
enddo
From 6e35f8f8f8735bd4a898fabbc6bf552f382e517a Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 15:30:52 +0100
Subject: [PATCH 046/140] fixed n_states > 1 for TC
---
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 2 +-
plugins/local/fci_tc_bi/diagonalize_ci.irp.f | 80 ++++++-----
.../local/tc_bi_ortho/tc_h_eigvectors.irp.f | 27 ++--
src/iterations/summary_tc.irp.f | 125 ++++++++++++++++++
4 files changed, 181 insertions(+), 53 deletions(-)
create mode 100644 src/iterations/summary_tc.irp.f
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 2a7273d3..59ea3f11 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -98,7 +98,7 @@ subroutine run_stochastic_cipsi
call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
- call print_summary(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
+ call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
call save_energy(psi_energy_with_nucl_rep, pt2_data % pt2)
diff --git a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
index a9ded70c..a5242b87 100644
--- a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
+++ b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
@@ -20,48 +20,44 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
PROVIDE mo_l_coef mo_r_coef
- print*,'*****'
- print*,'New wave function information'
- print*,'N_det tc = ',N_det
- do k = 1, N_states
- print*,'************'
- print*,'State ',k
- pt2_plus = pt2_data % variance(k)
- pt2_minus = pt2_data % pt2(k)
- pt2_abs = pt2_plus - pt2_minus
- pt2_tot = pt2_plus + pt2_minus
-! error_pt2_minus = pt2_data_err % pt2(k)
-! error_pt2_plus = pt2_data_err % variance(k)
-! error_pt2_tot = dsqrt(error_pt2_minus**2+error_pt2_plus**2)
-! error_pt2_abs = error_pt2_tot ! same variance because independent variables
-
- pt1_norm = pt2_data % overlap(k,k)
- rpt2_tot = pt2_tot / (1.d0 + pt1_norm)
-
-
- print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth(k)
- print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(k)
- 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_tot
- print*,'rPT2 = ',rpt2_tot
- print*,'|PT2| = ',pt2_abs
- print*,'Positive PT2 = ',pt2_plus
- print*,'Negative PT2 = ',pt2_minus
- print*,'E(before) + PT2 = ',E_tc + pt2_tot/norm
- print*,'E(before) +rPT2 = ',E_tc + rpt2_tot/norm
- write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tot/norm,E_tc + rpt2_tot/norm,pt2_minus, pt2_plus
- print*,'*****'
- endif
- E_tc(k) = eigval_right_tc_bi_orth(k)
- norm(k) = norm_ground_left_right_bi_orth(k)
- enddo
+! print*,'*****'
+! print*,'New wave function information'
+! print*,'N_det tc = ',N_det
+! do k = 1, N_states
+! print*,'************'
+! print*,'State ',k
+! pt2_plus = pt2_data % variance(k)
+! pt2_minus = pt2_data % pt2(k)
+! pt2_abs = pt2_plus - pt2_minus
+! pt2_tot = pt2_plus + pt2_minus
+!
+! pt1_norm = pt2_data % overlap(k,k)
+! rpt2_tot = pt2_tot / (1.d0 + pt1_norm)
+!
+!
+! print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth(k)
+! print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(k)
+! 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_tot
+! print*,'rPT2 = ',rpt2_tot
+! print*,'|PT2| = ',pt2_abs
+! print*,'Positive PT2 = ',pt2_plus
+! print*,'Negative PT2 = ',pt2_minus
+! print*,'E(before) + PT2 = ',E_tc + pt2_tot/norm
+! print*,'E(before) +rPT2 = ',E_tc + rpt2_tot/norm
+! write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tot/norm,E_tc + rpt2_tot/norm,pt2_minus, pt2_plus
+! print*,'*****'
+! endif
+! E_tc(k) = eigval_right_tc_bi_orth(k)
+! norm(k) = norm_ground_left_right_bi_orth(k)
+! enddo
psi_energy(1:N_states) = eigval_right_tc_bi_orth(1:N_states) - nuclear_repulsion
psi_s2(1:N_states) = s2_eigvec_tc_bi_orth(1:N_states)
diff --git a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
index c90c84c5..6bf3d99e 100644
--- a/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_h_eigvectors.irp.f
@@ -86,17 +86,20 @@ end
endif
call non_hrmt_real_diag(N_det, H_prime, leigvec_tc_bi_orth_tmp, reigvec_tc_bi_orth_tmp, n_real_tc_bi_orth_eigval_right, eigval_right_tmp)
+ if(N_states.gt.1)then
+ print*,'n_real_tc_bi_orth_eigval_right = ',n_real_tc_bi_orth_eigval_right
+ endif
! do i = 1, N_det
! call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp(1,i),reigvec_tc_bi_orth_tmp(1,i),1,N_det,expect_e(i), s2_values_tmp(i))
! enddo
call get_H_tc_s2_l0_r0(leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,N_det,N_det,expect_e, s2_values_tmp)
+
allocate(index_good_state_array(N_det),good_state_array(N_det))
i_state = 0
good_state_array = .False.
if(s2_eig) then
-
if(only_expected_s2) then
do j = 1, N_det
! Select at least n_states states with S^2 values closed to "expected_s2"
@@ -116,6 +119,9 @@ end
good_state_array(j) = .True.
enddo
endif
+ if(N_states.gt.1)then
+ print*,'i_state = ',i_state
+ endif
if(i_state .ne. 0) then
! Fill the first "i_state" states that have a correct S^2 value
@@ -338,11 +344,6 @@ end
TOUCH psi_r_coef_bi_ortho
call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(buffer)
deallocate(buffer)
-! print*,'After diag'
-! do i = 1, N_det! old version
-! print*,'i',i,psi_l_coef_bi_ortho(i,1),psi_r_coef_bi_ortho(i,1)
-! call debug_det(psi_det(1,1,i),N_int)
-! enddo
END_PROVIDER
@@ -357,23 +358,29 @@ subroutine bi_normalize(u_l, u_r, n, ld, nstates)
implicit none
integer, intent(in) :: n, ld, nstates
double precision, intent(inout) :: u_l(ld,nstates), u_r(ld,nstates)
- integer :: i, j
- double precision :: accu, tmp
+ integer :: i, j,j_loc
+ double precision :: accu, tmp, maxval_tmp
do i = 1, nstates
!!!! Normalization of right eigenvectors |Phi>
accu = 0.d0
! TODO: dot product lapack
+ maxval_tmp = 0.d0
do j = 1, n
accu += u_r(j,i) * u_r(j,i)
+ if(dabs(u_r(j,i)).gt.maxval_tmp)then
+ maxval_tmp = dabs(u_r(j,i))
+ j_loc = j
+ endif
enddo
accu = 1.d0/dsqrt(accu)
print*,'accu_r = ',accu
+ print*,'j_loc = ',j_loc
do j = 1, n
u_r(j,i) *= accu
enddo
- tmp = u_r(1,i) / dabs(u_r(1,i))
+ tmp = u_r(j_loc,i) / dabs(u_r(j_loc,i))
do j = 1, n
u_r(j,i) *= tmp
enddo
@@ -390,7 +397,7 @@ subroutine bi_normalize(u_l, u_r, n, ld, nstates)
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))
+ tmp = (u_l(j_loc,i) * u_r(j_loc,i) )/dabs(u_l(j_loc,i) * u_r(j_loc,i))
do j = 1, n
u_l(j,i) *= accu * tmp
u_r(j,i) *= accu
diff --git a/src/iterations/summary_tc.irp.f b/src/iterations/summary_tc.irp.f
new file mode 100644
index 00000000..00c2ba38
--- /dev/null
+++ b/src/iterations/summary_tc.irp.f
@@ -0,0 +1,125 @@
+subroutine print_summary_tc(e_,pt2_data,pt2_data_err,n_det_,n_configuration_,n_st,s2_)
+ use selection_types
+ implicit none
+ BEGIN_DOC
+! Print the extrapolated energy in the output
+ END_DOC
+
+ integer, intent(in) :: n_det_, n_configuration_, n_st
+ double precision, intent(in) :: e_(n_st), s2_(n_st)
+ type(pt2_type) , intent(in) :: pt2_data, pt2_data_err
+ integer :: i, k
+ integer :: N_states_p
+ character*(9) :: pt2_string
+ character*(512) :: fmt
+ double precision, allocatable :: pt2_minus(:),pt2_plus(:),pt2_tot(:), pt2_abs(:),pt1_norm(:),rpt2_tot(:)
+ double precision, allocatable :: error_pt2_minus(:), error_pt2_plus(:), error_pt2_tot(:), error_pt2_abs(:)
+
+ if (do_pt2) then
+ pt2_string = ' '
+ else
+ pt2_string = '(approx)'
+ endif
+
+ N_states_p = min(N_det_,n_st)
+
+ allocate(pt2_minus(N_states_p),pt2_plus(N_states_p),pt2_tot(N_states_p), pt2_abs(N_states_p),pt1_norm(N_states_p),rpt2_tot(N_states_p))
+ allocate(error_pt2_minus(N_states_p), error_pt2_plus(N_states_p), error_pt2_tot(N_states_p), error_pt2_abs(N_states_p))
+ do k = 1, N_states_p
+ pt2_plus(k) = pt2_data % variance(k)
+ pt2_minus(k) = pt2_data % pt2(k)
+ pt2_abs(k) = pt2_plus(k) - pt2_minus(k)
+ pt2_tot(k) = pt2_plus(k) + pt2_minus(k)
+ pt1_norm(k) = pt2_data % overlap(k,k)
+ rpt2_tot(k) = pt2_tot(k) / (1.d0 + pt1_norm(k))
+ error_pt2_minus(k) = pt2_data_err % pt2(k)
+ error_pt2_plus(k) = pt2_data_err % variance(k)
+ error_pt2_tot(k) = dsqrt(error_pt2_minus(k)**2+error_pt2_plus(k)**2)
+ error_pt2_abs(k) = error_pt2_tot(k) ! same variance because independent variables
+ enddo
+ k=1
+ write(*,'(A40,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=',n_det_,e_(k),e_(k) + pt2_tot(k),e_(k) + rpt2_tot(k),pt2_minus(k), pt2_plus(k),pt2_abs(k)
+
+ print *, ''
+ print '(A,I12)', 'Summary at N_det = ', N_det_
+ print '(A)', '-----------------------------------'
+ print *, ''
+
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ write(fmt,*) '(13X,', N_states_p, '(6X,A7,1X,I6,10X))'
+ write(*,fmt) ('State',k, k=1,N_states_p)
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ write(fmt,*) '(A13,', N_states_p, '(1X,F14.8,15X))'
+ 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
+ endif
+ write(fmt,*) '(A13,', 2*N_states_p, '(1X,F14.8))'
+ write(*,fmt) '# PT2 '//pt2_string, (pt2_tot(k), error_pt2_tot(k), k=1,N_states_p)
+ write(*,fmt) '# rPT2'//pt2_string, (rpt2_tot(k), error_pt2_tot(k), k=1,N_states_p)
+ write(*,'(A)') '#'
+ write(*,fmt) '# E+PT2 ', (e_(k)+pt2_tot(k) ,error_pt2_tot(k), k=1,N_states_p)
+ write(*,fmt) '# E+rPT2 ', (e_(k)+rpt2_tot(k),error_pt2_tot(k), k=1,N_states_p)
+ if (N_states_p > 1) then
+ write(*,fmt) '# Excit. (au)', ( (e_(k)+pt2_tot(k)-e_(1)-pt2_tot(1)), &
+ dsqrt(error_pt2_tot(k)*error_pt2_tot(k)+error_pt2_tot(1)*error_pt2_tot(1)), k=1,N_states_p)
+ write(*,fmt) '# Excit. (eV)', ( (e_(k)+pt2_tot(k)-e_(1)-pt2_tot(1))*27.211396641308d0, &
+ dsqrt(error_pt2_tot(k)*error_pt2_tot(k)+error_pt2_tot(1)*error_pt2_tot(1))*27.211396641308d0, k=1,N_states_p)
+ endif
+ write(fmt,*) '(''# ============'',', N_states_p, '(1X,''=============================''))'
+ write(*,fmt)
+ print *, ''
+
+ print *, 'N_det = ', N_det_
+ print *, 'N_states = ', n_st
+ if (s2_eig) then
+ print *, 'N_cfg = ', N_configuration_
+ if (only_expected_s2) then
+ print *, 'N_csf = ', N_csf
+ endif
+ endif
+ print *, ''
+
+ do k=1, N_states_p
+ print*,'* State ',k
+ print *, '< S^2 > = ', s2_(k)
+ print *, 'E = ', e_(k)
+ print *, 'PT norm = ', pt1_norm(k)
+ print *, 'PT2 = ', pt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'rPT2 = ', rpt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'E+PT2 '//pt2_string//' = ', e_(k)+pt2_tot(k) , ' +/- ', error_pt2_tot(k)
+ print *, 'E+rPT2'//pt2_string//' = ', e_(k)+rpt2_tot(k), ' +/- ', error_pt2_tot(k)
+ print *, 'Positive PT2 = ',pt2_plus(k),' +/- ',error_pt2_plus(k)
+ print *, 'Negative PT2 = ',pt2_minus(k),' +/- ',error_pt2_minus(k)
+ print *, 'Abs PT2 = ',pt2_abs(k), ' +/- ',error_pt2_abs(k)
+ print *, ''
+ enddo
+
+ print *, '-----'
+ if(n_st.gt.1)then
+ 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
+ enddo
+ print *, '-----'
+ print*, 'Variational + perturbative Energy difference (au | eV)'
+ do i=2, N_states_p
+ print*,'Delta E = ', (e_(i)+ pt2_tot(i) - (e_(1) + pt2_tot(1))), &
+ (e_(i)+ pt2_tot(i) - (e_(1) + pt2_tot(1))) * 27.211396641308d0
+ enddo
+ print *, '-----'
+ print*, 'Variational + renormalized perturbative Energy difference (au | eV)'
+ do i=2, N_states_p
+ print*,'Delta E = ', (e_(i)+ rpt2_tot(i) - (e_(1) + rpt2_tot(1))), &
+ (e_(i)+ rpt2_tot(i) - (e_(1) + rpt2_tot(1))) * 27.211396641308d0
+ enddo
+ endif
+
+! call print_energy_components()
+
+end subroutine
+
From 0ef067337d9cffd2fba9b1bc29afe071c696f883 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 16:37:16 +0100
Subject: [PATCH 047/140] Introducing cipsi_utils for CIPSI and TC-CIPSI
---
plugins/local/cipsi_tc_bi_ortho/NEED | 1 +
plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f | 2 +-
.../pt2_stoch_routines.irp.f | 869 +---------------
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 2 +-
plugins/local/fci_tc_bi/NEED | 1 +
plugins/local/fci_tc_bi/selectors.irp.f | 2 +-
src/cipsi/NEED | 1 +
src/cipsi/pt2_stoch_routines.irp.f | 924 +-----------------
src/generators_full_tc/README.rst | 9 +
.../generators_full_tc}/generators.irp.f | 48 +-
10 files changed, 56 insertions(+), 1803 deletions(-)
create mode 100644 src/generators_full_tc/README.rst
rename {plugins/local/fci_tc_bi => src/generators_full_tc}/generators.irp.f (51%)
diff --git a/plugins/local/cipsi_tc_bi_ortho/NEED b/plugins/local/cipsi_tc_bi_ortho/NEED
index 8f05be69..d329326c 100644
--- a/plugins/local/cipsi_tc_bi_ortho/NEED
+++ b/plugins/local/cipsi_tc_bi_ortho/NEED
@@ -1,3 +1,4 @@
+cipsi_utils
json
mpi
perturbation
diff --git a/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
index fb907cb3..65e0790a 100644
--- a/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/cipsi.irp.f
@@ -65,7 +65,7 @@ subroutine run_cipsi
if (N_det > N_det_max) then
psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
- psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
+ psi_coef(1:N_det,1:N_states) = psi_coef_sorted_gen(1:N_det,1:N_states)
N_det = N_det_max
soft_touch N_det psi_det psi_coef
if (s2_eig) then
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
index 284b2bc8..6e1a6748 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2_stoch_routines.irp.f
@@ -1,868 +1,3 @@
-BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
- implicit none
- BEGIN_DOC
- ! State for stochatsic PT2
- END_DOC
- pt2_stoch_istate = 1
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
-&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
- implicit none
- logical, external :: testTeethBuilding
- integer :: i,j
- pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
- pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
- call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
-
- pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
- do i=1,pt2_n_0(1+pt2_N_teeth/4)
- pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
- pt2_F(i) = pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
- pt2_F(i) = 1
- enddo
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_N_teeth ]
-&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
- implicit none
- logical, external :: testTeethBuilding
-
- if(N_det_generators < 500) then
- pt2_minDetInFirstTeeth = 1
- pt2_N_teeth = 1
- else
- pt2_minDetInFirstTeeth = min(5, N_det_generators)
- do pt2_N_teeth=100,2,-1
- if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
- end do
- end if
- call write_int(6,pt2_N_teeth,'Number of comb teeth')
-END_PROVIDER
-
-
-logical function testTeethBuilding(minF, N)
- implicit none
- integer, intent(in) :: minF, N
- integer :: n0, i
- double precision :: u0, Wt, r
-
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- integer, external :: dress_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate) * &
- psi_coef_sorted_tc_gen(i,pt2_stoch_istate)
- norm2 = norm2 + tilde_w(i)
- enddo
-
- f = 1.d0/norm2
- tilde_w(:) = tilde_w(:) * f
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
- deallocate(tilde_w)
-
- n0 = 0
- testTeethBuilding = .false.
- double precision :: f
- integer :: minFN
- minFN = N_det_generators - minF * N
- f = 1.d0/dble(N)
- do
- u0 = tilde_cW(n0)
- r = tilde_cW(n0 + minF)
- Wt = (1d0 - u0) * f
- if (dabs(Wt) <= 1.d-3) then
- exit
- endif
- if(Wt >= r - u0) then
- testTeethBuilding = .true.
- exit
- end if
- n0 += 1
- if(n0 > minFN) then
- exit
- end if
- end do
- deallocate(tilde_cW)
-
-end function
-
-
-
-subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
- use f77_zmq
- use selection_types
-
- implicit none
-
- 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
-!
- integer :: i, N
-
- double precision :: state_average_weight_save(N_states), w(N_states,4)
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- type(selection_buffer) :: b
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc psi_det_sorted_tc
- PROVIDE psi_det_hii 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
-
- if (h0_type == 'CFG') then
- PROVIDE psi_configuration_hii det_to_configuration
- endif
-
- if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
- print*,'ZMQ_selection'
- call ZMQ_selection(N_in, pt2_data)
- else
- print*,'else ZMQ_selection'
-
- N = max(N_in,1) * N_states
- state_average_weight_save(:) = state_average_weight(:)
- if (int(N,8)*2_8 > huge(1)) then
- print *, irp_here, ': integer too large'
- stop -1
- endif
- call create_selection_buffer(N, N*2, b)
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- do pt2_stoch_istate=1,N_states
- state_average_weight(:) = 0.d0
- state_average_weight(pt2_stoch_istate) = 1.d0
- TOUCH state_average_weight pt2_stoch_istate selection_weight
-
- PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
- PROVIDE pt2_u pt2_J pt2_R
- call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
- integer, external :: zmq_put_ivector
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
- stop 'Unable to put pt2_stoch_istate on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
-
-
- integer, external :: add_task_to_taskserver
- character(300000) :: task
-
- integer :: j,k,ipos,ifirst
- ifirst=0
-
- ipos=0
- do i=1,N_det_generators
- if (pt2_F(i) > 1) then
- ipos += 1
- endif
- enddo
- call write_int(6,sum(pt2_F),'Number of tasks')
- call write_int(6,ipos,'Number of fragmented tasks')
-
- ipos=1
- do i= 1, N_det_generators
- do j=1,pt2_F(pt2_J(i))
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
- ipos += 30
- if (ipos > 300000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- if (ifirst == 0) then
- ifirst=1
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
- endif
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
-
- 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
-
-
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- mem_collector = 8.d0 * & ! bytes
- ( 1.d0*pt2_n_tasks_max & ! task_id, index
- + 0.635d0*N_det_generators & ! f,d
- + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
- + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
- + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
- + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
- + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
- ) / 1024.d0**3
-
- integer :: nproc_target, ii
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = mem_collector + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
- call write_int(6,nproc_target,'Number of threads for PT2')
- call write_double(6,mem,'Memory (Gb)')
-
- call omp_set_max_active_levels(1)
-
-
- print '(A)', '========== ======================= ===================== ===================== ==========='
- print '(A)', ' Samples Energy Variance Norm^2 Seconds'
- print '(A)', '========== ======================= ===================== ===================== ==========='
-
- PROVIDE global_selection_buffer
-
- !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
- !$OMP PRIVATE(i)
- i = omp_get_thread_num()
- if (i==0) then
-
- call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
- pt2_data % rpt2(pt2_stoch_istate) = &
- pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- !TODO : We should use here the correct formula for the error of X/Y
- pt2_data_err % rpt2(pt2_stoch_istate) = &
- pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- else
- call pt2_slave_inproc(i)
- endif
- !$OMP END PARALLEL
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
- call omp_set_max_active_levels(8)
-
- 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
-
- enddo
- FREE pt2_stoch_istate
-
- ! Symmetrize overlap
- do j=2,N_states
- do i=1,j-1
- pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
- pt2_overlap(j,i) = pt2_overlap(i,j)
- enddo
- enddo
-
- print *, 'Overlap of perturbed states:'
- do k=1,N_states
- print *, pt2_overlap(k,:)
- enddo
- print *, '-------'
-
- if (N_in > 0) then
- b%cur = min(N_in,b%cur)
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- else
- call remove_duplicates_in_selection_buffer(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- state_average_weight(:) = state_average_weight_save(:)
- TOUCH state_average_weight
- call update_pt2_and_variance_weights(pt2_data, N_states)
- endif
-
-
-end subroutine
-
-
-subroutine pt2_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- PROVIDE global_selection_buffer
- call run_pt2_slave(1,i,pt2_e0_denominator)
+subroutine provide_for_zmq_pt2
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc psi_det_sorted_tc_order
end
-
-
-subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- double precision, intent(in) :: relative_error, E
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N_
-
- type(pt2_type), allocatable :: pt2_data_task(:)
- type(pt2_type), allocatable :: pt2_data_I(:)
- type(pt2_type), allocatable :: pt2_data_S(:)
- type(pt2_type), allocatable :: pt2_data_S2(:)
- type(pt2_type) :: pt2_data_teeth
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer, external :: zmq_delete_tasks_async_send
- integer, external :: zmq_delete_tasks_async_recv
- integer, external :: zmq_abort
- integer, external :: pt2_find_sample_lr
-
- PROVIDE pt2_stoch_istate
-
- integer :: more, n, i, p, c, t, n_tasks, U
- integer, allocatable :: task_id(:)
- integer, allocatable :: index(:)
-
- double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
- double precision :: eqta(N_states)
- double precision :: time, time1, time0
-
- integer, allocatable :: f(:)
- logical, allocatable :: d(:)
- logical :: do_exit, stop_now, sending
- logical, external :: qp_stop
- type(selection_buffer) :: b2
-
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- sending =.False.
-
- rss = memory_of_int(pt2_n_tasks_max*2+N_det_generators*2)
- rss += memory_of_double(N_states*N_det_generators)*3.d0
- rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
- rss += memory_of_double(pt2_N_teeth+1)*4.d0
- call check_mem(rss,irp_here)
-
- ! If an allocation is added here, the estimate of the memory should also be
- ! updated in ZMQ_pt2
- allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
- allocate(d(N_det_generators+1))
- allocate(pt2_data_task(pt2_n_tasks_max))
- allocate(pt2_data_I(N_det_generators))
- allocate(pt2_data_S(pt2_N_teeth+1))
- allocate(pt2_data_S2(pt2_N_teeth+1))
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N_, N_*2, b2)
-
-
- pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
- pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
- pt2_data % variance(pt2_stoch_istate) = huge(1.)
- pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
- pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
- pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
- n = 1
- t = 0
- U = 0
- do i=1,pt2_n_tasks_max
- call pt2_alloc(pt2_data_task(i),N_states)
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_alloc(pt2_data_S(i),N_states)
- call pt2_alloc(pt2_data_S2(i),N_states)
- enddo
- do i=1,N_det_generators
- call pt2_alloc(pt2_data_I(i),N_states)
- enddo
- f(:) = pt2_F(:)
- d(:) = .false.
- n_tasks = 0
- E0 = E
- v0 = 0.d0
- n0(:) = 0.d0
- more = 1
- call wall_time(time0)
- time1 = time0
-
- do_exit = .false.
- stop_now = .false.
- do while (n <= N_det_generators)
- if(f(pt2_J(n)) == 0) then
- d(pt2_J(n)) = .true.
- do while(d(U+1))
- U += 1
- end do
-
- ! Deterministic part
- do while(t <= pt2_N_teeth)
- if(U >= pt2_n_0(t+1)) then
- t=t+1
- E0 = 0.d0
- v0 = 0.d0
- n0(:) = 0.d0
- do i=pt2_n_0(t),1,-1
- E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
- v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
- n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
- end do
- else
- exit
- end if
- end do
-
- ! Add Stochastic part
- c = pt2_R(n)
- if(c > 0) then
-
- call pt2_alloc(pt2_data_teeth,N_states)
- do p=pt2_N_teeth, 1, -1
- v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
- i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
- v = pt2_W_T / pt2_w(i)
- call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
- call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
- call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
- enddo
- call pt2_dealloc(pt2_data_teeth)
-
- avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
- avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
- avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
- if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
- do_exit = .true.
- endif
- if (qp_stop()) then
- stop_now = .True.
- endif
- pt2_data % pt2(pt2_stoch_istate) = avg
- pt2_data % variance(pt2_stoch_istate) = avg2
- pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
- call wall_time(time)
- ! 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 = 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 = 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(:) = 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
- 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
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- call sleep(10)
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Error in sending abort signal (2)'
- endif
- endif
- endif
- endif
- endif
- end if
- n += 1
- else if(more == 0) then
- exit
- else
- call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
- if(n_tasks > pt2_n_tasks_max)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
- stop -1
- endif
- if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
- stop 'PT2: Unable to delete tasks (send)'
- 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
- endif
- call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
- f(index(i)) -= 1
- end do
- do i=1, b2%cur
- ! We assume the pulled buffer is sorted
- if (b2%val(i) > b%mini) exit
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- end do
- if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
- stop 'PT2: Unable to delete tasks (recv)'
- endif
- end if
- end do
- do i=1,N_det_generators
- call pt2_dealloc(pt2_data_I(i))
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_dealloc(pt2_data_S(i))
- call pt2_dealloc(pt2_data_S2(i))
- enddo
- do i=1,pt2_n_tasks_max
- call pt2_dealloc(pt2_data_task(i))
- enddo
-!print *, 'deleting b2'
- call delete_selection_buffer(b2)
-!print *, 'sorting b'
- call sort_selection_buffer(b)
-!print *, 'done'
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-
-end subroutine
-
-
-integer function pt2_find_sample(v, w)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, external :: pt2_find_sample_lr
-
- pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
-end function
-
-
-integer function pt2_find_sample_lr(v, w, l_in, r_in)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, intent(in) :: l_in,r_in
- integer :: i,l,r
-
- l=l_in
- r=r_in
-
- do while(r-l > 1)
- i = shiftr(r+l,1)
- if(w(i) < v) then
- l = i
- else
- r = i
- end if
- end do
- i = r
- do r=i+1,N_det_generators
- if (w(r) /= w(i)) then
- exit
- endif
- enddo
- pt2_find_sample_lr = r-1
-end function
-
-
-BEGIN_PROVIDER [ integer, pt2_n_tasks ]
- implicit none
- BEGIN_DOC
- ! Number of parallel tasks for the Monte Carlo
- END_DOC
- pt2_n_tasks = N_det_generators
-END_PROVIDER
-
-BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
- implicit none
- integer, allocatable :: seed(:)
- integer :: m,i
- call random_seed(size=m)
- allocate(seed(m))
- do i=1,m
- seed(i) = i
- enddo
- call random_seed(put=seed)
- deallocate(seed)
-
- call RANDOM_NUMBER(pt2_u)
- END_PROVIDER
-
- BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
-&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
- implicit none
- BEGIN_DOC
-! pt2_J contains the list of generators after ordering them according to the
-! Monte Carlo sampling.
-!
-! pt2_R(i) is the number of combs drawn when determinant i is computed.
- END_DOC
- integer :: N_c, N_j
- integer :: U, t, i
- double precision :: v
- integer, external :: pt2_find_sample_lr
-
- logical, allocatable :: pt2_d(:)
- integer :: m,l,r,k
- integer :: ncache
- integer, allocatable :: ii(:,:)
- double precision :: dt
-
- ncache = min(N_det_generators,10000)
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
-
- allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
-
- pt2_R(:) = 0
- pt2_d(:) = .false.
- N_c = 0
- N_j = pt2_n_0(1)
- do i=1,N_j
- pt2_d(i) = .true.
- pt2_J(i) = i
- end do
-
- U = 0
- do while(N_j < pt2_n_tasks)
-
- if (N_c+ncache > N_det_generators) then
- ncache = N_det_generators - N_c
- endif
-
- !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
- do k=1, ncache
- dt = pt2_u_0
- do t=1, pt2_N_teeth
- v = dt + pt2_W_T *pt2_u(N_c+k)
- dt = dt + pt2_W_T
- ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
- end do
- enddo
- !$OMP END PARALLEL DO
-
- do k=1,ncache
- !ADD_COMB
- N_c = N_c+1
- do t=1, pt2_N_teeth
- i = ii(t,k)
- if(.not. pt2_d(i)) then
- N_j += 1
- pt2_J(N_j) = i
- pt2_d(i) = .true.
- end if
- end do
-
- pt2_R(N_j) = N_c
-
- !FILL_TOOTH
- do while(U < N_det_generators)
- U += 1
- if(.not. pt2_d(U)) then
- N_j += 1
- pt2_J(N_j) = U
- pt2_d(U) = .true.
- exit
- end if
- end do
- if (N_j >= pt2_n_tasks) exit
- end do
- enddo
-
- if(N_det_generators > 1) then
- pt2_R(N_det_generators-1) = 0
- pt2_R(N_det_generators) = N_c
- end if
-
- deallocate(ii,pt2_d)
-
-END_PROVIDER
-
-
-
- BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_W_T ]
-&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
-&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
- implicit none
- integer :: i, t
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- double precision :: r, tooth_width
- integer, external :: pt2_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- if (N_det_generators == 1) then
-
- pt2_w(1) = 1.d0
- pt2_cw(1) = 1.d0
- pt2_u_0 = 1.d0
- pt2_W_T = 0.d0
- pt2_n_0(1) = 0
- pt2_n_0(2) = 1
-
- else
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- tilde_cW(0) = 0d0
-
- do i=1,N_det_generators
- tilde_w(i) = psi_coef_sorted_tc_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
- enddo
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- norm2 += tilde_w(i)
- enddo
-
- tilde_w(:) = tilde_w(:) / norm2
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
-
- pt2_n_0(1) = 0
- do
- pt2_u_0 = tilde_cW(pt2_n_0(1))
- r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
- pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
- if(pt2_W_T >= r - pt2_u_0) then
- exit
- end if
- pt2_n_0(1) += 1
- if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
- print *, "teeth building failed"
- stop -1
- end if
- end do
-
- do t=2, pt2_N_teeth
- r = pt2_u_0 + pt2_W_T * dble(t-1)
- pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
- 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 = 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
- end do
-
- pt2_cW(0) = 0d0
- do i=1,N_det_generators
- pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- endif
-END_PROVIDER
-
-
-
-
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 66d82964..2200373b 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -62,7 +62,7 @@ subroutine run_stochastic_cipsi
! if (N_det > N_det_max) then
! psi_det(1:N_int,1:2,1:N_det) = psi_det_generators(1:N_int,1:2,1:N_det)
-! psi_coef(1:N_det,1:N_states) = psi_coef_sorted_tc_gen(1:N_det,1:N_states)
+! psi_coef(1:N_det,1:N_states) = psi_coef_sorted_gen(1:N_det,1:N_states)
! N_det = N_det_max
! soft_touch N_det psi_det psi_coef
! if (s2_eig) then
diff --git a/plugins/local/fci_tc_bi/NEED b/plugins/local/fci_tc_bi/NEED
index 3bb9515a..8e9ae1c8 100644
--- a/plugins/local/fci_tc_bi/NEED
+++ b/plugins/local/fci_tc_bi/NEED
@@ -1,3 +1,4 @@
+generators_full_tc
json
tc_bi_ortho
davidson_undressed
diff --git a/plugins/local/fci_tc_bi/selectors.irp.f b/plugins/local/fci_tc_bi/selectors.irp.f
index 7f93ae55..606660fd 100644
--- a/plugins/local/fci_tc_bi/selectors.irp.f
+++ b/plugins/local/fci_tc_bi/selectors.irp.f
@@ -40,7 +40,7 @@ END_PROVIDER
enddo
do k=1,N_states
do i=1,N_det_selectors
- psi_selectors_coef(i,k) = psi_coef_sorted_tc_gen(i,k)
+ psi_selectors_coef(i,k) = psi_coef_sorted_gen(i,k)
psi_selectors_coef_tc(i,1,k) = psi_l_coef_sorted_bi_ortho(i,k)
psi_selectors_coef_tc(i,2,k) = psi_r_coef_sorted_bi_ortho(i,k)
enddo
diff --git a/src/cipsi/NEED b/src/cipsi/NEED
index 89c128ec..ddd1e8cc 100644
--- a/src/cipsi/NEED
+++ b/src/cipsi/NEED
@@ -1,3 +1,4 @@
+cipsi_utils
json
perturbation
zmq
diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f
index 3b048c14..228e0ef1 100644
--- a/src/cipsi/pt2_stoch_routines.irp.f
+++ b/src/cipsi/pt2_stoch_routines.irp.f
@@ -1,923 +1,3 @@
-BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
- implicit none
- BEGIN_DOC
- ! State for stochatsic PT2
- END_DOC
- pt2_stoch_istate = 1
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
-&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
- implicit none
- logical, external :: testTeethBuilding
- integer :: i,j
- pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
- pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
- call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
-
- pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
- do i=1,pt2_n_0(1+pt2_N_teeth/4)
- pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
- pt2_F(i) = pt2_min_parallel_tasks
- enddo
- do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
- pt2_F(i) = 1
- enddo
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ integer, pt2_N_teeth ]
-&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
- implicit none
- logical, external :: testTeethBuilding
-
- if(N_det_generators < 1024) then
- pt2_minDetInFirstTeeth = 1
- pt2_N_teeth = 1
- else
- pt2_minDetInFirstTeeth = min(5, N_det_generators)
- do pt2_N_teeth=100,2,-1
- if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
- end do
- end if
- call write_int(6,pt2_N_teeth,'Number of comb teeth')
-END_PROVIDER
-
-
-logical function testTeethBuilding(minF, N)
- implicit none
- integer, intent(in) :: minF, N
- integer :: n0, i
- double precision :: u0, Wt, r
-
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- integer, external :: dress_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
-
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
- psi_coef_sorted_gen(i,pt2_stoch_istate)
- norm2 = norm2 + tilde_w(i)
- enddo
-
- f = 1.d0/norm2
- tilde_w(:) = tilde_w(:) * f
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
- deallocate(tilde_w)
-
- n0 = 0
- testTeethBuilding = .false.
- double precision :: f
- integer :: minFN
- minFN = N_det_generators - minF * N
- f = 1.d0/dble(N)
- do
- u0 = tilde_cW(n0)
- r = tilde_cW(n0 + minF)
- Wt = (1d0 - u0) * f
- if (dabs(Wt) <= 1.d-3) then
- exit
- endif
- if(Wt >= r - u0) then
- testTeethBuilding = .true.
- exit
- end if
- n0 += 1
- if(n0 > minFN) then
- exit
- end if
- end do
- deallocate(tilde_cW)
-
-end function
-
-
-
-subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
- use f77_zmq
- use selection_types
-
- implicit none
-
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
- integer, intent(in) :: N_in
- double precision, intent(in) :: relative_error, E(N_states)
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
-!
- integer :: i, N
-
- double precision :: state_average_weight_save(N_states), w(N_states,4)
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- type(selection_buffer) :: b
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
- PROVIDE psi_det_hii 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
-
- if (h0_type == 'CFG') then
- PROVIDE psi_configuration_hii det_to_configuration
- endif
-
- if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
- call ZMQ_selection(N_in, pt2_data)
- else
-
- N = max(N_in,1) * N_states
- state_average_weight_save(:) = state_average_weight(:)
- if (int(N,8)*2_8 > huge(1)) then
- print *, irp_here, ': integer too large'
- stop -1
- endif
- call create_selection_buffer(N, N*2, b)
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- do pt2_stoch_istate=1,N_states
- state_average_weight(:) = 0.d0
- state_average_weight(pt2_stoch_istate) = 1.d0
- TOUCH state_average_weight pt2_stoch_istate selection_weight
-
- PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
- PROVIDE psi_selectors pt2_u pt2_J pt2_R
- call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
- integer, external :: zmq_put_ivector
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
- stop 'Unable to put pt2_stoch_istate on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
-
-
- integer, external :: add_task_to_taskserver
- character(300000) :: task
-
- integer :: j,k,ipos,ifirst
- ifirst=0
-
- ipos=0
- do i=1,N_det_generators
- if (pt2_F(i) > 1) then
- ipos += 1
- endif
- enddo
- call write_int(6,sum(pt2_F),'Number of tasks')
- call write_int(6,ipos,'Number of fragmented tasks')
-
- ipos=1
- do i= 1, N_det_generators
- do j=1,pt2_F(pt2_J(i))
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
- ipos += 30
- if (ipos > 300000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- if (ifirst == 0) then
- ifirst=1
- if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Failed in zmq_set_running'
- endif
- endif
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
-
- 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
-
-
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- mem_collector = 8.d0 * & ! bytes
- ( 1.d0*pt2_n_tasks_max & ! task_id, index
- + 0.635d0*N_det_generators & ! f,d
- + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
- + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
- + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
- + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
- + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
- ) / 1024.d0**3
-
- integer :: nproc_target, ii
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = mem_collector + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
- call write_int(6,nproc_target,'Number of threads for PT2')
- call write_double(6,mem,'Memory (Gb)')
-
- call set_multiple_levels_omp(.False.)
-
-
- print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
- print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
- print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
-
- PROVIDE global_selection_buffer
-
- !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
- !$OMP PRIVATE(i)
- i = omp_get_thread_num()
- if (i==0) then
-
- call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
- pt2_data % rpt2(pt2_stoch_istate) = &
- pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- !TODO : We should use here the correct formula for the error of X/Y
- pt2_data_err % rpt2(pt2_stoch_istate) = &
- pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
-
- else
- call pt2_slave_inproc(i)
- endif
- !$OMP END PARALLEL
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
- call set_multiple_levels_omp(.True.)
-
- 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
-
- enddo
- FREE pt2_stoch_istate
-
- ! Symmetrize overlap
- do j=2,N_states
- do i=1,j-1
- pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
- pt2_overlap(j,i) = pt2_overlap(i,j)
- enddo
- enddo
-
- print *, 'Overlap of perturbed states:'
- do k=1,N_states
- print *, pt2_overlap(k,:)
- enddo
- print *, '-------'
-
- if (N_in > 0) then
- b%cur = min(N_in,b%cur)
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- else
- call remove_duplicates_in_selection_buffer(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- state_average_weight(:) = state_average_weight_save(:)
- TOUCH state_average_weight
- call update_pt2_and_variance_weights(pt2_data, N_states)
- endif
-
-
-end subroutine
-
-
-subroutine pt2_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- PROVIDE global_selection_buffer
- call run_pt2_slave(1,i,pt2_e0_denominator)
+subroutine provide_for_zmq_pt2
+ PROVIDE psi_selectors_coef_transp psi_det_sorted psi_det_sorted_order
end
-
-
-subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- double precision, intent(in) :: relative_error, E
- type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N_
-
- type(pt2_type), allocatable :: pt2_data_task(:)
- type(pt2_type), allocatable :: pt2_data_I(:)
- type(pt2_type), allocatable :: pt2_data_S(:)
- type(pt2_type), allocatable :: pt2_data_S2(:)
- type(pt2_type) :: pt2_data_teeth
- integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- integer, external :: zmq_delete_tasks_async_send
- integer, external :: zmq_delete_tasks_async_recv
- integer, external :: zmq_abort
- integer, external :: pt2_find_sample_lr
-
- PROVIDE pt2_stoch_istate
-
- integer :: more, n, i, p, c, t, n_tasks, U
- integer, allocatable :: task_id(:)
- integer, allocatable :: index(:)
-
- double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
- double precision :: eqta(N_states)
- double precision :: time, time1, time0
-
- integer, allocatable :: f(:)
- logical, allocatable :: d(:)
- logical :: do_exit, stop_now, sending
- logical, external :: qp_stop
- type(selection_buffer) :: b2
-
-
- 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)
- rss += memory_of_double(N_states*N_det_generators)*3.d0
- rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
- rss += memory_of_double(pt2_N_teeth+1)*4.d0
- call check_mem(rss,irp_here)
-
- ! If an allocation is added here, the estimate of the memory should also be
- ! updated in ZMQ_pt2
- allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
- allocate(d(N_det_generators+1))
- allocate(pt2_data_task(pt2_n_tasks_max))
- allocate(pt2_data_I(N_det_generators))
- allocate(pt2_data_S(pt2_N_teeth+1))
- allocate(pt2_data_S2(pt2_N_teeth+1))
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N_, N_*2, b2)
-
-
- pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
- pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
- pt2_data % variance(pt2_stoch_istate) = huge(1.)
- pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
- pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
- pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
- n = 1
- t = 0
- U = 0
- do i=1,pt2_n_tasks_max
- call pt2_alloc(pt2_data_task(i),N_states)
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_alloc(pt2_data_S(i),N_states)
- call pt2_alloc(pt2_data_S2(i),N_states)
- enddo
- do i=1,N_det_generators
- call pt2_alloc(pt2_data_I(i),N_states)
- enddo
- f(:) = pt2_F(:)
- d(:) = .false.
- n_tasks = 0
- E0 = E
- v0 = 0.d0
- n0(:) = 0.d0
- more = 1
- call wall_time(time0)
- time1 = time0
-
- do_exit = .false.
- stop_now = .false.
- do while (n <= N_det_generators)
- if(f(pt2_J(n)) == 0) then
- d(pt2_J(n)) = .true.
- do while(d(U+1))
- U += 1
- end do
-
- ! Deterministic part
- do while(t <= pt2_N_teeth)
- if(U >= pt2_n_0(t+1)) then
- t=t+1
- E0 = 0.d0
- v0 = 0.d0
- n0(:) = 0.d0
- do i=pt2_n_0(t),1,-1
- E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
- v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
- n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
- end do
- else
- exit
- end if
- end do
-
- ! Add Stochastic part
- c = pt2_R(n)
- if(c > 0) then
-
- call pt2_alloc(pt2_data_teeth,N_states)
- do p=pt2_N_teeth, 1, -1
- v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
- i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
- v = pt2_W_T / pt2_w(i)
- call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
- call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
- call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
- enddo
- call pt2_dealloc(pt2_data_teeth)
-
- avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
- avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
- avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
- if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
- do_exit = .true.
- endif
- if (qp_stop()) then
- stop_now = .True.
- endif
- pt2_data % pt2(pt2_stoch_istate) = avg
- pt2_data % variance(pt2_stoch_istate) = avg2
- pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
- call wall_time(time)
- ! 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))
- 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))
- 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))
- 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,ES16.6,ES16.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
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- call sleep(10)
- if (zmq_abort(zmq_to_qp_run_socket) == -1) then
- print *, irp_here, ': Error in sending abort signal (2)'
- endif
- endif
- endif
- endif
- endif
- end if
- n += 1
- else if(more == 0) then
- exit
- else
- call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
- if(n_tasks > pt2_n_tasks_max)then
- print*,'PB !!!'
- print*,'If you see this, send a bug report with the following content'
- print*,irp_here
- print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
- stop -1
- endif
- if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
- stop 'PT2: Unable to delete tasks (send)'
- 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
- endif
- call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
- f(index(i)) -= 1
- end do
- do i=1, b2%cur
- ! We assume the pulled buffer is sorted
- if (b2%val(i) > b%mini) exit
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- end do
- if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
- stop 'PT2: Unable to delete tasks (recv)'
- endif
- end if
- end do
- do i=1,N_det_generators
- call pt2_dealloc(pt2_data_I(i))
- enddo
- do i=1,pt2_N_teeth+1
- call pt2_dealloc(pt2_data_S(i))
- call pt2_dealloc(pt2_data_S2(i))
- enddo
- do i=1,pt2_n_tasks_max
- call pt2_dealloc(pt2_data_task(i))
- enddo
-!print *, 'deleting b2'
- call delete_selection_buffer(b2)
-!print *, 'sorting b'
- call sort_selection_buffer(b)
-!print *, 'done'
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-
-end subroutine
-
-
-integer function pt2_find_sample(v, w)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, external :: pt2_find_sample_lr
-
- pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
-end function
-
-
-integer function pt2_find_sample_lr(v, w, l_in, r_in)
- implicit none
- double precision, intent(in) :: v, w(0:N_det_generators)
- integer, intent(in) :: l_in,r_in
- integer :: i,l,r
-
- l=l_in
- r=r_in
-
- do while(r-l > 1)
- i = shiftr(r+l,1)
- if(w(i) < v) then
- l = i
- else
- r = i
- end if
- end do
- i = r
- do r=i+1,N_det_generators
- if (w(r) /= w(i)) then
- exit
- endif
- enddo
- pt2_find_sample_lr = r-1
-end function
-
-
-BEGIN_PROVIDER [ integer, pt2_n_tasks ]
- implicit none
- BEGIN_DOC
- ! Number of parallel tasks for the Monte Carlo
- END_DOC
- pt2_n_tasks = N_det_generators
-END_PROVIDER
-
-BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
- implicit none
- integer, allocatable :: seed(:)
- integer :: m,i
- call random_seed(size=m)
- allocate(seed(m))
- do i=1,m
- seed(i) = i
- enddo
- call random_seed(put=seed)
- deallocate(seed)
-
- call RANDOM_NUMBER(pt2_u)
- END_PROVIDER
-
- BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
-&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
- implicit none
- BEGIN_DOC
-! pt2_J contains the list of generators after ordering them according to the
-! Monte Carlo sampling.
-!
-! pt2_R(i) is the number of combs drawn when determinant i is computed.
- END_DOC
- integer :: N_c, N_j
- integer :: U, t, i
- double precision :: v
- integer, external :: pt2_find_sample_lr
-
- logical, allocatable :: pt2_d(:)
- integer :: m,l,r,k
- integer :: ncache
- integer, allocatable :: ii(:,:)
- double precision :: dt
-
- ncache = min(N_det_generators,10000)
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
-
- allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
-
- pt2_R(:) = 0
- pt2_d(:) = .false.
- N_c = 0
- N_j = pt2_n_0(1)
- do i=1,N_j
- pt2_d(i) = .true.
- pt2_J(i) = i
- end do
-
- U = 0
- do while(N_j < pt2_n_tasks)
-
- if (N_c+ncache > N_det_generators) then
- ncache = N_det_generators - N_c
- endif
-
- !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
- do k=1, ncache
- dt = pt2_u_0
- do t=1, pt2_N_teeth
- v = dt + pt2_W_T *pt2_u(N_c+k)
- dt = dt + pt2_W_T
- ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
- end do
- enddo
- !$OMP END PARALLEL DO
-
- do k=1,ncache
- !ADD_COMB
- N_c = N_c+1
- do t=1, pt2_N_teeth
- i = ii(t,k)
- if(.not. pt2_d(i)) then
- N_j += 1
- pt2_J(N_j) = i
- pt2_d(i) = .true.
- end if
- end do
-
- pt2_R(N_j) = N_c
-
- !FILL_TOOTH
- do while(U < N_det_generators)
- U += 1
- if(.not. pt2_d(U)) then
- N_j += 1
- pt2_J(N_j) = U
- pt2_d(U) = .true.
- exit
- end if
- end do
- if (N_j >= pt2_n_tasks) exit
- end do
- enddo
-
- if(N_det_generators > 1) then
- pt2_R(N_det_generators-1) = 0
- pt2_R(N_det_generators) = N_c
- end if
-
- deallocate(ii,pt2_d)
-
-END_PROVIDER
-
-
-
- BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
-&BEGIN_PROVIDER [ double precision, pt2_W_T ]
-&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
-&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
- implicit none
- integer :: i, t
- double precision, allocatable :: tilde_w(:), tilde_cW(:)
- double precision :: r, tooth_width
- integer, external :: pt2_find_sample
-
- double precision :: rss
- double precision, external :: memory_of_double, memory_of_int
- rss = memory_of_double(2*N_det_generators+1)
- call check_mem(rss,irp_here)
-
- if (N_det_generators == 1) then
-
- pt2_w(1) = 1.d0
- pt2_cw(1) = 1.d0
- pt2_u_0 = 1.d0
- pt2_W_T = 0.d0
- pt2_n_0(1) = 0
- pt2_n_0(2) = 1
-
- else
-
- allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-
- tilde_cW(0) = 0d0
-
- do i=1,N_det_generators
- tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
- enddo
-
- double precision :: norm2
- norm2 = 0.d0
- do i=N_det_generators,1,-1
- norm2 += tilde_w(i)
- enddo
-
- tilde_w(:) = tilde_w(:) / norm2
-
- tilde_cW(0) = -1.d0
- do i=1,N_det_generators
- tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
- enddo
- tilde_cW(:) = tilde_cW(:) + 1.d0
-
- pt2_n_0(1) = 0
- do
- pt2_u_0 = tilde_cW(pt2_n_0(1))
- r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
- pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
- if(pt2_W_T >= r - pt2_u_0) then
- exit
- end if
- pt2_n_0(1) += 1
- if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
- print *, "teeth building failed"
- stop -1
- end if
- end do
-
- do t=2, pt2_N_teeth
- r = pt2_u_0 + pt2_W_T * dble(t-1)
- pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
- 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))))
- 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
- end do
-
- pt2_cW(0) = 0d0
- do i=1,N_det_generators
- pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
- end do
- pt2_n_0(pt2_N_teeth+1) = N_det_generators
-
- endif
-END_PROVIDER
-
-
-
-
-
diff --git a/src/generators_full_tc/README.rst b/src/generators_full_tc/README.rst
new file mode 100644
index 00000000..4e59ee3b
--- /dev/null
+++ b/src/generators_full_tc/README.rst
@@ -0,0 +1,9 @@
+===============
+generators_full
+===============
+
+Module defining the generator determinants as all the determinants of the
+variational space.
+
+This module is intended to be included in the :file:`NEED` file to define
+a full set of generators.
diff --git a/plugins/local/fci_tc_bi/generators.irp.f b/src/generators_full_tc/generators.irp.f
similarity index 51%
rename from plugins/local/fci_tc_bi/generators.irp.f
rename to src/generators_full_tc/generators.irp.f
index bf972423..a9da7dbc 100644
--- a/plugins/local/fci_tc_bi/generators.irp.f
+++ b/src/generators_full_tc/generators.irp.f
@@ -34,23 +34,49 @@ END_PROVIDER
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) ]
+ 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
! 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
- integer :: i
-! do i = 1,N_det
-! print*,'i = ',i
-! call debug_det(psi_det_sorted_tc(1,1,i),N_int)
-! enddo
+ psi_det_sorted_gen = psi_det_sorted_tc
+ psi_coef_sorted_gen = psi_coef_sorted_tc
+ psi_det_sorted_gen_order = psi_det_sorted_tc_order
END_PROVIDER
+BEGIN_PROVIDER [integer, degree_max_generators]
+ implicit none
+ BEGIN_DOC
+! Max degree of excitation (respect to HF) of the generators
+ END_DOC
+ integer :: i,degree
+ degree_max_generators = 0
+ do i = 1, N_det_generators
+ call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int)
+ if(degree .gt. degree_max_generators)then
+ degree_max_generators = degree
+ endif
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, size_select_max]
+ implicit none
+ BEGIN_DOC
+ ! Size of the select_max array
+ END_DOC
+ size_select_max = 10000
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
+ implicit none
+ BEGIN_DOC
+ ! Memo to skip useless selectors
+ END_DOC
+ select_max = huge(1.d0)
+END_PROVIDER
+
From 9a15fecd6a164375ead8684c6a836147b548f4fa Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 16:42:08 +0100
Subject: [PATCH 048/140] Merging CIPSI and TC-CIPSI
---
.../cipsi_tc_bi_ortho/zmq_selection.irp.f | 234 ------------------
.../zmq_selection.irp.f | 0
2 files changed, 234 deletions(-)
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
rename src/{cipsi => cipsi_utils}/zmq_selection.irp.f (100%)
diff --git a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
deleted file mode 100644
index 22db643f..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/zmq_selection.irp.f
+++ /dev/null
@@ -1,234 +0,0 @@
-subroutine ZMQ_selection(N_in, pt2_data)
- use f77_zmq
- use selection_types
-
- implicit none
-
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
- integer, intent(in) :: N_in
- type(selection_buffer) :: b
- integer :: i, l, N
- integer, external :: omp_get_thread_num
- type(pt2_type), intent(inout) :: pt2_data
-
-! PROVIDE psi_det psi_coef N_det qp_max_mem N_states pt2_F s2_eig N_det_generators
-
- N = max(N_in,1)
- N = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- if (.True.) then
- PROVIDE pt2_e0_denominator nproc
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- 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
-
- call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'selection')
-
- integer, external :: zmq_put_psi
- integer, external :: zmq_put_N_det_generators
- integer, external :: zmq_put_N_det_selectors
- integer, external :: zmq_put_dvector
-
- if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
- stop 'Unable to put psi on ZMQ server'
- endif
- if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_generators on ZMQ server'
- endif
- if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
- stop 'Unable to put N_det_selectors on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
- stop 'Unable to put energy on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
- stop 'Unable to put state_average_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
- stop 'Unable to put selection_weight on ZMQ server'
- endif
- if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
- stop 'Unable to put threshold_generators on ZMQ server'
- endif
- call create_selection_buffer(N, N*2, b)
- endif
-
- integer, external :: add_task_to_taskserver
- character(len=100000) :: task
- integer :: j,k,ipos
- ipos=1
- task = ' '
-
- do i= 1, N_det_generators
- do j=1,pt2_F(i)
- write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, i, N
- ipos += 30
- if (ipos > 100000-30) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- ipos=1
- endif
- end do
- enddo
- if (ipos > 1) then
- if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
- stop 'Unable to add task to task server'
- endif
- endif
- N = max(N_in,1)
-
-
- ASSERT (associated(b%det))
- ASSERT (associated(b%val))
-
- 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
-
- integer :: nproc_target
- if (N_det < 3*nproc) then
- nproc_target = N_det/4
- else
- nproc_target = nproc
- endif
- double precision :: mem
- mem = 8.d0 * N_det * (N_int * 2.d0 * 3.d0 + 3.d0 + 5.d0) / (1024.d0**3)
- call write_double(6,mem,'Estimated memory/thread (Gb)')
- if (qp_max_mem > 0) then
- nproc_target = max(1,int(dble(qp_max_mem)/(0.1d0 + mem)))
- nproc_target = min(nproc_target,nproc)
- endif
-
- f(:) = 1.d0
- if (.not.do_pt2) then
- double precision :: f(N_states), u_dot_u
- do k=1,min(N_det,N_states)
- f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
- enddo
- endif
-
- !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2_data) PRIVATE(i) NUM_THREADS(nproc_target+1)
- i = omp_get_thread_num()
- if (i==0) then
- call selection_collector(zmq_socket_pull, b, N, pt2_data)
- else
- call selection_slave_inproc(i)
- endif
- !$OMP END PARALLEL
-
- call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'selection')
- if (N_in > 0) then
- if (s2_eig) then
- call make_selection_buffer_s2(b)
- endif
- call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
- endif
- call delete_selection_buffer(b)
-
- do k=1,N_states
- pt2_data % pt2(k) = pt2_data % pt2(k) * f(k)
- pt2_data % variance(k) = pt2_data % variance(k) * f(k)
- do l=1,N_states
- pt2_data % overlap(k,l) = pt2_data % overlap(k,l) * dsqrt(f(k)*f(l))
- pt2_data % overlap(l,k) = pt2_data % overlap(l,k) * dsqrt(f(k)*f(l))
- enddo
-
- pt2_data % rpt2(k) = &
- pt2_data % pt2(k)/(1.d0 + pt2_data % overlap(k,k))
- enddo
-
- pt2_overlap(:,:) = pt2_data % overlap(:,:)
-
- print *, 'Overlap of perturbed states:'
- do l=1,N_states
- print *, pt2_overlap(l,:)
- enddo
- print *, '-------'
- SOFT_TOUCH pt2_overlap
- call update_pt2_and_variance_weights(pt2_data, N_states)
-
-end subroutine
-
-
-subroutine selection_slave_inproc(i)
- implicit none
- integer, intent(in) :: i
-
- call run_selection_slave(1,i,pt2_e0_denominator)
-end
-
-subroutine selection_collector(zmq_socket_pull, b, N, pt2_data)
- use f77_zmq
- use selection_types
- use bitmasks
- implicit none
-
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: N
- type(pt2_type), intent(inout) :: pt2_data
- type(pt2_type) :: pt2_data_tmp
-
- double precision :: pt2_mwen(N_states)
- double precision :: variance_mwen(N_states)
- double precision :: norm2_mwen(N_states)
- 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 :: msg_size, rc, more
- integer :: acc, i, j, robin, ntask
- double precision, pointer :: val(:)
- integer(bit_kind), pointer :: det(:,:,:)
- integer, allocatable :: task_id(:)
- type(selection_buffer) :: b2
-
-
-
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
- call create_selection_buffer(N, N*2, b2)
- integer :: k
- double precision :: rss
- double precision, external :: memory_of_int
- rss = memory_of_int(N_det_generators)
- call check_mem(rss,irp_here)
- allocate(task_id(N_det_generators))
- more = 1
- pt2_data % pt2(:) = 0d0
- pt2_data % variance(:) = 0.d0
- pt2_data % overlap(:,:) = 0.d0
- call pt2_alloc(pt2_data_tmp,N_states)
- do while (more == 1)
- call pull_selection_results(zmq_socket_pull, pt2_data_tmp, b2%val(1), b2%det(1,1,1), b2%cur, task_id, ntask)
-
- call pt2_add(pt2_data, 1.d0, pt2_data_tmp)
- do i=1, b2%cur
- call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
- if (b2%val(i) > b%mini) exit
- end do
-
- do i=1, ntask
- if(task_id(i) == 0) then
- print *, "Error in collector"
- endif
- integer, external :: zmq_delete_task
- if (zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) == -1) then
- stop 'Unable to delete task'
- endif
- end do
- end do
- call pt2_dealloc(pt2_data_tmp)
-
-
- call delete_selection_buffer(b2)
- call sort_selection_buffer(b)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
-end subroutine
-
diff --git a/src/cipsi/zmq_selection.irp.f b/src/cipsi_utils/zmq_selection.irp.f
similarity index 100%
rename from src/cipsi/zmq_selection.irp.f
rename to src/cipsi_utils/zmq_selection.irp.f
From 1769efddca34f996d0d3a169bea08030c6a9e0ed Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 16:52:53 +0100
Subject: [PATCH 049/140] fixed the qp_test of tc_scf
---
plugins/local/tc_scf/11.tc_scf.bats | 44 ++++++++++++++++-------------
1 file changed, 24 insertions(+), 20 deletions(-)
diff --git a/plugins/local/tc_scf/11.tc_scf.bats b/plugins/local/tc_scf/11.tc_scf.bats
index b81c2f4b..f5f2e3c1 100644
--- a/plugins/local/tc_scf/11.tc_scf.bats
+++ b/plugins/local/tc_scf/11.tc_scf.bats
@@ -10,16 +10,17 @@ function run_Ne() {
qp create_ezfio -b cc-pcvdz Ne.xyz -o Ne_tc_scf
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-128.552134
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -33,16 +34,17 @@ function run_C() {
qp create_ezfio -b cc-pcvdz C.xyz -o C_tc_scf -m 3
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-37.691254356408791
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -57,16 +59,17 @@ function run_O() {
qp create_ezfio -b cc-pcvdz O.xyz -o O_tc_scf -m 3
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1.]"
+ qp set jastrow env_expo "[1.5]"
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen [1.5]
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-74.814687229354590
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -82,16 +85,17 @@ function run_ch2() {
qp create_ezfio -b "C:cc-pcvdz|H:cc-pvdz" ch2.xyz -o ch2_tc_scf
qp run scf
+ qp set tc_keywords tc_integ_type numeric
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow j1e_type None
+ qp set jastrow env_coef "[1., 1., 1.]"
+ qp set jastrow env_expo '[1.5,10000,10000]'
qp set hamiltonian mu_erf 0.87
- qp set tc_keywords j1b_type 3
- qp set tc_keywords j1b_pen '[1.5,10000,10000]'
- qp set tc_keywords bi_ortho True
- qp set tc_keywords test_cycle_tc True
qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
eref=-38.903247818077737
energy="$(qp get tc_scf bitc_energy)"
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
From a42c79ca34111ac449bdf2b18243ef38f9d4abe6 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 17:09:58 +0100
Subject: [PATCH 050/140] The test works for fci_tc_bi but not for tc_bi_ortho
---
plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats b/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats
index 93bed2ab..33afcb92 100644
--- a/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats
+++ b/plugins/local/tc_bi_ortho/31.tc_bi_ortho.bats
@@ -14,7 +14,7 @@ function run_Ne() {
qp run tc_bi_ortho | tee Ne_tc_scf.cisd_tc_bi_ortho.out
eref=-128.77020441279302
energy=$(get_e Ne_tc_scf.cisd_tc_bi_ortho.out)
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -29,7 +29,7 @@ function run_C() {
qp run tc_bi_ortho | tee C_tc_scf.cisd_tc_bi_ortho.out
eref=-37.757536149952514
energy=$(get_e C_tc_scf.cisd_tc_bi_ortho.out)
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
@@ -43,7 +43,7 @@ function run_O() {
qp run tc_bi_ortho | tee O_tc_scf.cisd_tc_bi_ortho.out
eref=-74.908518517716161
energy=$(get_e O_tc_scf.cisd_tc_bi_ortho.out)
- eq $energy $eref 1e-6
+ eq $energy $eref 2e-4
}
From f816773102c06547c1f8d3a5f5b492321b4fd84f Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 17:21:35 +0100
Subject: [PATCH 051/140] Refactor CIPSI / TC-CIPSI
---
plugins/local/cipsi_tc_bi_ortho/energy.irp.f | 32 -
.../local/cipsi_tc_bi_ortho/environment.irp.f | 14 -
.../local/cipsi_tc_bi_ortho/lock_2rdm.irp.f | 0
.../cipsi_tc_bi_ortho/run_pt2_slave.irp.f | 546 -----------
.../run_selection_slave.irp.f | 261 +----
.../local/cipsi_tc_bi_ortho/selection.irp.f | 150 +--
.../cipsi_tc_bi_ortho/selection_buffer.irp.f | 424 ---------
.../cipsi_tc_bi_ortho/selection_weight.irp.f | 134 ---
.../local/cipsi_tc_bi_ortho/slave_cipsi.irp.f | 348 -------
src/cipsi/cipsi.irp.f | 11 +-
src/cipsi/energy.irp.f | 9 -
src/cipsi/lock_2rdm.irp.f | 0
src/cipsi/pt2_type.irp.f | 128 ---
src/cipsi/run_selection_slave.irp.f | 259 +----
src/cipsi/selection.irp.f | 104 +-
src/cipsi/selection_types.f90 | 25 -
src/cipsi_utils/README.rst | 5 +
src/{cipsi => cipsi_utils}/environment.irp.f | 0
src/cipsi_utils/pt2_stoch_routines.irp.f | 891 ++++++++++++++++++
.../cipsi_utils}/pt2_type.irp.f | 0
.../run_pt2_slave.irp.f | 0
src/cipsi_utils/run_selection_slave.irp.f | 257 +++++
.../selection_buffer.irp.f | 0
.../cipsi_utils}/selection_types.f90 | 0
.../selection_weight.irp.f | 0
src/{cipsi => cipsi_utils}/slave_cipsi.irp.f | 5 +-
26 files changed, 1303 insertions(+), 2300 deletions(-)
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/environment.irp.f
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
delete mode 100644 plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
delete mode 100644 src/cipsi/lock_2rdm.irp.f
delete mode 100644 src/cipsi/pt2_type.irp.f
delete mode 100644 src/cipsi/selection_types.f90
create mode 100644 src/cipsi_utils/README.rst
rename src/{cipsi => cipsi_utils}/environment.irp.f (100%)
create mode 100644 src/cipsi_utils/pt2_stoch_routines.irp.f
rename {plugins/local/cipsi_tc_bi_ortho => src/cipsi_utils}/pt2_type.irp.f (100%)
rename src/{cipsi => cipsi_utils}/run_pt2_slave.irp.f (100%)
create mode 100644 src/cipsi_utils/run_selection_slave.irp.f
rename src/{cipsi => cipsi_utils}/selection_buffer.irp.f (100%)
rename {plugins/local/cipsi_tc_bi_ortho => src/cipsi_utils}/selection_types.f90 (100%)
rename src/{cipsi => cipsi_utils}/selection_weight.irp.f (100%)
rename src/{cipsi => cipsi_utils}/slave_cipsi.irp.f (98%)
diff --git a/plugins/local/cipsi_tc_bi_ortho/energy.irp.f b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
index 16f4528e..3698e5c2 100644
--- a/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/energy.irp.f
@@ -15,37 +15,5 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
pt2_E0_denominator = eigval_right_tc_bi_orth
-! if (initialize_pt2_E0_denominator) then
-! if (h0_type == "EN") then
-! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
-! else if (h0_type == "HF") then
-! do i=1,N_states
-! j = maxloc(abs(psi_coef(:,i)),1)
-! pt2_E0_denominator(i) = psi_det_hii(j)
-! enddo
-! else if (h0_type == "Barycentric") then
-! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states)
-! else if (h0_type == "CFG") then
-! pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
-! else
-! print *, h0_type, ' not implemented'
-! stop
-! endif
-! do i=1,N_states
-! call write_double(6,pt2_E0_denominator(i)+nuclear_repulsion, 'PT2 Energy denominator')
-! enddo
-! else
-! pt2_E0_denominator = -huge(1.d0)
-! endif
-
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
- implicit none
- BEGIN_DOC
- ! Overlap between the perturbed wave functions
- END_DOC
- pt2_overlap(1:N_states,1:N_states) = 0.d0
END_PROVIDER
diff --git a/plugins/local/cipsi_tc_bi_ortho/environment.irp.f b/plugins/local/cipsi_tc_bi_ortho/environment.irp.f
deleted file mode 100644
index 5c0e0820..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/environment.irp.f
+++ /dev/null
@@ -1,14 +0,0 @@
-BEGIN_PROVIDER [ integer, nthreads_pt2 ]
- implicit none
- BEGIN_DOC
- ! Number of threads for Davidson
- END_DOC
- nthreads_pt2 = nproc
- character*(32) :: env
- call getenv('QP_NTHREADS_PT2',env)
- if (trim(env) /= '') then
- read(env,*) nthreads_pt2
- call write_int(6,nthreads_pt2,'Target number of threads for PT2')
- endif
-END_PROVIDER
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f b/plugins/local/cipsi_tc_bi_ortho/lock_2rdm.irp.f
deleted file mode 100644
index e69de29b..00000000
diff --git a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
deleted file mode 100644
index d4f45649..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/run_pt2_slave.irp.f
+++ /dev/null
@@ -1,546 +0,0 @@
- use omp_lib
- use selection_types
- use f77_zmq
-BEGIN_PROVIDER [ integer(omp_lock_kind), global_selection_buffer_lock ]
- use omp_lib
- implicit none
- BEGIN_DOC
- ! Global buffer for the OpenMP selection
- END_DOC
- call omp_init_lock(global_selection_buffer_lock)
-END_PROVIDER
-
-BEGIN_PROVIDER [ type(selection_buffer), global_selection_buffer ]
- use omp_lib
- implicit none
- BEGIN_DOC
- ! Global buffer for the OpenMP selection
- END_DOC
- call omp_set_lock(global_selection_buffer_lock)
- call delete_selection_buffer(global_selection_buffer)
- call create_selection_buffer(N_det_generators, 2*N_det_generators, &
- global_selection_buffer)
- call omp_unset_lock(global_selection_buffer_lock)
-END_PROVIDER
-
-
-subroutine run_pt2_slave(thread,iproc,energy)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- call run_pt2_slave_large(thread,iproc,energy)
-! if (N_det > 100000 ) 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)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, ctask, ltask
- character*(512), allocatable :: task(:)
- integer, allocatable :: task_id(:)
-
- 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
-
- type(selection_buffer) :: b
- logical :: done, buffer_ready
-
- type(pt2_type), allocatable :: pt2_data(:)
- integer :: n_tasks, k, N
- integer, allocatable :: i_generator(:), subset(:)
-
- double precision, external :: memory_of_double, memory_of_int
- integer :: bsize ! Size of selection buffers
-
- 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))
- 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)
-
- b%N = 0
- buffer_ready = .False.
- n_tasks = 1
-
- done = .False.
- do while (.not.done)
-
- n_tasks = max(1,n_tasks)
- n_tasks = min(pt2_n_tasks_max,n_tasks)
-
- integer, external :: get_tasks_from_taskserver
- if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
- exit
- endif
- done = task_id(n_tasks) == 0
- if (done) then
- n_tasks = n_tasks-1
- endif
- if (n_tasks == 0) exit
-
- do k=1,n_tasks
- call sscanf_ddd(task(k), subset(k), i_generator(k), N)
- enddo
- if (b%N == 0) then
- ! Only first time
- bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- call create_selection_buffer(bsize, bsize*2, b)
- buffer_ready = .True.
- else
- ASSERT (b%N == bsize)
- endif
-
- double precision :: time0, time1
- call wall_time(time0)
- do k=1,n_tasks
- call pt2_alloc(pt2_data(k),N_states)
- b%cur = 0
- call select_connected(i_generator(k),energy,pt2_data(k),b,subset(k),pt2_F(i_generator(k)))
- enddo
- 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 push_pt2_results(zmq_socket_push, i_generator, pt2_data, b, task_id, n_tasks)
- do k=1,n_tasks
- call pt2_dealloc(pt2_data(k))
- enddo
- b%cur=0
-
-! ! Try to adjust n_tasks around nproc/2 seconds per job
- n_tasks = min(2*n_tasks,int( dble(n_tasks * nproc/2) / (time1 - time0 + 1.d0)))
- n_tasks = min(n_tasks, pt2_n_tasks_max)
-! n_tasks = 1
- end do
-
- integer, external :: disconnect_from_taskserver
- do i=1,300
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
- call usleep(500)
- print *, 'Retry disconnect...'
- end do
-
- call end_zmq_push_socket(zmq_socket_push,thread)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- if (buffer_ready) then
- call delete_selection_buffer(b)
- endif
- deallocate(pt2_data)
-end subroutine
-
-
-subroutine run_pt2_slave_large(thread,iproc,energy)
- use selection_types
- use f77_zmq
- implicit none
-
- double precision, intent(in) :: energy(N_states_diag)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, ctask, ltask
- character*(512) :: task
- integer :: task_id(1)
-
- 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
-
- type(selection_buffer) :: b
- logical :: done, buffer_ready
-
- type(pt2_type) :: pt2_data
- integer :: n_tasks, k, N
- integer :: i_generator, subset
- integer :: ifirst
-
- integer :: bsize ! Size of selection buffers
- logical :: sending
- PROVIDE global_selection_buffer global_selection_buffer_lock
-
-
- 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)
-
- ifirst = 0
- b%N = 0
- buffer_ready = .False.
- n_tasks = 1
-
- sending = .False.
- done = .False.
- do while (.not.done)
-
- integer, external :: get_tasks_from_taskserver
- if (get_tasks_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task, n_tasks) == -1) then
- exit
- endif
- done = task_id(1) == 0
- if (done) then
- n_tasks = n_tasks-1
- endif
- if (n_tasks == 0) exit
-
- call sscanf_ddd(task, subset, i_generator, N)
- if( pt2_F(i_generator) <= 0 .or. pt2_F(i_generator) > N_det ) then
- print *, irp_here
- stop 'bug in selection'
- endif
- if (b%N == 0) then
- ! Only first time
- bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2)
- call create_selection_buffer(bsize, bsize*2, b)
- buffer_ready = .True.
- else
- 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 push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
- call omp_set_lock(global_selection_buffer_lock)
- global_selection_buffer%mini = b%mini
- call merge_selection_buffers(b,global_selection_buffer)
- if (ifirst /= 0 ) then
- b%cur=0
- else
- ifirst = 1
- endif
- 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
- call omp_unset_lock(global_selection_buffer_lock)
- else
- call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), b, (/task_id/), 1,sending)
- endif
-
- call pt2_dealloc(pt2_data)
- end do
- call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
-
- integer, external :: disconnect_from_taskserver
- do i=1,300
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) /= -2) exit
- call sleep(1)
- print *, 'Retry disconnect...'
- end do
-
- call end_zmq_push_socket(zmq_socket_push,thread)
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- if (buffer_ready) then
- call delete_selection_buffer(b)
- endif
- FREE global_selection_buffer
-end subroutine
-
-
-subroutine push_pt2_results(zmq_socket_push, index, pt2_data, b, task_id, n_tasks)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data(n_tasks)
- integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
- type(selection_buffer), intent(inout) :: b
-
- logical :: sending
- sending = .False.
- call push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending)
- call push_pt2_results_async_recv(zmq_socket_push, b%mini, sending)
-end subroutine
-
-
-subroutine push_pt2_results_async_send(zmq_socket_push, index, pt2_data, b, task_id, n_tasks, sending)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data(n_tasks)
- integer, intent(in) :: n_tasks, index(n_tasks), task_id(n_tasks)
- type(selection_buffer), intent(inout) :: b
- logical, intent(inout) :: sending
- integer :: rc, i
- integer*8 :: rc8
- double precision, allocatable :: pt2_serialized(:,:)
-
- if (sending) then
- print *, irp_here, ': sending is true'
- stop -1
- endif
- sending = .True.
-
- rc = f77_zmq_send( zmq_socket_push, n_tasks, 4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 1
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
-
- rc = f77_zmq_send( zmq_socket_push, index, 4*n_tasks, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 2
- return
- else if(rc /= 4*n_tasks) then
- stop 'push'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) )
- do i=1,n_tasks
- call pt2_serialize(pt2_data(i),N_states,pt2_serialized(1,i))
- enddo
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- deallocate(pt2_serialized)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
-
-
- rc = f77_zmq_send( zmq_socket_push, task_id, n_tasks*4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 6
- return
- else if(rc /= 4*n_tasks) then
- stop 'push'
- endif
-
-
- if (b%cur == 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 7
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
- else
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 7
- return
- else if(rc /= 4) then
- stop 'push'
- endif
-
-
- rc8 = f77_zmq_send8( zmq_socket_push, b%val, 8_8*int(b%cur,8), ZMQ_SNDMORE)
- if (rc8 == -1_8) then
- print *, irp_here, ': error sending result'
- stop 8
- return
- else if(rc8 /= 8_8*int(b%cur,8)) then
- stop 'push'
- endif
-
-
- rc8 = f77_zmq_send8( zmq_socket_push, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- print *, irp_here, ': error sending result'
- stop 9
- return
- else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
- stop 'push'
- endif
-
- endif
-
-end subroutine
-
-subroutine push_pt2_results_async_recv(zmq_socket_push,mini,sending)
- use selection_types
- use f77_zmq
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- double precision, intent(out) :: mini
- logical, intent(inout) :: sending
- integer :: rc
-
- if (.not.sending) return
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 10
- return
- else if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
- rc = f77_zmq_recv( zmq_socket_push, mini, 8, 0)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 11
- return
- else if (rc /= 8) then
- print *, irp_here//': error in receiving mini'
- stop 12
- endif
-IRP_ENDIF
- sending = .False.
-end subroutine
-
-
-
-subroutine pull_pt2_results(zmq_socket_pull, index, pt2_data, task_id, n_tasks, b)
- use selection_types
- use f77_zmq
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data(*)
- type(selection_buffer), intent(inout) :: b
- integer, intent(out) :: index(*)
- integer, intent(out) :: n_tasks, task_id(*)
- integer :: rc, rn, i
- integer*8 :: rc8
- double precision, allocatable :: pt2_serialized(:,:)
-
- rc = f77_zmq_recv( zmq_socket_pull, n_tasks, 4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4) then
- stop 'pull'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, index, 4*n_tasks, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4*n_tasks) then
- stop 'pull'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states),n_tasks) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized)*n_tasks, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- do i=1,n_tasks
- call pt2_deserialize(pt2_data(i),N_states,pt2_serialized(1,i))
- enddo
- deallocate(pt2_serialized)
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id, n_tasks*4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4*n_tasks) then
- stop 'pull'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, b%cur, 4, 0)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc /= 4) then
- stop 'pull'
- endif
-
- if (b%cur > 0) then
-
- rc8 = f77_zmq_recv8( zmq_socket_pull, b%val, 8_8*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc8 /= 8_8*int(b%cur,8)) then
- stop 'pull'
- endif
-
- rc8 = f77_zmq_recv8( zmq_socket_pull, b%det, int(bit_kind*N_int*2,8)*int(b%cur,8), 0)
- if (rc8 == -1_8) then
- n_tasks = 1
- task_id(1) = 0
- else if(rc8 /= int(N_int*2*8,8)*int(b%cur,8)) then
- stop 'pull'
- endif
-
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, ZMQ_SNDMORE)
- if (rc == -1) then
- n_tasks = 1
- task_id(1) = 0
- else if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
- rc = f77_zmq_send( zmq_socket_pull, b%mini, 8, 0)
-IRP_ENDIF
-
-end subroutine
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
index 39c83c4b..aaf2f31d 100644
--- a/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/run_selection_slave.irp.f
@@ -1,258 +1,5 @@
-subroutine run_selection_slave(thread, iproc, energy)
-
- use f77_zmq
- use selection_types
-
- implicit none
-
- double precision, intent(in) :: energy(N_states)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, task_id(1), ctask, ltask
- 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
-
- type(selection_buffer) :: buf, buf2
- logical :: done, buffer_ready
- type(pt2_type) :: pt2_data
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
- PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc weight_selection
-
- call pt2_alloc(pt2_data,N_states)
-
- 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)
-
- buf%N = 0
- buffer_ready = .False.
- ctask = 1
-
- do
- integer, external :: get_task_from_taskserver
- if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
- exit
- endif
- done = task_id(ctask) == 0
- if (done) then
- ctask = ctask - 1
- else
- integer :: i_generator, N, subset, bsize
- call sscanf_ddd(task, subset, i_generator, N)
- if(buf%N == 0) then
- ! Only first time
- call create_selection_buffer(N, N*2, buf)
- buffer_ready = .True.
- else
- if (N /= buf%N) then
- print *, 'N=', N
- print *, 'buf%N=', buf%N
- print *, 'bug in ', irp_here
- stop '-1'
- end if
- end if
- call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
- endif
-
- integer, external :: task_done_to_taskserver
-
- if(done .or. ctask == size(task_id)) then
- do i=1, ctask
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- call usleep(100)
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- ctask = 0
- done = .true.
- exit
- endif
- endif
- end do
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
- call pt2_dealloc(pt2_data)
- call pt2_alloc(pt2_data,N_states)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- end if
-
- if(done) exit
- ctask = ctask + 1
- end do
-
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- call pt2_dealloc(pt2_data)
-
- integer, external :: disconnect_from_taskserver
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
- continue
- endif
-
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- call end_zmq_push_socket(zmq_socket_push,thread)
- if (buffer_ready) then
- call delete_selection_buffer(buf)
-! call delete_selection_buffer(buf2)
- endif
-end subroutine
-
-
-subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: ntasks, task_id(*)
- integer :: rc
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- call pt2_serialize(pt2_data,N_states,pt2_serialized)
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
- deallocate(pt2_serialized)
-
- if (b%cur > 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
- if(rc /= 8*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
- if(rc /= bit_kind*N_int*2*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
- endif
-
- endif
-
- rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
-IRP_ENDIF
-
-end subroutine
-
-
-subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data
- double precision, intent(out) :: val(*)
- integer(bit_kind), intent(out) :: det(N_int, 2, *)
- integer, intent(out) :: N, ntasks, task_id(*)
- integer :: rc, rn, i
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
- if (rc == -1) then
- ntasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- call pt2_deserialize(pt2_data,N_states,pt2_serialized)
- deallocate(pt2_serialized)
-
- if (N>0) then
- rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
- if(rc /= 8*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
- if(rc /= bit_kind*N_int*2*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
- endif
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
- if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
-IRP_ENDIF
-end subroutine
-
-
+subroutine provide_for_selection_slave
+ PROVIDE psi_det_sorted_tc_order
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc
+end
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 06cf848b..9b8cc81e 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -76,6 +76,8 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
double precision, allocatable :: fock_diag_tmp(:,:)
+ if (csubset == 0) return
+
allocate(fock_diag_tmp(2,mo_num+1))
call build_fock_tmp_tc(fock_diag_tmp, psi_det_generators(1,1,i_generator), N_int)
@@ -86,10 +88,13 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part), not(psi_det_generators(k,1,i_generator)) )
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part), not(psi_det_generators(k,2,i_generator)) )
enddo
+ if ((subset == 1).and.(sum(hole_mask(:,2)) == 0_bit_kind)) then
+ ! No beta electron to excite
+ call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b)
+ endif
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b,subset,csubset)
deallocate(fock_diag_tmp)
-end subroutine select_connected
-
+end subroutine
double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
@@ -136,7 +141,7 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
end
-subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
+subroutine select_singles_and_doubles(i_generator, hole_mask, particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
use bitmasks
use selection_types
implicit none
@@ -151,8 +156,6 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
- double precision, parameter :: norm_thr = 1.d-16
-
integer :: h1, h2, s1, s2, s3, i1, i2, ib, sp, k, i, j, nt, ii, sze
integer :: maskInd
integer :: N_holes(2), N_particles(2)
@@ -170,6 +173,7 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
integer, allocatable :: preinteresting(:), prefullinteresting(:)
integer, allocatable :: interesting(:), fullinteresting(:)
integer, allocatable :: tmp_array(:)
+
integer, allocatable :: indices(:), exc_degree(:), iorder(:)
integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
@@ -178,15 +182,16 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order psi_bilinear_matrix_transp_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_tc
+ PROVIDE psi_selectors_coef_transp_tc psi_det_sorted_tc_order
PROVIDE banned_excitation
monoAdo = .true.
monoBdo = .true.
+ if (csubset == 0) return
do k=1,N_int
hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1))
@@ -198,7 +203,11 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
- allocate( indices(N_det), exc_degree( max(N_det_alpha_unique, N_det_beta_unique) ) )
+ ! Removed to avoid introducing determinants already presents in the wf
+ !double precision, parameter :: norm_thr = 1.d-16
+
+ allocate (indices(N_det), &
+ exc_degree(max(N_det_alpha_unique,N_det_beta_unique)))
! Pre-compute excitation degrees wrt alpha determinants
k=1
@@ -214,73 +223,76 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
if (nt > 2) cycle
do l_a=psi_bilinear_matrix_columns_loc(j), psi_bilinear_matrix_columns_loc(j+1)-1
i = psi_bilinear_matrix_rows(l_a)
- if(nt + exc_degree(i) <= 4) then
+ if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_tc_order(psi_bilinear_matrix_order(l_a))
-! if (psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
+ ! Removed to avoid introducing determinants already presents in the wf
+ !if (psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
indices(k) = idx
- k = k + 1
-! endif
+ k=k+1
+ !endif
endif
enddo
enddo
! Pre-compute excitation degrees wrt beta determinants
do i=1,N_det_beta_unique
- call get_excitation_degree_spin(psi_det_beta_unique(1,i), psi_det_generators(1,2,i_generator), exc_degree(i), N_int)
+ call get_excitation_degree_spin(psi_det_beta_unique(1,i), &
+ psi_det_generators(1,2,i_generator), exc_degree(i), N_int)
enddo
! Iterate on 0S alpha, and find betas TQ such that exc_degree <= 4
- ! Remove also contributions < 1.d-20)
do j=1,N_det_alpha_unique
- call get_excitation_degree_spin(psi_det_alpha_unique(1,j), psi_det_generators(1,1,i_generator), nt, N_int)
+ call get_excitation_degree_spin(psi_det_alpha_unique(1,j), &
+ psi_det_generators(1,1,i_generator), nt, N_int)
if (nt > 1) cycle
- do l_a = psi_bilinear_matrix_transp_rows_loc(j), psi_bilinear_matrix_transp_rows_loc(j+1)-1
+ do l_a=psi_bilinear_matrix_transp_rows_loc(j), psi_bilinear_matrix_transp_rows_loc(j+1)-1
i = psi_bilinear_matrix_transp_columns(l_a)
- if(exc_degree(i) < 3) cycle
- if(nt + exc_degree(i) <= 4) then
+ if (exc_degree(i) < 3) cycle
+ if (nt + exc_degree(i) <= 4) then
idx = psi_det_sorted_tc_order( &
psi_bilinear_matrix_order( &
psi_bilinear_matrix_transp_order(l_a)))
-! if(psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
+ ! Removed to avoid introducing determinants already presents in the wf
+ !if(psi_average_norm_contrib_sorted_tc(idx) > norm_thr) then
indices(k) = idx
- k = k + 1
-! endif
+ k=k+1
+ !endif
endif
enddo
enddo
deallocate(exc_degree)
- nmax = k - 1
+ 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))
+ allocate(preinteresting(0:32), prefullinteresting(0:32), &
+ interesting(0:32), fullinteresting(0:32))
preinteresting(:) = 0
prefullinteresting(:) = 0
- do i = 1, N_int
+ do i=1,N_int
negMask(i,1) = not(psi_det_generators(i,1,i_generator))
negMask(i,2) = not(psi_det_generators(i,2,i_generator))
- enddo
-
- do k = 1, nmax
+ end do
+ do k=1,nmax
i = indices(k)
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i))
mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2))
- do j = 2, N_int
+ do j=2,N_int
mobMask(j,1) = iand(negMask(j,1), psi_det_sorted_tc(j,1,i))
mobMask(j,2) = iand(negMask(j,2), psi_det_sorted_tc(j,2,i))
nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2))
- enddo
+ end do
if(nt <= 4) then
if(i <= N_det_selectors) then
sze = preinteresting(0)
- if(sze+1 == size(preinteresting)) then
- allocate(tmp_array(0:sze))
+ if (sze+1 == size(preinteresting)) then
+ allocate (tmp_array(0:sze))
tmp_array(0:sze) = preinteresting(0:sze)
deallocate(preinteresting)
allocate(preinteresting(0:2*sze))
@@ -289,9 +301,9 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
preinteresting(0) = sze+1
preinteresting(sze+1) = i
- elseif(nt <= 2) then
+ else if(nt <= 2) then
sze = prefullinteresting(0)
- if(sze+1 == size(prefullinteresting)) then
+ if (sze+1 == size(prefullinteresting)) then
allocate (tmp_array(0:sze))
tmp_array(0:sze) = prefullinteresting(0:sze)
deallocate(prefullinteresting)
@@ -301,20 +313,16 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
prefullinteresting(0) = sze+1
prefullinteresting(sze+1) = i
- endif
- endif
-
- enddo
+ end if
+ end if
+ end do
deallocate(indices)
- allocate( banned(mo_num, mo_num,2), bannedOrb(mo_num, 2) )
- allocate( mat(N_states, mo_num, mo_num) )
- allocate( mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num) )
+ allocate(banned(mo_num, mo_num,2), bannedOrb(mo_num, 2))
+ allocate(mat(N_states, mo_num, mo_num))
+ allocate(mat_l(N_states, mo_num, mo_num), mat_r(N_states, mo_num, mo_num))
maskInd = -1
-
-
-
do s1 = 1, 2
do i1 = N_holes(s1), 1, -1 ! Generate low excitations first
@@ -347,17 +355,17 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
do ii = 1, preinteresting(0)
i = preinteresting(ii)
- select case(N_int)
- case(1)
+ select case (N_int)
+ case (1)
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted_tc(1,1,i))
mobMask(1,2) = iand(negMask(1,2), psi_det_sorted_tc(1,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2))
- case(2)
+ case (2)
mobMask(1:2,1) = iand(negMask(1:2,1), psi_det_sorted_tc(1:2,1,i))
mobMask(1:2,2) = iand(negMask(1:2,2), psi_det_sorted_tc(1:2,2,i))
nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + &
popcnt(mobMask(2, 1)) + popcnt(mobMask(2, 2))
- case(3)
+ case (3)
mobMask(1:3,1) = iand(negMask(1:3,1), psi_det_sorted_tc(1:3,1,i))
mobMask(1:3,2) = iand(negMask(1:3,2), psi_det_sorted_tc(1:3,2,i))
nt = 0
@@ -370,8 +378,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
- case(4)
+ end do
+ case (4)
mobMask(1:4,1) = iand(negMask(1:4,1), psi_det_sorted_tc(1:4,1,i))
mobMask(1:4,2) = iand(negMask(1:4,2), psi_det_sorted_tc(1:4,2,i))
nt = 0
@@ -384,7 +392,7 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
+ end do
case default
mobMask(1:N_int,1) = iand(negMask(1:N_int,1), psi_det_sorted_tc(1:N_int,1,i))
mobMask(1:N_int,2) = iand(negMask(1:N_int,2), psi_det_sorted_tc(1:N_int,2,i))
@@ -398,12 +406,12 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
nt = nt+ popcnt(mobMask(j, 2))
if (nt > 4) exit
endif
- enddo
+ end do
end select
if(nt <= 4) then
sze = interesting(0)
- if(sze+1 == size(interesting)) then
+ if (sze+1 == size(interesting)) then
allocate (tmp_array(0:sze))
tmp_array(0:sze) = interesting(0:sze)
deallocate(interesting)
@@ -425,8 +433,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
fullinteresting(0) = sze+1
fullinteresting(sze+1) = i
- endif
- endif
+ end if
+ end if
enddo
@@ -456,10 +464,10 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
endif
fullinteresting(0) = sze+1
fullinteresting(sze+1) = i
- endif
- enddo
- allocate( fullminilist (N_int, 2, fullinteresting(0)), &
- minilist (N_int, 2, interesting(0)) )
+ end if
+ end do
+ allocate (fullminilist (N_int, 2, fullinteresting(0)), &
+ minilist (N_int, 2, interesting(0)) )
do i = 1, fullinteresting(0)
do k = 1, N_int
@@ -517,7 +525,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting, mat_l, mat_r)
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf, mat_l, mat_r)
- endif
+ end if
+
enddo
@@ -533,7 +542,8 @@ subroutine select_singles_and_doubles(i_generator, hole_mask,particle_mask, fock
deallocate(banned, bannedOrb,mat)
deallocate(mat_l, mat_r)
-end subroutine select_singles_and_doubles
+
+end subroutine
! ---
@@ -924,13 +934,13 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
print*,i_h_alpha,alpha_h_i
- call debug_det(psi_selectors(1,1,iii),N_int)
- enddo
+ call debug_det(psi_selectors(1,1,iii),N_int)
+ enddo
! print*,'psi_det '
! do iii = 1, N_det! old version
! print*,'iii',iii,psi_l_coef_bi_ortho(iii,1),psi_r_coef_bi_ortho(iii,1)
-! call debug_det(psi_det(1,1,iii),N_int)
-! enddo
+! call debug_det(psi_det(1,1,iii),N_int)
+! enddo
stop
endif
endif
@@ -938,7 +948,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
psi_h_alpha = mat_l(istate, p1, p2)
alpha_h_psi = mat_r(istate, p1, p2)
endif
- val = 4.d0 * psi_h_alpha * alpha_h_psi
+ val = 4.d0 * psi_h_alpha * alpha_h_psi
tmp = dsqrt(delta_E * delta_E + val)
! if (delta_E < 0.d0) then
! tmp = -tmp
@@ -946,21 +956,21 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
e_pert(istate) = 0.25 * val / delta_E
! e_pert(istate) = 0.5d0 * (tmp - delta_E)
if(dsqrt(dabs(tmp)).gt.1.d-4.and.dabs(alpha_h_psi).gt.1.d-4)then
- coef(istate) = e_pert(istate) / psi_h_alpha
+ coef(istate) = e_pert(istate) / psi_h_alpha
else
- coef(istate) = alpha_h_psi / delta_E
+ coef(istate) = alpha_h_psi / delta_E
endif
if(selection_tc == 1)then
- if(e_pert(istate).lt.0.d0)then
+ if(e_pert(istate).lt.0.d0)then
e_pert(istate)=0.d0
- else
+ else
e_pert(istate)=-e_pert(istate)
endif
else if(selection_tc == -1)then
if(e_pert(istate).gt.0.d0)e_pert(istate)=0.d0
endif
-
+
! if(selection_tc == 1 )then
! if(e_pert(istate).lt.0.d0)then
! e_pert(istate) = 0.d0
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
deleted file mode 100644
index 0bd51464..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/selection_buffer.irp.f
+++ /dev/null
@@ -1,424 +0,0 @@
-
-subroutine create_selection_buffer(N, size_in, res)
- use selection_types
- implicit none
- BEGIN_DOC
-! Allocates the memory for a selection buffer.
-! The arrays have dimension size_in and the maximum number of elements is N
- END_DOC
-
- integer, intent(in) :: N, size_in
- type(selection_buffer), intent(out) :: res
-
- integer :: siz
- siz = max(size_in,1)
-
- double precision :: rss
- double precision, external :: memory_of_double
- rss = memory_of_double(siz)*(N_int*2+1)
- call check_mem(rss,irp_here)
-
- allocate(res%det(N_int, 2, siz), res%val(siz))
-
- res%val(:) = 0d0
- res%det(:,:,:) = 0_8
- res%N = N
- res%mini = 0d0
- res%cur = 0
-end subroutine
-
-subroutine delete_selection_buffer(b)
- use selection_types
- implicit none
- type(selection_buffer), intent(inout) :: b
- if (associated(b%det)) then
- deallocate(b%det)
- endif
- if (associated(b%val)) then
- deallocate(b%val)
- endif
- NULLIFY(b%det)
- NULLIFY(b%val)
- b%cur = 0
- b%mini = 0.d0
- b%N = 0
-end
-
-
-subroutine add_to_selection_buffer(b, det, val)
- use selection_types
- implicit none
-
- type(selection_buffer), intent(inout) :: b
- integer(bit_kind), intent(in) :: det(N_int, 2)
- double precision, intent(in) :: val
- integer :: i
-
- if(b%N > 0 .and. val <= b%mini) then
- b%cur += 1
- b%det(1:N_int,1:2,b%cur) = det(1:N_int,1:2)
- b%val(b%cur) = val
- if(b%cur == size(b%val)) then
- call sort_selection_buffer(b)
- end if
- end if
-end subroutine
-
-subroutine merge_selection_buffers(b1, b2)
- use selection_types
- implicit none
- BEGIN_DOC
-! Merges the selection buffers b1 and b2 into b2
- END_DOC
- type(selection_buffer), intent(inout) :: b1
- type(selection_buffer), intent(inout) :: b2
- integer(bit_kind), pointer :: detmp(:,:,:)
- double precision, pointer :: val(:)
- integer :: i, i1, i2, k, nmwen, sze
- if (b1%cur == 0) return
- do while (b1%val(b1%cur) > b2%mini)
- b1%cur = b1%cur-1
- if (b1%cur == 0) then
- return
- endif
- enddo
- nmwen = min(b1%N, b1%cur+b2%cur)
- 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)
- allocate(val(sze), detmp(N_int, 2, sze))
- i1=1
- i2=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
- 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
- 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
-! if(selection_tc == 1)then
-! b2%mini = max(b2%mini,b2%val(b2%N))
-! else
- b2%mini = min(b2%mini,b2%val(b2%N))
-! endif
- b2%cur = nmwen
-end
-
-
-subroutine sort_selection_buffer(b)
- use selection_types
- implicit none
-
- type(selection_buffer), intent(inout) :: b
- integer, allocatable :: iorder(:)
- integer(bit_kind), pointer :: detmp(:,:,:)
- integer :: i, nmwen
- logical, external :: detEq
- if (b%N == 0 .or. b%cur == 0) return
- nmwen = min(b%N, b%cur)
-
- 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)
- allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)))
- do i=1,b%cur
- iorder(i) = i
- end do
- call dsort(b%val, iorder, b%cur)
- do i=1, nmwen
- detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i))
- detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i))
- end do
- deallocate(b%det,iorder)
- b%det => detmp
-! if(selection_tc == 1)then
-! b%mini = max(b%mini,b%val(b%N))
-! else
- b%mini = min(b%mini,b%val(b%N))
-! endif
- b%cur = nmwen
-end subroutine
-
-subroutine make_selection_buffer_s2(b)
- use selection_types
- type(selection_buffer), intent(inout) :: b
-
- integer(bit_kind), allocatable :: o(:,:,:)
- double precision, allocatable :: val(:)
-
- integer :: n_d
- integer :: i,k,sze,n_alpha,j,n
- logical :: dup
-
- ! Sort
- integer, allocatable :: iorder(:)
- integer*8, allocatable :: bit_tmp(:)
- integer*8, external :: configuration_search_key
- integer(bit_kind), allocatable :: tmp_array(:,:,:)
- logical, allocatable :: duplicate(:)
-
- n_d = b%cur
- double precision :: rss
- double precision, external :: memory_of_double
- rss = (4*N_int+4)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
- allocate(o(N_int,2,n_d), iorder(n_d), duplicate(n_d), bit_tmp(n_d), &
- tmp_array(N_int,2,n_d), val(n_d) )
-
- do i=1,n_d
- do k=1,N_int
- o(k,1,i) = ieor(b%det(k,1,i), b%det(k,2,i))
- o(k,2,i) = iand(b%det(k,1,i), b%det(k,2,i))
- enddo
- iorder(i) = i
- bit_tmp(i) = configuration_search_key(o(1,1,i),N_int)
- enddo
-
- deallocate(b%det)
-
- call i8sort(bit_tmp,iorder,n_d)
-
- do i=1,n_d
- do k=1,N_int
- tmp_array(k,1,i) = o(k,1,iorder(i))
- tmp_array(k,2,i) = o(k,2,iorder(i))
- enddo
- val(i) = b%val(iorder(i))
- duplicate(i) = .False.
- enddo
-
- ! Find duplicates
- do i=1,n_d-1
- if (duplicate(i)) then
- cycle
- endif
- j = i+1
- do while (bit_tmp(j)==bit_tmp(i))
- if (duplicate(j)) then
- j+=1
- if (j>n_d) then
- exit
- endif
- cycle
- 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
- dup = .False.
- exit
- endif
- enddo
- if (dup) then
- val(i) = max(val(i), val(j))
- duplicate(j) = .True.
- endif
- j+=1
- if (j>n_d) then
- exit
- endif
- enddo
- enddo
-
- deallocate (b%val)
- ! Copy filtered result
- integer :: n_p
- n_p=0
- do i=1,n_d
- if (duplicate(i)) then
- cycle
- endif
- n_p = n_p + 1
- do k=1,N_int
- o(k,1,n_p) = tmp_array(k,1,i)
- o(k,2,n_p) = tmp_array(k,2,i)
- enddo
- val(n_p) = val(i)
- enddo
-
- ! Sort by importance
- do i=1,n_p
- iorder(i) = i
- end do
- call dsort(val,iorder,n_p)
- do i=1,n_p
- do k=1,N_int
- tmp_array(k,1,i) = o(k,1,iorder(i))
- tmp_array(k,2,i) = o(k,2,iorder(i))
- enddo
- enddo
- do i=1,n_p
- do k=1,N_int
- o(k,1,i) = tmp_array(k,1,i)
- o(k,2,i) = tmp_array(k,2,i)
- enddo
- enddo
-
- ! Create determinants
- n_d = 0
- do i=1,n_p
- 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
-
- rss = (4*N_int+2)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
- allocate(b%det(N_int,2,2*n_d), b%val(2*n_d))
- k=1
- do i=1,n_p
- n=n_d
- call configuration_to_dets_size(o(1,1,i),n,elec_alpha_num,N_int)
- call configuration_to_dets(o(1,1,i),b%det(1,1,k),n,elec_alpha_num,N_int)
- do j=k,k+n-1
- b%val(j) = val(i)
- enddo
- k = k+n
- if (k > n_d) exit
- enddo
- deallocate(o)
- b%cur = n_d
- b%N = n_d
-end
-
-
-
-
-subroutine remove_duplicates_in_selection_buffer(b)
- use selection_types
- type(selection_buffer), intent(inout) :: b
-
- integer(bit_kind), allocatable :: o(:,:,:)
- double precision, allocatable :: val(:)
-
- integer :: n_d
- integer :: i,k,sze,n_alpha,j,n
- logical :: dup
-
- ! Sort
- integer, allocatable :: iorder(:)
- integer*8, allocatable :: bit_tmp(:)
- integer*8, external :: det_search_key
- 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
- rss = (4*N_int+4)*memory_of_double(n_d)
- call check_mem(rss,irp_here)
-
- found_duplicates = .False.
- allocate(iorder(n_d), duplicate(n_d), bit_tmp(n_d), &
- tmp_array(N_int,2,n_d), val(n_d) )
-
- do i=1,n_d
- iorder(i) = i
- bit_tmp(i) = det_search_key(b%det(1,1,i),N_int)
- enddo
-
- call i8sort(bit_tmp,iorder,n_d)
-
- do i=1,n_d
- do k=1,N_int
- tmp_array(k,1,i) = b%det(k,1,iorder(i))
- tmp_array(k,2,i) = b%det(k,2,iorder(i))
- enddo
- val(i) = b%val(iorder(i))
- duplicate(i) = .False.
- enddo
-
- ! Find duplicates
- do i=1,n_d-1
- if (duplicate(i)) then
- cycle
- endif
- j = i+1
- do while (bit_tmp(j)==bit_tmp(i))
- if (duplicate(j)) then
- j+=1
- if (j>n_d) then
- exit
- endif
- cycle
- 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
- dup = .False.
- exit
- endif
- enddo
- if (dup) then
- duplicate(j) = .True.
- found_duplicates = .True.
- endif
- j+=1
- if (j>n_d) then
- exit
- endif
- enddo
- enddo
-
- if (found_duplicates) then
-
- ! Copy filtered result
- integer :: n_p
- n_p=0
- do i=1,n_d
- if (duplicate(i)) then
- cycle
- endif
- n_p = n_p + 1
- do k=1,N_int
- b%det(k,1,n_p) = tmp_array(k,1,i)
- b%det(k,2,n_p) = tmp_array(k,2,i)
- enddo
- val(n_p) = val(i)
- enddo
- b%cur=n_p
- b%N=n_p
-
- endif
-
-end
-
-
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
deleted file mode 100644
index 3c09e59a..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/selection_weight.irp.f
+++ /dev/null
@@ -1,134 +0,0 @@
-BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights adjusted along the selection to make the PT2 contributions
- ! of each state coincide.
- END_DOC
- pt2_match_weight(:) = 1.d0
-END_PROVIDER
-
-
-
-BEGIN_PROVIDER [ double precision, variance_match_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights adjusted along the selection to make the variances
- ! of each state coincide.
- END_DOC
- variance_match_weight(:) = 1.d0
-END_PROVIDER
-
-
-
-subroutine update_pt2_and_variance_weights(pt2_data, N_st)
- implicit none
- use selection_types
- BEGIN_DOC
-! Updates the PT2- and Variance- matching weights.
- END_DOC
- integer, intent(in) :: N_st
- type(pt2_type), intent(in) :: pt2_data
- double precision :: pt2(N_st)
- double precision :: variance(N_st)
-
- double precision :: avg, element, dt, x
- integer :: k
- pt2(:) = pt2_data % pt2(:)
- variance(:) = pt2_data % variance(:)
-
- avg = sum(pt2(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
-
- dt = 8.d0 !* selection_factor
- do k=1,N_st
- element = exp(dt*(pt2(k)/avg - 1.d0))
- element = min(2.0d0 , element)
- element = max(0.5d0 , element)
- pt2_match_weight(k) *= element
- enddo
-
-
- avg = sum(variance(1:N_st)) / dble(N_st) + 1.d-32 ! Avoid future division by zero
-
- do k=1,N_st
- element = exp(dt*(variance(k)/avg -1.d0))
- element = min(2.0d0 , element)
- element = max(0.5d0 , element)
- variance_match_weight(k) *= element
- enddo
-
- if (N_det < 100) then
- ! For tiny wave functions, weights are 1.d0
- pt2_match_weight(:) = 1.d0
- variance_match_weight(:) = 1.d0
- endif
-
- threshold_davidson_pt2 = min(1.d-6, &
- max(threshold_davidson, 1.e-1 * PT2_relative_error * minval(abs(pt2(1:N_states)))) )
-
- SOFT_TOUCH pt2_match_weight variance_match_weight threshold_davidson_pt2
-end
-
-
-
-
-BEGIN_PROVIDER [ double precision, selection_weight, (N_states) ]
- implicit none
- BEGIN_DOC
- ! Weights used in the selection criterion
- END_DOC
- select case (weight_selection)
-
- case (0)
- print *, 'Using input weights in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * state_average_weight(1:N_states)
-
- case (1)
- print *, 'Using 1/c_max^2 weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states)
-
- case (2)
- 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)
-
- case (3)
- print *, 'Using variance-matching weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (4)
- 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)
-
- case (5)
- print *, 'Using variance-matching weight in selection'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- case (6)
- print *, 'Using CI coefficient-based selection'
- selection_weight(1:N_states) = c0_weight(1:N_states)
-
- case (7)
- 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)
-
- case (8)
- print *, 'Input weights multiplied by pt2-matching'
- selection_weight(1:N_states) = c0_weight(1:N_states) * pt2_match_weight(1:N_states) * state_average_weight(1:N_states)
- print *, '# PT2 weight ', real(pt2_match_weight(:),4)
-
- case (9)
- print *, 'Input weights multiplied by variance-matching'
- selection_weight(1:N_states) = c0_weight(1:N_states) * variance_match_weight(1:N_states) * state_average_weight(1:N_states)
- print *, '# var weight ', real(variance_match_weight(:),4)
-
- end select
- print *, '# Total weight ', real(selection_weight(:),4)
-
-END_PROVIDER
-
diff --git a/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
deleted file mode 100644
index 6343bf8b..00000000
--- a/plugins/local/cipsi_tc_bi_ortho/slave_cipsi.irp.f
+++ /dev/null
@@ -1,348 +0,0 @@
-subroutine run_slave_cipsi
-
- BEGIN_DOC
- ! Helper program for distributed parallelism
- END_DOC
-
- implicit none
-
- call omp_set_max_active_levels(1)
- distributed_davidson = .False.
- read_wf = .False.
- SOFT_TOUCH read_wf distributed_davidson
- call provide_everything
- call switch_qp_run_to_master
- call run_slave_main
-end
-
-subroutine provide_everything
- PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
-
- PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
- PROVIDE psi_det psi_coef threshold_generators state_average_weight
- PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
-end
-
-
-subroutine run_slave_main
-
- use f77_zmq
-
- implicit none
- IRP_IF MPI
- include 'mpif.h'
- IRP_ENDIF
-
- integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
- integer(ZMQ_PTR) :: zmq_to_qp_run_socket
- double precision :: energy(N_states)
- character*(64) :: states(10)
- character*(64) :: old_state
- integer :: rc, i, ierr
- double precision :: t0, t1
-
- integer, external :: zmq_get_dvector, zmq_get_N_det_generators
- integer, external :: zmq_get8_dvector
- integer, external :: zmq_get_ivector
- integer, external :: zmq_get_psi, zmq_get_N_det_selectors, zmq_get_psi_bilinear
- integer, external :: zmq_get_psi_notouch
- integer, external :: zmq_get_N_states_diag
-
- zmq_context = f77_zmq_ctx_new ()
- states(1) = 'selection'
- states(2) = 'davidson'
- states(3) = 'pt2'
- old_state = 'Waiting'
-
- zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
-
- PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
- PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
- PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- IRP_ENDIF
- do
-
- if (mpi_master) then
- call wait_for_states(states,zmq_state,size(states))
- if (zmq_state(1:64) == old_state(1:64)) then
- call usleep(200)
- cycle
- else
- old_state(1:64) = zmq_state(1:64)
- endif
- print *, trim(zmq_state)
- endif
-
- IRP_IF MPI_DEBUG
- print *, irp_here, mpi_rank
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- IRP_ENDIF
- IRP_IF MPI
- call MPI_BCAST (zmq_state, 128, MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in broadcast of zmq_state'
- endif
- IRP_ENDIF
-
- if(zmq_state(1:7) == 'Stopped') then
- exit
- endif
-
-
- if (zmq_state(1:9) == 'selection') then
-
- ! Selection
- ! ---------
-
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector threshold_generators')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector energy')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_generators')
- IRP_ENDIF
- if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_selectors')
- IRP_ENDIF
- if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector state_average_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector selection_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle
- pt2_e0_denominator(1:N_states) = energy(1:N_states)
- TOUCH pt2_e0_denominator state_average_weight threshold_generators selection_weight psi_det psi_coef
-
- if (mpi_master) then
- print *, 'N_det', N_det
- print *, 'N_det_generators', N_det_generators
- print *, 'N_det_selectors', N_det_selectors
- print *, 'pt2_e0_denominator', pt2_e0_denominator
- print *, 'pt2_stoch_istate', pt2_stoch_istate
- print *, 'state_average_weight', state_average_weight
- print *, 'selection_weight', selection_weight
- endif
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
-
- IRP_IF MPI_DEBUG
- call mpi_print('Entering OpenMP section')
- IRP_ENDIF
- !$OMP PARALLEL PRIVATE(i)
- i = omp_get_thread_num()
- call run_selection_slave(0,i,energy)
- !$OMP END PARALLEL
- print *, mpi_rank, ': Selection done'
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- else if (zmq_state(1:8) == 'davidson') then
-
- ! Davidson
- ! --------
-
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_states_diag')
- IRP_ENDIF
- if (zmq_get_N_states_diag(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
-
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
-
- !---
- call omp_set_max_active_levels(8)
- call davidson_slave_tcp(0)
- call omp_set_max_active_levels(1)
- print *, mpi_rank, ': Davidson done'
- !---
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- else if (zmq_state(1:3) == 'pt2') then
-
- ! PT2
- ! ---
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call wall_time(t0)
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_psi')
- IRP_ENDIF
- if (zmq_get_psi(zmq_to_qp_run_socket,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_generators')
- IRP_ENDIF
- if (zmq_get_N_det_generators (zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_N_det_selectors')
- IRP_ENDIF
- if (zmq_get_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector threshold_generators')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector energy')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'energy',energy,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_ivector pt2_stoch_istate')
- IRP_ENDIF
- if (zmq_get_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector state_average_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) cycle
- IRP_IF MPI_DEBUG
- call mpi_print('zmq_get_dvector selection_weight')
- IRP_ENDIF
- if (zmq_get_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) cycle
- pt2_e0_denominator(1:N_states) = energy(1:N_states)
- SOFT_TOUCH pt2_e0_denominator state_average_weight pt2_stoch_istate threshold_generators selection_weight psi_det psi_coef N_det_generators N_det_selectors
-
-
- call wall_time(t1)
- call write_double(6,(t1-t0),'Broadcast time')
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
-
-
- IRP_IF MPI_DEBUG
- call mpi_print('Entering OpenMP section')
- IRP_ENDIF
- if (.true.) then
- integer :: nproc_target, ii
- double precision :: mem_collector, mem, rss
-
- call resident_memory(rss)
-
- nproc_target = nthreads_pt2
- ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
-
- do
- mem = rss + & !
- nproc_target * 8.d0 * & ! bytes
- ( 0.5d0*pt2_n_tasks_max & ! task_id
- + 64.d0*pt2_n_tasks_max & ! task
- + 3.d0*pt2_n_tasks_max*N_states & ! pt2, variance, norm
- + 1.d0*pt2_n_tasks_max & ! i_generator, subset
- + 3.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
- + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
- + 2.0d0*(ii) & ! preinteresting, interesting,
- ! prefullinteresting, fullinteresting
- + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
- + 1.0d0*(N_states*mo_num*mo_num) & ! mat
- ) / 1024.d0**3
-
- if (nproc_target == 0) then
- call check_mem(mem,irp_here)
- nproc_target = 1
- exit
- endif
-
- if (mem+rss < qp_max_mem) then
- exit
- endif
-
- nproc_target = nproc_target - 1
-
- enddo
-
- if (N_det > 100000) then
-
- if (mpi_master) then
- print *, 'N_det', N_det
- print *, 'N_det_generators', N_det_generators
- print *, 'N_det_selectors', N_det_selectors
- print *, 'pt2_e0_denominator', pt2_e0_denominator
- print *, 'pt2_stoch_istate', pt2_stoch_istate
- print *, 'state_average_weight', state_average_weight
- print *, 'selection_weight', selection_weight
- print *, 'Number of threads', nproc_target
- endif
-
- if (h0_type == 'CFG') then
- PROVIDE det_to_configuration
- endif
-
- PROVIDE global_selection_buffer pt2_N_teeth pt2_F N_det_generators
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_tc_order psi_bilinear_matrix_order
- 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_tc
-
- PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks
-
- if (mpi_master) then
- print *, 'Running PT2'
- endif
- !$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
- FREE state_average_weight
- print *, mpi_rank, ': PT2 done'
- print *, '-------'
-
- endif
- endif
-
- IRP_IF MPI
- call MPI_BARRIER(MPI_COMM_WORLD, ierr)
- if (ierr /= MPI_SUCCESS) then
- print *, irp_here, 'error in barrier'
- endif
- IRP_ENDIF
- call mpi_print('----------')
-
- endif
-
- end do
- IRP_IF MPI
- call MPI_finalize(ierr)
- IRP_ENDIF
-end
-
-
-
diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f
index cf770049..446e8d87 100644
--- a/src/cipsi/cipsi.irp.f
+++ b/src/cipsi/cipsi.irp.f
@@ -1,10 +1,13 @@
subroutine run_cipsi
- implicit none
- use selection_types
+
BEGIN_DOC
-! Selected Full Configuration Interaction with deterministic selection and
-! stochastic PT2.
+ ! Selected Full Configuration Interaction with deterministic selection and
+ ! stochastic PT2.
END_DOC
+
+ use selection_types
+
+ implicit none
integer :: i,j,k
type(pt2_type) :: pt2_data, pt2_data_err
double precision, allocatable :: zeros(:)
diff --git a/src/cipsi/energy.irp.f b/src/cipsi/energy.irp.f
index 1f7cf122..4b496c11 100644
--- a/src/cipsi/energy.irp.f
+++ b/src/cipsi/energy.irp.f
@@ -36,12 +36,3 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
endif
END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
- implicit none
- BEGIN_DOC
- ! Overlap between the perturbed wave functions
- END_DOC
- pt2_overlap(1:N_states,1:N_states) = 0.d0
-END_PROVIDER
-
diff --git a/src/cipsi/lock_2rdm.irp.f b/src/cipsi/lock_2rdm.irp.f
deleted file mode 100644
index e69de29b..00000000
diff --git a/src/cipsi/pt2_type.irp.f b/src/cipsi/pt2_type.irp.f
deleted file mode 100644
index ee90d421..00000000
--- a/src/cipsi/pt2_type.irp.f
+++ /dev/null
@@ -1,128 +0,0 @@
-subroutine pt2_alloc(pt2_data,N)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- integer, intent(in) :: N
- integer :: k
-
- allocate(pt2_data % pt2(N) &
- ,pt2_data % variance(N) &
- ,pt2_data % rpt2(N) &
- ,pt2_data % overlap(N,N) &
- )
-
- pt2_data % pt2(:) = 0.d0
- pt2_data % variance(:) = 0.d0
- pt2_data % rpt2(:) = 0.d0
- pt2_data % overlap(:,:) = 0.d0
-
-end subroutine
-
-subroutine pt2_dealloc(pt2_data)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- deallocate(pt2_data % pt2 &
- ,pt2_data % variance &
- ,pt2_data % rpt2 &
- ,pt2_data % overlap &
- )
-end subroutine
-
-subroutine pt2_add(p1, w, p2)
- implicit none
- use selection_types
- BEGIN_DOC
-! p1 += w * p2
- END_DOC
- type(pt2_type), intent(inout) :: p1
- double precision, intent(in) :: w
- type(pt2_type), intent(in) :: p2
-
- if (w == 1.d0) then
-
- p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:)
-
- else
-
- p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:)
-
- endif
-
-end subroutine
-
-
-subroutine pt2_add2(p1, w, p2)
- implicit none
- use selection_types
- BEGIN_DOC
-! p1 += w * p2**2
- END_DOC
- type(pt2_type), intent(inout) :: p1
- double precision, intent(in) :: w
- type(pt2_type), intent(in) :: p2
-
- if (w == 1.d0) then
-
- p1 % pt2(:) = p1 % pt2(:) + p2 % pt2(:) * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + p2 % rpt2(:) * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + p2 % variance(:) * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + p2 % overlap(:,:) * p2 % overlap(:,:)
-
- else
-
- p1 % pt2(:) = p1 % pt2(:) + w * p2 % pt2(:) * p2 % pt2(:)
- p1 % rpt2(:) = p1 % rpt2(:) + w * p2 % rpt2(:) * p2 % rpt2(:)
- p1 % variance(:) = p1 % variance(:) + w * p2 % variance(:) * p2 % variance(:)
- p1 % overlap(:,:) = p1 % overlap(:,:) + w * p2 % overlap(:,:) * p2 % overlap(:,:)
-
- endif
-
-end subroutine
-
-
-subroutine pt2_serialize(pt2_data, n, x)
- implicit none
- use selection_types
- type(pt2_type), intent(in) :: pt2_data
- integer, intent(in) :: n
- double precision, intent(out) :: x(*)
-
- integer :: i,k,n2
-
- n2 = n*n
- x(1:n) = pt2_data % pt2(1:n)
- k=n
- x(k+1:k+n) = pt2_data % rpt2(1:n)
- k=k+n
- x(k+1:k+n) = pt2_data % variance(1:n)
- k=k+n
- x(k+1:k+n2) = reshape(pt2_data % overlap(1:n,1:n), (/ n2 /))
-
-end
-
-subroutine pt2_deserialize(pt2_data, n, x)
- implicit none
- use selection_types
- type(pt2_type), intent(inout) :: pt2_data
- integer, intent(in) :: n
- double precision, intent(in) :: x(*)
-
- integer :: i,k,n2
-
- n2 = n*n
- pt2_data % pt2(1:n) = x(1:n)
- k=n
- pt2_data % rpt2(1:n) = x(k+1:k+n)
- k=k+n
- pt2_data % variance(1:n) = x(k+1:k+n)
- k=k+n
- pt2_data % overlap(1:n,1:n) = reshape(x(k+1:k+n2), (/ n, n /))
-
-end
diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f
index 87ebca40..38a8f362 100644
--- a/src/cipsi/run_selection_slave.irp.f
+++ b/src/cipsi/run_selection_slave.irp.f
@@ -1,256 +1,5 @@
-subroutine run_selection_slave(thread,iproc,energy)
- use f77_zmq
- use selection_types
- implicit none
-
- double precision, intent(in) :: energy(N_states)
- integer, intent(in) :: thread, iproc
- integer :: rc, i
-
- integer :: worker_id, task_id(1), ctask, ltask
- 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
-
- type(selection_buffer) :: buf, buf2
- logical :: done, buffer_ready
- type(pt2_type) :: pt2_data
-
- PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
- PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
- PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
-
- call pt2_alloc(pt2_data,N_states)
-
- 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)
-
- buf%N = 0
- buffer_ready = .False.
- ctask = 1
-
- do
- integer, external :: get_task_from_taskserver
- if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
- exit
- endif
- done = task_id(ctask) == 0
- if (done) then
- ctask = ctask - 1
- else
- integer :: i_generator, N, subset, bsize
- call sscanf_ddd(task, subset, i_generator, N)
- if(buf%N == 0) then
- ! Only first time
- call create_selection_buffer(N, N*2, buf)
- buffer_ready = .True.
- else
- if (N /= buf%N) then
- print *, 'N=', N
- print *, 'buf%N=', buf%N
- print *, 'bug in ', irp_here
- stop '-1'
- end if
- end if
- call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
- endif
-
- integer, external :: task_done_to_taskserver
-
- if(done .or. ctask == size(task_id)) then
- do i=1, ctask
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- call usleep(100)
- if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
- ctask = 0
- done = .true.
- exit
- endif
- endif
- end do
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
- call pt2_dealloc(pt2_data)
- call pt2_alloc(pt2_data,N_states)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- end if
-
- if(done) exit
- ctask = ctask + 1
- end do
-
- if(ctask > 0) then
- call sort_selection_buffer(buf)
-! call merge_selection_buffers(buf,buf2)
- call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
-! buf%mini = buf2%mini
- buf%cur = 0
- end if
- ctask = 0
- call pt2_dealloc(pt2_data)
-
- integer, external :: disconnect_from_taskserver
- if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
- continue
- endif
-
- call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
- call end_zmq_push_socket(zmq_socket_push,thread)
- if (buffer_ready) then
- call delete_selection_buffer(buf)
-! call delete_selection_buffer(buf2)
- endif
-end subroutine
-
-
-subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
-
- integer(ZMQ_PTR), intent(in) :: zmq_socket_push
- type(pt2_type), intent(in) :: pt2_data
- type(selection_buffer), intent(inout) :: b
- integer, intent(in) :: ntasks, task_id(*)
- integer :: rc
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
- endif
-
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- call pt2_serialize(pt2_data,N_states,pt2_serialized)
-
- rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
- if (rc == -1) then
- print *, irp_here, ': error sending result'
- stop 3
- return
- else if(rc /= size(pt2_serialized)*8) then
- stop 'push'
- endif
- deallocate(pt2_serialized)
-
- if (b%cur > 0) then
-
- rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
- if(rc /= 8*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
- if(rc /= bit_kind*N_int*2*b%cur) then
- print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
- endif
-
- endif
-
- rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
- if(rc /= 4) then
- print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
- endif
-
- rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_push is a REQ
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- character*(2) :: ok
- rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
- if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
- print *, irp_here//': error in receiving ok'
- stop -1
- endif
-IRP_ENDIF
-
-end subroutine
-
-
-subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
- use f77_zmq
- use selection_types
- implicit none
- integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
- type(pt2_type), intent(inout) :: pt2_data
- double precision, intent(out) :: val(*)
- integer(bit_kind), intent(out) :: det(N_int, 2, *)
- integer, intent(out) :: N, ntasks, task_id(*)
- integer :: rc, rn, i
- double precision, allocatable :: pt2_serialized(:)
-
- rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
- endif
-
- allocate(pt2_serialized (pt2_type_size(N_states)) )
- rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
- if (rc == -1) then
- ntasks = 1
- task_id(1) = 0
- else if(rc /= 8*size(pt2_serialized)) then
- stop 'pull'
- endif
-
- call pt2_deserialize(pt2_data,N_states,pt2_serialized)
- deallocate(pt2_serialized)
-
- if (N>0) then
- rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
- if(rc /= 8*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
- if(rc /= bit_kind*N_int*2*N) then
- print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
- endif
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
- if(rc /= 4) then
- print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
- endif
-
- rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
- if(rc /= 4*ntasks) then
- print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
- endif
-
-! Activate is zmq_socket_pull is a REP
-IRP_IF ZMQ_PUSH
-IRP_ELSE
- rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
- if (rc /= 2) then
- print *, irp_here//': error in sending ok'
- stop -1
- endif
-IRP_ENDIF
-end subroutine
-
-
+subroutine provide_for_selection_slave
+ PROVIDE psi_det_sorted_order
+ PROVIDE psi_selectors_coef_transp psi_det_sorted
+end
diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f
index ae84f84e..50749272 100644
--- a/src/cipsi/selection.irp.f
+++ b/src/cipsi/selection.irp.f
@@ -141,12 +141,12 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2, Nint)
end
-subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,buf,subset,csubset)
+subroutine select_singles_and_doubles(i_generator, hole_mask, particle_mask, fock_diag_tmp, E0, pt2_data, buf, subset, csubset)
use bitmasks
use selection_types
implicit none
BEGIN_DOC
-! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
+ ! WARNING /!\ : It is assumed that the generators and selectors are psi_det_sorted
END_DOC
integer, intent(in) :: i_generator, subset, csubset
@@ -156,28 +156,35 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
type(pt2_type), intent(inout) :: pt2_data
type(selection_buffer), intent(inout) :: buf
- integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii,sze
- integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
- logical :: fullMatch, ok
+ integer :: h1, h2, s1, s2, s3, i1, i2, ib, sp, k, i, j, nt, ii, sze
+ integer :: maskInd
+ integer :: N_holes(2), N_particles(2)
+ integer :: hole_list(N_int*bit_kind_size,2)
+ integer :: particle_list(N_int*bit_kind_size,2)
+ integer :: l_a, nmax, idx
+ integer :: nb_count, maskInd_save
+ integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2)
+ integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2)
+ logical :: fullMatch, ok
+ logical :: monoAdo, monoBdo
+ logical :: monoBdo_save
+ logical :: found
- integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2)
- integer,allocatable :: preinteresting(:), prefullinteresting(:)
- integer,allocatable :: interesting(:), fullinteresting(:)
- integer,allocatable :: tmp_array(:)
- integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
- logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
- double precision, allocatable :: coef_fullminilist_rev(:,:)
+ integer, allocatable :: preinteresting(:), prefullinteresting(:)
+ integer, allocatable :: interesting(:), fullinteresting(:)
+ integer, allocatable :: tmp_array(:)
+ integer, allocatable :: indices(:), exc_degree(:), iorder(:)
+ integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :)
+ logical, allocatable :: banned(:,:,:), bannedOrb(:,:)
+ double precision, allocatable :: coef_fullminilist_rev(:,:)
+ double precision, allocatable :: mat(:,:,:)
- double precision, allocatable :: mat(:,:,:)
-
- logical :: monoAdo, monoBdo
- integer :: maskInd
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order psi_bilinear_matrix_transp_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
- PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp
+ PROVIDE psi_selectors_coef_transp psi_det_sorted_order
PROVIDE banned_excitation
monoAdo = .true.
@@ -192,17 +199,9 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2))
enddo
-
- integer :: N_holes(2), N_particles(2)
- integer :: hole_list(N_int*bit_kind_size,2)
- integer :: particle_list(N_int*bit_kind_size,2)
-
call bitstring_to_list_ab(hole , hole_list , N_holes , N_int)
call bitstring_to_list_ab(particle, particle_list, N_particles, N_int)
- 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
@@ -320,22 +319,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
allocate(banned(mo_num, mo_num,2), bannedOrb(mo_num, 2))
- allocate (mat(N_states, mo_num, mo_num))
+ allocate(mat(N_states, mo_num, mo_num))
maskInd = -1
- integer :: nb_count, maskInd_save
- logical :: monoBdo_save
- logical :: found
- do s1=1,2
- do i1=N_holes(s1),1,-1 ! Generate low excitations first
+ do s1 = 1, 2
+ do i1 = N_holes(s1), 1, -1 ! Generate low excitations first
found = .False.
monoBdo_save = monoBdo
maskInd_save = maskInd
- do s2=s1,2
+ do s2 = s1, 2
ib = 1
if(s1 == s2) ib = i1+1
- do i2=N_holes(s2),ib,-1
+ do i2 = N_holes(s2), ib, -1
maskInd = maskInd + 1
if(mod(maskInd, csubset) == (subset-1)) then
found = .True.
@@ -349,14 +345,14 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
maskInd = maskInd_save
h1 = hole_list(i1,s1)
- call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int)
+ call apply_hole(psi_det_generators(1,1,i_generator), s1, h1, pmask, ok, N_int)
negMask = not(pmask)
interesting(0) = 0
fullinteresting(0) = 0
- do ii=1,preinteresting(0)
+ do ii = 1, preinteresting(0)
i = preinteresting(ii)
select case (N_int)
case (1)
@@ -372,7 +368,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:3,1) = iand(negMask(1:3,1), psi_det_sorted(1:3,1,i))
mobMask(1:3,2) = iand(negMask(1:3,2), psi_det_sorted(1:3,2,i))
nt = 0
- do j=3,1,-1
+ do j = 3, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -386,7 +382,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:4,1) = iand(negMask(1:4,1), psi_det_sorted(1:4,1,i))
mobMask(1:4,2) = iand(negMask(1:4,2), psi_det_sorted(1:4,2,i))
nt = 0
- do j=4,1,-1
+ do j = 4, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -400,7 +396,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
mobMask(1:N_int,1) = iand(negMask(1:N_int,1), psi_det_sorted(1:N_int,1,i))
mobMask(1:N_int,2) = iand(negMask(1:N_int,2), psi_det_sorted(1:N_int,2,i))
nt = 0
- do j=N_int,1,-1
+ do j = N_int, 1, -1
if (mobMask(j,1) /= 0_bit_kind) then
nt = nt+ popcnt(mobMask(j, 1))
if (nt > 4) exit
@@ -441,7 +437,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
end do
- do ii=1,prefullinteresting(0)
+ do ii = 1, prefullinteresting(0)
i = prefullinteresting(ii)
nt = 0
mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i))
@@ -480,40 +476,38 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
minilist(:,:,i) = psi_det_sorted(:,:,interesting(i))
enddo
- do s2=s1,2
+ do s2 = s1, 2
sp = s1
- if(s1 /= s2) then
- sp = 3
- endif
+ if(s1 /= s2) sp = 3
ib = 1
if(s1 == s2) ib = i1+1
monoAdo = .true.
- do i2=N_holes(s2),ib,-1 ! Generate low excitations first
+ do i2 = N_holes(s2), ib, -1 ! Generate low excitations first
h2 = hole_list(i2,s2)
call apply_hole(pmask, s2,h2, mask, ok, N_int)
banned(:,:,1) = banned_excitation(:,:)
banned(:,:,2) = banned_excitation(:,:)
- do j=1,mo_num
+ do j = 1, mo_num
bannedOrb(j, 1) = .true.
bannedOrb(j, 2) = .true.
enddo
- do s3=1,2
- do i=1,N_particles(s3)
+ do s3 = 1, 2
+ do i = 1, N_particles(s3)
bannedOrb(particle_list(i,s3), s3) = .false.
enddo
enddo
if(s1 /= s2) then
if(monoBdo) then
bannedOrb(h1,s1) = .false.
- end if
+ endif
if(monoAdo) then
bannedOrb(h2,s2) = .false.
monoAdo = .false.
- end if
- end if
+ endif
+ endif
maskInd = maskInd + 1
if(mod(maskInd, csubset) == (subset-1)) then
@@ -522,12 +516,18 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d
if(fullMatch) cycle
call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting)
+
call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2_data, mat, buf)
end if
+
+
enddo
+
if(s1 /= s2) monoBdo = .false.
enddo
- deallocate(fullminilist,minilist)
+
+ deallocate(fullminilist, minilist)
+
enddo
enddo
deallocate(preinteresting, prefullinteresting, interesting, fullinteresting)
diff --git a/src/cipsi/selection_types.f90 b/src/cipsi/selection_types.f90
deleted file mode 100644
index 58ce0e03..00000000
--- a/src/cipsi/selection_types.f90
+++ /dev/null
@@ -1,25 +0,0 @@
-module selection_types
- type selection_buffer
- integer :: N, cur
- integer(8) , pointer :: det(:,:,:)
- double precision, pointer :: val(:)
- double precision :: mini
- endtype
-
- type pt2_type
- double precision, allocatable :: pt2(:)
- double precision, allocatable :: rpt2(:)
- double precision, allocatable :: variance(:)
- double precision, allocatable :: overlap(:,:)
- endtype
-
- contains
-
- integer function pt2_type_size(N)
- implicit none
- integer, intent(in) :: N
- pt2_type_size = (3*n + n*n)
- end function
-
-end module
-
diff --git a/src/cipsi_utils/README.rst b/src/cipsi_utils/README.rst
new file mode 100644
index 00000000..8e98e3ac
--- /dev/null
+++ b/src/cipsi_utils/README.rst
@@ -0,0 +1,5 @@
+===========
+cipsi_utils
+===========
+
+Common functions for CIPSI and TC-CIPSI
diff --git a/src/cipsi/environment.irp.f b/src/cipsi_utils/environment.irp.f
similarity index 100%
rename from src/cipsi/environment.irp.f
rename to src/cipsi_utils/environment.irp.f
diff --git a/src/cipsi_utils/pt2_stoch_routines.irp.f b/src/cipsi_utils/pt2_stoch_routines.irp.f
new file mode 100644
index 00000000..f067d0be
--- /dev/null
+++ b/src/cipsi_utils/pt2_stoch_routines.irp.f
@@ -0,0 +1,891 @@
+BEGIN_PROVIDER [ integer, pt2_stoch_istate ]
+ implicit none
+ BEGIN_DOC
+ ! State for stochatsic PT2
+ END_DOC
+ pt2_stoch_istate = 1
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, pt2_F, (N_det_generators) ]
+&BEGIN_PROVIDER [ integer, pt2_n_tasks_max ]
+ implicit none
+ logical, external :: testTeethBuilding
+ integer :: i,j
+ pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num - n_core_orb*2
+ pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
+ call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
+
+ pt2_F(:) = max(int(sqrt(float(pt2_n_tasks_max))),1)
+ do i=1,pt2_n_0(1+pt2_N_teeth/4)
+ pt2_F(i) = pt2_n_tasks_max*pt2_min_parallel_tasks
+ enddo
+ do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/4), pt2_n_0(pt2_N_teeth-pt2_N_teeth/10)
+ pt2_F(i) = pt2_min_parallel_tasks
+ enddo
+ do i=1+pt2_n_0(pt2_N_teeth-pt2_N_teeth/10), N_det_generators
+ pt2_F(i) = 1
+ enddo
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, pt2_N_teeth ]
+&BEGIN_PROVIDER [ integer, pt2_minDetInFirstTeeth ]
+ implicit none
+ logical, external :: testTeethBuilding
+
+ if(N_det_generators < 1024) then
+ pt2_minDetInFirstTeeth = 1
+ pt2_N_teeth = 1
+ else
+ pt2_minDetInFirstTeeth = min(5, N_det_generators)
+ do pt2_N_teeth=100,2,-1
+ if(testTeethBuilding(pt2_minDetInFirstTeeth, pt2_N_teeth)) exit
+ end do
+ end if
+ call write_int(6,pt2_N_teeth,'Number of comb teeth')
+END_PROVIDER
+
+
+logical function testTeethBuilding(minF, N)
+ implicit none
+ integer, intent(in) :: minF, N
+ integer :: n0, i
+ double precision :: u0, Wt, r
+
+ double precision, allocatable :: tilde_w(:), tilde_cW(:)
+ integer, external :: dress_find_sample
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+
+ rss = memory_of_double(2*N_det_generators+1)
+ call check_mem(rss,irp_here)
+
+ allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
+
+ double precision :: norm2
+ norm2 = 0.d0
+ do i=N_det_generators,1,-1
+ tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
+ psi_coef_sorted_gen(i,pt2_stoch_istate)
+ norm2 = norm2 + tilde_w(i)
+ enddo
+
+ f = 1.d0/norm2
+ tilde_w(:) = tilde_w(:) * f
+
+ tilde_cW(0) = -1.d0
+ do i=1,N_det_generators
+ tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
+ enddo
+ tilde_cW(:) = tilde_cW(:) + 1.d0
+ deallocate(tilde_w)
+
+ n0 = 0
+ testTeethBuilding = .false.
+ double precision :: f
+ integer :: minFN
+ minFN = N_det_generators - minF * N
+ f = 1.d0/dble(N)
+ do
+ u0 = tilde_cW(n0)
+ r = tilde_cW(n0 + minF)
+ Wt = (1d0 - u0) * f
+ if (dabs(Wt) <= 1.d-3) then
+ exit
+ endif
+ if(Wt >= r - u0) then
+ testTeethBuilding = .true.
+ exit
+ end if
+ n0 += 1
+ if(n0 > minFN) then
+ exit
+ end if
+ end do
+ deallocate(tilde_cW)
+
+end function
+
+
+!subroutine provide_for_zmq_pt2
+! PROVIDE psi_det_sorted_order psi_selectors_coef_transp psi_det_sorted
+!end
+
+subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
+ use f77_zmq
+ use selection_types
+
+ implicit none
+
+ integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
+ integer, intent(in) :: N_in
+ double precision, intent(in) :: relative_error, E(N_states)
+ type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
+!
+ integer :: i, N
+
+ double precision :: state_average_weight_save(N_states), w(N_states,4)
+ integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket
+ type(selection_buffer) :: b
+
+ PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+ PROVIDE psi_bilinear_matrix_transp_order
+ PROVIDE psi_det_hii 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
+
+ call provide_for_zmq_pt2
+
+ if (h0_type == 'CFG') then
+ PROVIDE psi_configuration_hii det_to_configuration
+ endif
+
+ if (N_det <= max(4,N_states) .or. pt2_N_teeth < 2) then
+ call ZMQ_selection(N_in, pt2_data)
+ else
+
+ N = max(N_in,1) * N_states
+ state_average_weight_save(:) = state_average_weight(:)
+ if (int(N,8)*2_8 > huge(1)) then
+ print *, irp_here, ': integer too large'
+ stop -1
+ endif
+ call create_selection_buffer(N, N*2, b)
+ ASSERT (associated(b%det))
+ ASSERT (associated(b%val))
+
+ do pt2_stoch_istate=1,N_states
+ state_average_weight(:) = 0.d0
+ state_average_weight(pt2_stoch_istate) = 1.d0
+ TOUCH state_average_weight pt2_stoch_istate selection_weight
+
+ PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
+ PROVIDE psi_selectors pt2_u pt2_J pt2_R
+ call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
+
+ integer, external :: zmq_put_psi
+ integer, external :: zmq_put_N_det_generators
+ integer, external :: zmq_put_N_det_selectors
+ integer, external :: zmq_put_dvector
+ integer, external :: zmq_put_ivector
+ if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
+ stop 'Unable to put psi on ZMQ server'
+ endif
+ if (zmq_put_N_det_generators(zmq_to_qp_run_socket, 1) == -1) then
+ stop 'Unable to put N_det_generators on ZMQ server'
+ endif
+ if (zmq_put_N_det_selectors(zmq_to_qp_run_socket, 1) == -1) then
+ stop 'Unable to put N_det_selectors on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',pt2_e0_denominator,size(pt2_e0_denominator)) == -1) then
+ stop 'Unable to put energy on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'state_average_weight',state_average_weight,N_states) == -1) then
+ stop 'Unable to put state_average_weight on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'selection_weight',selection_weight,N_states) == -1) then
+ stop 'Unable to put selection_weight on ZMQ server'
+ endif
+ if (zmq_put_ivector(zmq_to_qp_run_socket,1,'pt2_stoch_istate',pt2_stoch_istate,1) == -1) then
+ stop 'Unable to put pt2_stoch_istate on ZMQ server'
+ endif
+ if (zmq_put_dvector(zmq_to_qp_run_socket,1,'threshold_generators',(/threshold_generators/),1) == -1) then
+ stop 'Unable to put threshold_generators on ZMQ server'
+ endif
+
+
+ integer, external :: add_task_to_taskserver
+ character(300000) :: task
+
+ integer :: j,k,ipos,ifirst
+ ifirst=0
+
+ ipos=0
+ do i=1,N_det_generators
+ if (pt2_F(i) > 1) then
+ ipos += 1
+ endif
+ enddo
+ call write_int(6,sum(pt2_F),'Number of tasks')
+ call write_int(6,ipos,'Number of fragmented tasks')
+
+ ipos=1
+ do i= 1, N_det_generators
+ do j=1,pt2_F(pt2_J(i))
+ write(task(ipos:ipos+30),'(I9,1X,I9,1X,I9,''|'')') j, pt2_J(i), N_in
+ ipos += 30
+ if (ipos > 300000-30) then
+ if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+ stop 'Unable to add task to task server'
+ endif
+ ipos=1
+ if (ifirst == 0) then
+ ifirst=1
+ if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
+ print *, irp_here, ': Failed in zmq_set_running'
+ endif
+ endif
+ endif
+ end do
+ enddo
+ if (ipos > 1) then
+ if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+ stop 'Unable to add task to task server'
+ endif
+ endif
+
+ 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
+
+
+ double precision :: mem_collector, mem, rss
+
+ call resident_memory(rss)
+
+ mem_collector = 8.d0 * & ! bytes
+ ( 1.d0*pt2_n_tasks_max & ! task_id, index
+ + 0.635d0*N_det_generators & ! f,d
+ + pt2_n_tasks_max*pt2_type_size(N_states) & ! pt2_data_task
+ + N_det_generators*pt2_type_size(N_states) & ! pt2_data_I
+ + 4.d0*(pt2_N_teeth+1) & ! S, S2, T2, T3
+ + 1.d0*(N_int*2.d0*N + N) & ! selection buffer
+ + 1.d0*(N_int*2.d0*N + N) & ! sort selection buffer
+ ) / 1024.d0**3
+
+ integer :: nproc_target, ii
+ nproc_target = nthreads_pt2
+ ii = min(N_det, (elec_alpha_num*(mo_num-elec_alpha_num))**2)
+
+ do
+ mem = mem_collector + & !
+ nproc_target * 8.d0 * & ! bytes
+ ( 0.5d0*pt2_n_tasks_max & ! task_id
+ + 64.d0*pt2_n_tasks_max & ! task
+ + pt2_type_size(N_states)*pt2_n_tasks_max*N_states & ! pt2, variance, overlap
+ + 1.d0*pt2_n_tasks_max & ! i_generator, subset
+ + 1.d0*(N_int*2.d0*ii+ ii) & ! selection buffer
+ + 1.d0*(N_int*2.d0*ii+ ii) & ! sort selection buffer
+ + 2.0d0*(ii) & ! preinteresting, interesting,
+ ! prefullinteresting, fullinteresting
+ + 2.0d0*(N_int*2*ii) & ! minilist, fullminilist
+ + 1.0d0*(N_states*mo_num*mo_num) & ! mat
+ ) / 1024.d0**3
+
+ if (nproc_target == 0) then
+ call check_mem(mem,irp_here)
+ nproc_target = 1
+ exit
+ endif
+
+ if (mem+rss < qp_max_mem) then
+ exit
+ endif
+
+ nproc_target = nproc_target - 1
+
+ enddo
+ call write_int(6,nproc_target,'Number of threads for PT2')
+ call write_double(6,mem,'Memory (Gb)')
+
+ call set_multiple_levels_omp(.False.)
+
+
+ print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
+ print '(A)', ' Samples Energy PT2 Variance Norm^2 Convergence Seconds'
+ print '(A)', '========== ==================== ================ ================ ================ ============= ==========='
+
+ PROVIDE global_selection_buffer
+
+ !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1) &
+ !$OMP PRIVATE(i)
+ i = omp_get_thread_num()
+ if (i==0) then
+
+ call pt2_collector(zmq_socket_pull, E(pt2_stoch_istate),relative_error, pt2_data, pt2_data_err, b, N)
+ pt2_data % rpt2(pt2_stoch_istate) = &
+ pt2_data % pt2(pt2_stoch_istate)/(1.d0+pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
+
+ !TODO : We should use here the correct formula for the error of X/Y
+ pt2_data_err % rpt2(pt2_stoch_istate) = &
+ pt2_data_err % pt2(pt2_stoch_istate)/(1.d0 + pt2_data % overlap(pt2_stoch_istate,pt2_stoch_istate))
+
+ else
+ call pt2_slave_inproc(i)
+ endif
+ !$OMP END PARALLEL
+ call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
+ call set_multiple_levels_omp(.True.)
+
+ 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
+
+ enddo
+ FREE pt2_stoch_istate
+
+ ! Symmetrize overlap
+ do j=2,N_states
+ do i=1,j-1
+ pt2_overlap(i,j) = 0.5d0 * (pt2_overlap(i,j) + pt2_overlap(j,i))
+ pt2_overlap(j,i) = pt2_overlap(i,j)
+ enddo
+ enddo
+
+ print *, 'Overlap of perturbed states:'
+ do k=1,N_states
+ print *, pt2_overlap(k,:)
+ enddo
+ print *, '-------'
+
+ if (N_in > 0) then
+ b%cur = min(N_in,b%cur)
+ if (s2_eig) then
+ call make_selection_buffer_s2(b)
+ else
+ call remove_duplicates_in_selection_buffer(b)
+ endif
+ call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0)
+ endif
+ call delete_selection_buffer(b)
+
+ state_average_weight(:) = state_average_weight_save(:)
+ TOUCH state_average_weight
+ call update_pt2_and_variance_weights(pt2_data, N_states)
+ endif
+
+
+end subroutine
+
+
+subroutine pt2_slave_inproc(i)
+ implicit none
+ integer, intent(in) :: i
+
+ PROVIDE global_selection_buffer
+ call run_pt2_slave(1,i,pt2_e0_denominator)
+end
+
+
+subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2_data, pt2_data_err, b, N_)
+ use f77_zmq
+ use selection_types
+ use bitmasks
+ implicit none
+
+
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
+ double precision, intent(in) :: relative_error, E
+ type(pt2_type), intent(inout) :: pt2_data, pt2_data_err
+ type(selection_buffer), intent(inout) :: b
+ integer, intent(in) :: N_
+
+ type(pt2_type), allocatable :: pt2_data_task(:)
+ type(pt2_type), allocatable :: pt2_data_I(:)
+ type(pt2_type), allocatable :: pt2_data_S(:)
+ type(pt2_type), allocatable :: pt2_data_S2(:)
+ type(pt2_type) :: pt2_data_teeth
+ integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
+ integer(ZMQ_PTR) :: zmq_to_qp_run_socket
+ integer, external :: zmq_delete_tasks_async_send
+ integer, external :: zmq_delete_tasks_async_recv
+ integer, external :: zmq_abort
+ integer, external :: pt2_find_sample_lr
+
+ PROVIDE pt2_stoch_istate
+
+ integer :: more, n, i, p, c, t, n_tasks, U
+ integer, allocatable :: task_id(:)
+ integer, allocatable :: index(:)
+
+ double precision :: v, x, x2, x3, avg, avg2, avg3(N_states), eqt, E0, v0, n0(N_states)
+ double precision :: eqta(N_states)
+ double precision :: time, time1, time0
+
+ integer, allocatable :: f(:)
+ logical, allocatable :: d(:)
+ logical :: do_exit, stop_now, sending
+ logical, external :: qp_stop
+ type(selection_buffer) :: b2
+
+
+ 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)
+ rss += memory_of_double(N_states*N_det_generators)*3.d0
+ rss += memory_of_double(N_states*pt2_n_tasks_max)*3.d0
+ rss += memory_of_double(pt2_N_teeth+1)*4.d0
+ call check_mem(rss,irp_here)
+
+ ! If an allocation is added here, the estimate of the memory should also be
+ ! updated in ZMQ_pt2
+ allocate(task_id(pt2_n_tasks_max), index(pt2_n_tasks_max), f(N_det_generators))
+ allocate(d(N_det_generators+1))
+ allocate(pt2_data_task(pt2_n_tasks_max))
+ allocate(pt2_data_I(N_det_generators))
+ allocate(pt2_data_S(pt2_N_teeth+1))
+ allocate(pt2_data_S2(pt2_N_teeth+1))
+
+
+
+ zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
+ call create_selection_buffer(N_, N_*2, b2)
+
+
+ pt2_data % pt2(pt2_stoch_istate) = -huge(1.)
+ pt2_data_err % pt2(pt2_stoch_istate) = huge(1.)
+ pt2_data % variance(pt2_stoch_istate) = huge(1.)
+ pt2_data_err % variance(pt2_stoch_istate) = huge(1.)
+ pt2_data % overlap(:,pt2_stoch_istate) = 0.d0
+ pt2_data_err % overlap(:,pt2_stoch_istate) = huge(1.)
+ n = 1
+ t = 0
+ U = 0
+ do i=1,pt2_n_tasks_max
+ call pt2_alloc(pt2_data_task(i),N_states)
+ enddo
+ do i=1,pt2_N_teeth+1
+ call pt2_alloc(pt2_data_S(i),N_states)
+ call pt2_alloc(pt2_data_S2(i),N_states)
+ enddo
+ do i=1,N_det_generators
+ call pt2_alloc(pt2_data_I(i),N_states)
+ enddo
+ f(:) = pt2_F(:)
+ d(:) = .false.
+ n_tasks = 0
+ E0 = E
+ v0 = 0.d0
+ n0(:) = 0.d0
+ more = 1
+ call wall_time(time0)
+ time1 = time0
+
+ do_exit = .false.
+ stop_now = .false.
+ do while (n <= N_det_generators)
+ if(f(pt2_J(n)) == 0) then
+ d(pt2_J(n)) = .true.
+ do while(d(U+1))
+ U += 1
+ end do
+
+ ! Deterministic part
+ do while(t <= pt2_N_teeth)
+ if(U >= pt2_n_0(t+1)) then
+ t=t+1
+ E0 = 0.d0
+ v0 = 0.d0
+ n0(:) = 0.d0
+ do i=pt2_n_0(t),1,-1
+ E0 += pt2_data_I(i) % pt2(pt2_stoch_istate)
+ v0 += pt2_data_I(i) % variance(pt2_stoch_istate)
+ n0(:) += pt2_data_I(i) % overlap(:,pt2_stoch_istate)
+ end do
+ else
+ exit
+ end if
+ end do
+
+ ! Add Stochastic part
+ c = pt2_R(n)
+ if(c > 0) then
+
+ call pt2_alloc(pt2_data_teeth,N_states)
+ do p=pt2_N_teeth, 1, -1
+ v = pt2_u_0 + pt2_W_T * (pt2_u(c) + dble(p-1))
+ i = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(p),pt2_n_0(p+1))
+ v = pt2_W_T / pt2_w(i)
+ call pt2_add ( pt2_data_teeth, v, pt2_data_I(i) )
+ call pt2_add ( pt2_data_S(p), 1.d0, pt2_data_teeth )
+ call pt2_add2( pt2_data_S2(p), 1.d0, pt2_data_teeth )
+ enddo
+ call pt2_dealloc(pt2_data_teeth)
+
+ avg = E0 + pt2_data_S(t) % pt2(pt2_stoch_istate) / dble(c)
+ avg2 = v0 + pt2_data_S(t) % variance(pt2_stoch_istate) / dble(c)
+ avg3(:) = n0(:) + pt2_data_S(t) % overlap(:,pt2_stoch_istate) / dble(c)
+ if ((avg /= 0.d0) .or. (n == N_det_generators) ) then
+ do_exit = .true.
+ endif
+ if (qp_stop()) then
+ stop_now = .True.
+ endif
+ pt2_data % pt2(pt2_stoch_istate) = avg
+ pt2_data % variance(pt2_stoch_istate) = avg2
+ pt2_data % overlap(:,pt2_stoch_istate) = avg3(:)
+ call wall_time(time)
+ ! 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 = 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 = 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(:) = 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
+ 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
+ if (zmq_abort(zmq_to_qp_run_socket) == -1) then
+ call sleep(10)
+ if (zmq_abort(zmq_to_qp_run_socket) == -1) then
+ print *, irp_here, ': Error in sending abort signal (2)'
+ endif
+ endif
+ endif
+ endif
+ endif
+ end if
+ n += 1
+ else if(more == 0) then
+ exit
+ else
+ call pull_pt2_results(zmq_socket_pull, index, pt2_data_task, task_id, n_tasks, b2)
+ if(n_tasks > pt2_n_tasks_max)then
+ print*,'PB !!!'
+ print*,'If you see this, send a bug report with the following content'
+ print*,irp_here
+ print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
+ stop -1
+ endif
+ if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
+ stop 'PT2: Unable to delete tasks (send)'
+ 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
+ endif
+ call pt2_add(pt2_data_I(index(i)),1.d0,pt2_data_task(i))
+ f(index(i)) -= 1
+ end do
+ do i=1, b2%cur
+ ! We assume the pulled buffer is sorted
+ if (b2%val(i) > b%mini) exit
+ call add_to_selection_buffer(b, b2%det(1,1,i), b2%val(i))
+ end do
+ if (zmq_delete_tasks_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
+ stop 'PT2: Unable to delete tasks (recv)'
+ endif
+ end if
+ end do
+ do i=1,N_det_generators
+ call pt2_dealloc(pt2_data_I(i))
+ enddo
+ do i=1,pt2_N_teeth+1
+ call pt2_dealloc(pt2_data_S(i))
+ call pt2_dealloc(pt2_data_S2(i))
+ enddo
+ do i=1,pt2_n_tasks_max
+ call pt2_dealloc(pt2_data_task(i))
+ enddo
+!print *, 'deleting b2'
+ call delete_selection_buffer(b2)
+!print *, 'sorting b'
+ call sort_selection_buffer(b)
+!print *, 'done'
+ call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+
+end subroutine
+
+
+integer function pt2_find_sample(v, w)
+ implicit none
+ double precision, intent(in) :: v, w(0:N_det_generators)
+ integer, external :: pt2_find_sample_lr
+
+ pt2_find_sample = pt2_find_sample_lr(v, w, 0, N_det_generators)
+end function
+
+
+integer function pt2_find_sample_lr(v, w, l_in, r_in)
+ implicit none
+ double precision, intent(in) :: v, w(0:N_det_generators)
+ integer, intent(in) :: l_in,r_in
+ integer :: i,l,r
+
+ l=l_in
+ r=r_in
+
+ do while(r-l > 1)
+ i = shiftr(r+l,1)
+ if(w(i) < v) then
+ l = i
+ else
+ r = i
+ end if
+ end do
+ i = r
+ do r=i+1,N_det_generators
+ if (w(r) /= w(i)) then
+ exit
+ endif
+ enddo
+ pt2_find_sample_lr = r-1
+end function
+
+
+BEGIN_PROVIDER [ integer, pt2_n_tasks ]
+ implicit none
+ BEGIN_DOC
+ ! Number of parallel tasks for the Monte Carlo
+ END_DOC
+ pt2_n_tasks = N_det_generators
+END_PROVIDER
+
+BEGIN_PROVIDER[ double precision, pt2_u, (N_det_generators)]
+ implicit none
+ integer, allocatable :: seed(:)
+ integer :: m,i
+ call random_seed(size=m)
+ allocate(seed(m))
+ do i=1,m
+ seed(i) = i
+ enddo
+ call random_seed(put=seed)
+ deallocate(seed)
+
+ call RANDOM_NUMBER(pt2_u)
+ END_PROVIDER
+
+ BEGIN_PROVIDER[ integer, pt2_J, (N_det_generators)]
+&BEGIN_PROVIDER[ integer, pt2_R, (N_det_generators)]
+ implicit none
+ BEGIN_DOC
+! pt2_J contains the list of generators after ordering them according to the
+! Monte Carlo sampling.
+!
+! pt2_R(i) is the number of combs drawn when determinant i is computed.
+ END_DOC
+ integer :: N_c, N_j
+ integer :: U, t, i
+ double precision :: v
+ integer, external :: pt2_find_sample_lr
+
+ logical, allocatable :: pt2_d(:)
+ integer :: m,l,r,k
+ integer :: ncache
+ integer, allocatable :: ii(:,:)
+ double precision :: dt
+
+ ncache = min(N_det_generators,10000)
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+ rss = memory_of_int(ncache)*dble(pt2_N_teeth) + memory_of_int(N_det_generators)
+ call check_mem(rss,irp_here)
+
+ allocate(ii(pt2_N_teeth,ncache),pt2_d(N_det_generators))
+
+ pt2_R(:) = 0
+ pt2_d(:) = .false.
+ N_c = 0
+ N_j = pt2_n_0(1)
+ do i=1,N_j
+ pt2_d(i) = .true.
+ pt2_J(i) = i
+ end do
+
+ U = 0
+ do while(N_j < pt2_n_tasks)
+
+ if (N_c+ncache > N_det_generators) then
+ ncache = N_det_generators - N_c
+ endif
+
+ !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(dt,v,t,k)
+ do k=1, ncache
+ dt = pt2_u_0
+ do t=1, pt2_N_teeth
+ v = dt + pt2_W_T *pt2_u(N_c+k)
+ dt = dt + pt2_W_T
+ ii(t,k) = pt2_find_sample_lr(v, pt2_cW,pt2_n_0(t),pt2_n_0(t+1))
+ end do
+ enddo
+ !$OMP END PARALLEL DO
+
+ do k=1,ncache
+ !ADD_COMB
+ N_c = N_c+1
+ do t=1, pt2_N_teeth
+ i = ii(t,k)
+ if(.not. pt2_d(i)) then
+ N_j += 1
+ pt2_J(N_j) = i
+ pt2_d(i) = .true.
+ end if
+ end do
+
+ pt2_R(N_j) = N_c
+
+ !FILL_TOOTH
+ do while(U < N_det_generators)
+ U += 1
+ if(.not. pt2_d(U)) then
+ N_j += 1
+ pt2_J(N_j) = U
+ pt2_d(U) = .true.
+ exit
+ end if
+ end do
+ if (N_j >= pt2_n_tasks) exit
+ end do
+ enddo
+
+ if(N_det_generators > 1) then
+ pt2_R(N_det_generators-1) = 0
+ pt2_R(N_det_generators) = N_c
+ end if
+
+ deallocate(ii,pt2_d)
+
+END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [ double precision, pt2_w, (N_det_generators) ]
+&BEGIN_PROVIDER [ double precision, pt2_cW, (0:N_det_generators) ]
+&BEGIN_PROVIDER [ double precision, pt2_W_T ]
+&BEGIN_PROVIDER [ double precision, pt2_u_0 ]
+&BEGIN_PROVIDER [ integer, pt2_n_0, (pt2_N_teeth+1) ]
+ implicit none
+ integer :: i, t
+ double precision, allocatable :: tilde_w(:), tilde_cW(:)
+ double precision :: r, tooth_width
+ integer, external :: pt2_find_sample
+
+ double precision :: rss
+ double precision, external :: memory_of_double, memory_of_int
+ rss = memory_of_double(2*N_det_generators+1)
+ call check_mem(rss,irp_here)
+
+ if (N_det_generators == 1) then
+
+ pt2_w(1) = 1.d0
+ pt2_cw(1) = 1.d0
+ pt2_u_0 = 1.d0
+ pt2_W_T = 0.d0
+ pt2_n_0(1) = 0
+ pt2_n_0(2) = 1
+
+ else
+
+ allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
+
+ tilde_cW(0) = 0d0
+
+ do i=1,N_det_generators
+ tilde_w(i) = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
+ enddo
+
+ double precision :: norm2
+ norm2 = 0.d0
+ do i=N_det_generators,1,-1
+ norm2 += tilde_w(i)
+ enddo
+
+ tilde_w(:) = tilde_w(:) / norm2
+
+ tilde_cW(0) = -1.d0
+ do i=1,N_det_generators
+ tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
+ enddo
+ tilde_cW(:) = tilde_cW(:) + 1.d0
+
+ pt2_n_0(1) = 0
+ do
+ pt2_u_0 = tilde_cW(pt2_n_0(1))
+ r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
+ pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
+ if(pt2_W_T >= r - pt2_u_0) then
+ exit
+ end if
+ pt2_n_0(1) += 1
+ if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then
+ print *, "teeth building failed"
+ stop -1
+ end if
+ end do
+
+ do t=2, pt2_N_teeth
+ r = pt2_u_0 + pt2_W_T * dble(t-1)
+ pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
+ end do
+ pt2_n_0(pt2_N_teeth+1) = N_det_generators
+
+ pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
+ 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 = 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
+ end do
+
+ pt2_cW(0) = 0d0
+ do i=1,N_det_generators
+ pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
+ end do
+ pt2_n_0(pt2_N_teeth+1) = N_det_generators
+
+ endif
+END_PROVIDER
+
+
+
+
+
+BEGIN_PROVIDER [ double precision, pt2_overlap, (N_states, N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! Overlap between the perturbed wave functions
+ END_DOC
+ pt2_overlap(1:N_states,1:N_states) = 0.d0
+END_PROVIDER
+
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f b/src/cipsi_utils/pt2_type.irp.f
similarity index 100%
rename from plugins/local/cipsi_tc_bi_ortho/pt2_type.irp.f
rename to src/cipsi_utils/pt2_type.irp.f
diff --git a/src/cipsi/run_pt2_slave.irp.f b/src/cipsi_utils/run_pt2_slave.irp.f
similarity index 100%
rename from src/cipsi/run_pt2_slave.irp.f
rename to src/cipsi_utils/run_pt2_slave.irp.f
diff --git a/src/cipsi_utils/run_selection_slave.irp.f b/src/cipsi_utils/run_selection_slave.irp.f
new file mode 100644
index 00000000..783bed0f
--- /dev/null
+++ b/src/cipsi_utils/run_selection_slave.irp.f
@@ -0,0 +1,257 @@
+subroutine run_selection_slave(thread,iproc,energy)
+ use f77_zmq
+ use selection_types
+ implicit none
+
+ double precision, intent(in) :: energy(N_states)
+ integer, intent(in) :: thread, iproc
+ integer :: rc, i
+
+ integer :: worker_id, task_id(1), ctask, ltask
+ 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
+
+ type(selection_buffer) :: buf, buf2
+ logical :: done, buffer_ready
+ type(pt2_type) :: pt2_data
+
+ PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+ PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+ PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order weight_selection
+
+ call provide_for_selection_slave
+
+ call pt2_alloc(pt2_data,N_states)
+
+ 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)
+
+ buf%N = 0
+ buffer_ready = .False.
+ ctask = 1
+
+ do
+ integer, external :: get_task_from_taskserver
+ if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) == -1) then
+ exit
+ endif
+ done = task_id(ctask) == 0
+ if (done) then
+ ctask = ctask - 1
+ else
+ integer :: i_generator, N, subset, bsize
+ call sscanf_ddd(task, subset, i_generator, N)
+ if(buf%N == 0) then
+ ! Only first time
+ call create_selection_buffer(N, N*2, buf)
+ buffer_ready = .True.
+ else
+ if (N /= buf%N) then
+ print *, 'N=', N
+ print *, 'buf%N=', buf%N
+ print *, 'bug in ', irp_here
+ stop '-1'
+ end if
+ end if
+ call select_connected(i_generator, energy, pt2_data, buf, subset, pt2_F(i_generator))
+ endif
+
+ integer, external :: task_done_to_taskserver
+
+ if(done .or. ctask == size(task_id)) then
+ do i=1, ctask
+ if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
+ call usleep(100)
+ if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) == -1) then
+ ctask = 0
+ done = .true.
+ exit
+ endif
+ endif
+ end do
+ if(ctask > 0) then
+ call sort_selection_buffer(buf)
+! call merge_selection_buffers(buf,buf2)
+ call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
+ call pt2_dealloc(pt2_data)
+ call pt2_alloc(pt2_data,N_states)
+! buf%mini = buf2%mini
+ buf%cur = 0
+ end if
+ ctask = 0
+ end if
+
+ if(done) exit
+ ctask = ctask + 1
+ end do
+
+ if(ctask > 0) then
+ call sort_selection_buffer(buf)
+! call merge_selection_buffers(buf,buf2)
+ call push_selection_results(zmq_socket_push, pt2_data, buf, task_id(1), ctask)
+! buf%mini = buf2%mini
+ buf%cur = 0
+ end if
+ ctask = 0
+ call pt2_dealloc(pt2_data)
+
+ integer, external :: disconnect_from_taskserver
+ if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then
+ continue
+ endif
+
+ call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
+ call end_zmq_push_socket(zmq_socket_push,thread)
+ if (buffer_ready) then
+ call delete_selection_buffer(buf)
+! call delete_selection_buffer(buf2)
+ endif
+end subroutine
+
+
+subroutine push_selection_results(zmq_socket_push, pt2_data, b, task_id, ntasks)
+ use f77_zmq
+ use selection_types
+ implicit none
+
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_push
+ type(pt2_type), intent(in) :: pt2_data
+ type(selection_buffer), intent(inout) :: b
+ integer, intent(in) :: ntasks, task_id(*)
+ integer :: rc
+ double precision, allocatable :: pt2_serialized(:)
+
+ rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)
+ if(rc /= 4) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE)'
+ endif
+
+
+ allocate(pt2_serialized (pt2_type_size(N_states)) )
+ call pt2_serialize(pt2_data,N_states,pt2_serialized)
+
+ rc = f77_zmq_send( zmq_socket_push, pt2_serialized, size(pt2_serialized)*8, ZMQ_SNDMORE)
+ if (rc == -1) then
+ print *, irp_here, ': error sending result'
+ stop 3
+ return
+ else if(rc /= size(pt2_serialized)*8) then
+ stop 'push'
+ endif
+ deallocate(pt2_serialized)
+
+ if (b%cur > 0) then
+
+ rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)
+ if(rc /= 8*b%cur) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE)'
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)
+ if(rc /= bit_kind*N_int*2*b%cur) then
+ print *, 'f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE)'
+ endif
+
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)
+ if(rc /= 4) then
+ print *, 'f77_zmq_send( zmq_socket_push, ntasks, 4, ZMQ_SNDMORE)'
+ endif
+
+ rc = f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)
+ if(rc /= 4*ntasks) then
+ print *, 'f77_zmq_send( zmq_socket_push, task_id(1), ntasks*4, 0)'
+ endif
+
+! Activate is zmq_socket_push is a REQ
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+ character*(2) :: ok
+ rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
+ if ((rc /= 2).and.(ok(1:2) /= 'ok')) then
+ print *, irp_here//': error in receiving ok'
+ stop -1
+ endif
+IRP_ENDIF
+
+end subroutine
+
+
+subroutine pull_selection_results(zmq_socket_pull, pt2_data, val, det, N, task_id, ntasks)
+ use f77_zmq
+ use selection_types
+ implicit none
+ integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
+ type(pt2_type), intent(inout) :: pt2_data
+ double precision, intent(out) :: val(*)
+ integer(bit_kind), intent(out) :: det(N_int, 2, *)
+ integer, intent(out) :: N, ntasks, task_id(*)
+ integer :: rc, rn, i
+ double precision, allocatable :: pt2_serialized(:)
+
+ rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0)
+ if(rc /= 4) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, N, 4, 0)'
+ endif
+
+ allocate(pt2_serialized (pt2_type_size(N_states)) )
+ rc = f77_zmq_recv( zmq_socket_pull, pt2_serialized, 8*size(pt2_serialized), 0)
+ if (rc == -1) then
+ ntasks = 1
+ task_id(1) = 0
+ else if(rc /= 8*size(pt2_serialized)) then
+ stop 'pull'
+ endif
+
+ call pt2_deserialize(pt2_data,N_states,pt2_serialized)
+ deallocate(pt2_serialized)
+
+ if (N>0) then
+ rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)
+ if(rc /= 8*N) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0)'
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)
+ if(rc /= bit_kind*N_int*2*N) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0)'
+ endif
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)
+ if(rc /= 4) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, ntasks, 4, 0)'
+ endif
+
+ rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)
+ if(rc /= 4*ntasks) then
+ print *, 'f77_zmq_recv( zmq_socket_pull, task_id(1), ntasks*4, 0)'
+ endif
+
+! Activate is zmq_socket_pull is a REP
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+ rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
+ if (rc /= 2) then
+ print *, irp_here//': error in sending ok'
+ stop -1
+ endif
+IRP_ENDIF
+end subroutine
+
+
+
diff --git a/src/cipsi/selection_buffer.irp.f b/src/cipsi_utils/selection_buffer.irp.f
similarity index 100%
rename from src/cipsi/selection_buffer.irp.f
rename to src/cipsi_utils/selection_buffer.irp.f
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection_types.f90 b/src/cipsi_utils/selection_types.f90
similarity index 100%
rename from plugins/local/cipsi_tc_bi_ortho/selection_types.f90
rename to src/cipsi_utils/selection_types.f90
diff --git a/src/cipsi/selection_weight.irp.f b/src/cipsi_utils/selection_weight.irp.f
similarity index 100%
rename from src/cipsi/selection_weight.irp.f
rename to src/cipsi_utils/selection_weight.irp.f
diff --git a/src/cipsi/slave_cipsi.irp.f b/src/cipsi_utils/slave_cipsi.irp.f
similarity index 98%
rename from src/cipsi/slave_cipsi.irp.f
rename to src/cipsi_utils/slave_cipsi.irp.f
index ddfc050e..8be48f40 100644
--- a/src/cipsi/slave_cipsi.irp.f
+++ b/src/cipsi_utils/slave_cipsi.irp.f
@@ -303,10 +303,11 @@ subroutine run_slave_main
PROVIDE global_selection_buffer pt2_N_teeth pt2_F N_det_generators
PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
- PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+ PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order
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_bilinear_matrix_transp_order psi_selectors_coef_transp
PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks
+ call provide_for_zmq_pt2
if (mpi_master) then
print *, 'Running PT2'
From 6b7f2411b17c87368cbe56a03aad157819fcd1aa Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 17:31:49 +0100
Subject: [PATCH 052/140] Add NEED in cipsi_utils
---
src/cipsi_utils/NEED | 1 +
1 file changed, 1 insertion(+)
create mode 100644 src/cipsi_utils/NEED
diff --git a/src/cipsi_utils/NEED b/src/cipsi_utils/NEED
new file mode 100644
index 00000000..d3d4d2c7
--- /dev/null
+++ b/src/cipsi_utils/NEED
@@ -0,0 +1 @@
+determinants
From 37588e520766f303acaecd26b1dc16484b69f80f Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 17:32:38 +0100
Subject: [PATCH 053/140] Add NEED in generators_full_tc
---
src/generators_full_tc/NEED | 2 ++
1 file changed, 2 insertions(+)
create mode 100644 src/generators_full_tc/NEED
diff --git a/src/generators_full_tc/NEED b/src/generators_full_tc/NEED
new file mode 100644
index 00000000..0cf7d3aa
--- /dev/null
+++ b/src/generators_full_tc/NEED
@@ -0,0 +1,2 @@
+determinants
+hartree_fock
From 0618372b29284e16aeb3dd0cfc9b62377571a03d Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 12 Mar 2024 17:38:30 +0100
Subject: [PATCH 054/140] Commented out select_singles in TC
---
plugins/local/cipsi_tc_bi_ortho/selection.irp.f | 8 ++++----
src/.gitignore | 1 +
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 9b8cc81e..b1c02102 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -88,10 +88,10 @@ subroutine select_connected(i_generator,E0,pt2_data,b,subset,csubset)
particle_mask(k,1) = iand(generators_bitmask(k,1,s_part), not(psi_det_generators(k,1,i_generator)) )
particle_mask(k,2) = iand(generators_bitmask(k,2,s_part), not(psi_det_generators(k,2,i_generator)) )
enddo
- if ((subset == 1).and.(sum(hole_mask(:,2)) == 0_bit_kind)) then
- ! No beta electron to excite
- call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b)
- endif
+! if ((subset == 1).and.(sum(hole_mask(:,2)) == 0_bit_kind)) then
+! ! No beta electron to excite
+! call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b)
+! endif
call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2_data,b,subset,csubset)
deallocate(fock_diag_tmp)
end subroutine
diff --git a/src/.gitignore b/src/.gitignore
index 6353c21a..abc6a4c0 100644
--- a/src/.gitignore
+++ b/src/.gitignore
@@ -1,5 +1,6 @@
*
!README.rst
+!NEED
!*/
*/*
!*/*.*
From fdc418d72a12eb307a0cf875225794fbd37dde11 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 17:45:50 +0100
Subject: [PATCH 055/140] fixed print in TC
---
plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 1 +
plugins/local/fci_tc_bi/diagonalize_ci.irp.f | 6 ++++--
2 files changed, 5 insertions(+), 2 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 8863b7bc..721564e6 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -91,6 +91,7 @@ subroutine run_stochastic_cipsi
to_select = max(N_states_diag, to_select)
E_denom = E_tc ! TC Energy of the current wave function
+ print*,'E_tc = ',E_tc
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
diff --git a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
index a5242b87..5fcce5eb 100644
--- a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
+++ b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
@@ -55,9 +55,11 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
! write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tot/norm,E_tc + rpt2_tot/norm,pt2_minus, pt2_plus
! print*,'*****'
! endif
-! E_tc(k) = eigval_right_tc_bi_orth(k)
-! norm(k) = norm_ground_left_right_bi_orth(k)
! enddo
+ do k = 1, N_states
+ E_tc(k) = eigval_right_tc_bi_orth(k)
+ norm(k) = norm_ground_left_right_bi_orth(k)
+ enddo
psi_energy(1:N_states) = eigval_right_tc_bi_orth(1:N_states) - nuclear_repulsion
psi_s2(1:N_states) = s2_eigvec_tc_bi_orth(1:N_states)
From a56488e3a865dccc98d7984dd2cc4a7be1885539 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 12 Mar 2024 18:23:09 +0100
Subject: [PATCH 056/140] fci_tc_bi_ortho works for multi state ninja
---
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 57 ++++---------------
plugins/local/fci_tc_bi/diagonalize_ci.irp.f | 42 +-------------
.../local/tc_bi_ortho/psi_det_tc_sorted.irp.f | 8 ++-
src/cipsi/pt2_stoch_routines.irp.f | 2 +-
src/cipsi_utils/slave_cipsi.irp.f | 2 +-
5 files changed, 20 insertions(+), 91 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 721564e6..99a8de7e 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -11,15 +11,13 @@ subroutine run_stochastic_cipsi
implicit none
integer :: i, j, k, ndet
integer :: to_select
- logical :: print_pt2
logical :: has
type(pt2_type) :: pt2_data, pt2_data_err
double precision :: rss
- double precision :: correlation_energy_ratio, E_denom, E_tc, norm
+ double precision :: correlation_energy_ratio
double precision :: hf_energy_ref
double precision :: relative_error
- double precision, allocatable :: ept2(:), pt1(:), extrap_energy(:)
- double precision, allocatable :: zeros(:)
+ double precision, allocatable :: zeros(:),E_tc(:), norm(:)
logical, external :: qp_stop
double precision, external :: memory_of_double
@@ -32,14 +30,13 @@ subroutine run_stochastic_cipsi
write(*,*) i, Fock_matrix_tc_mo_tot(i,i)
enddo
- N_iter = 1
threshold_generators = 1.d0
SOFT_TOUCH threshold_generators
rss = memory_of_double(N_states)*4.d0
call check_mem(rss, irp_here)
- allocate(zeros(N_states))
+ allocate(zeros(N_states),E_tc(N_states), norm(N_states))
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
@@ -55,8 +52,7 @@ subroutine run_stochastic_cipsi
! if (s2_eig) then
! call make_s2_eigenfunction
! endif
- print_pt2 = .False.
- call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm)
! if (N_det > N_det_max) then
@@ -67,19 +63,16 @@ subroutine run_stochastic_cipsi
! if (s2_eig) then
! call make_s2_eigenfunction
! endif
-! print_pt2 = .False.
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
+! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm)
! call routine_save_right
! endif
- allocate(ept2(1000),pt1(1000),extrap_energy(100))
correlation_energy_ratio = 0.d0
! thresh_it_dav = 5.d-5
! soft_touch thresh_it_dav
- print_pt2 = .True.
do while( (N_det < N_det_max) .and. &
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max))
@@ -90,13 +83,12 @@ subroutine run_stochastic_cipsi
to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
to_select = max(N_states_diag, to_select)
- E_denom = E_tc ! TC Energy of the current wave function
print*,'E_tc = ',E_tc
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
- call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
+ call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
@@ -117,48 +109,19 @@ subroutine run_stochastic_cipsi
PROVIDE psi_det
PROVIDE psi_det_sorted_tc
- ept2(N_iter-1) = E_tc + nuclear_repulsion + (pt2_data % pt2(1))/norm
- pt1(N_iter-1) = dsqrt(pt2_data % overlap(1,1))
- call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm)
! stop
if (qp_stop()) exit
enddo
-! print*,'data to extrapolate '
-! do i = 2, N_iter
-! print*,'iteration ',i
-! print*,'pt1,Ept2',pt1(i),ept2(i)
-! call get_extrapolated_energy(i-1,ept2(i),pt1(i),extrap_energy(i))
-! do j = 2, i
-! print*,'j,e,energy',j,extrap_energy(j)
-! enddo
-! enddo
-
-! thresh_it_dav = 5.d-6
-! soft_touch thresh_it_dav
call pt2_dealloc(pt2_data)
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
- call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
-! if (.not.qp_stop()) then
-! if (N_det < N_det_max) then
-! thresh_it_dav = 5.d-7
-! soft_touch thresh_it_dav
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
-! endif
-!
-! call pt2_dealloc(pt2_data)
-! call pt2_dealloc(pt2_data_err)
-! call pt2_alloc(pt2_data, N_states)
-! call pt2_alloc(pt2_data_err, N_states)
-! call ZMQ_pt2(E_denom, pt2_data, pt2_data_err, relative_error, 0) ! Stochastic PT2
-! call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
-! endif
-! call pt2_dealloc(pt2_data)
-! call pt2_dealloc(pt2_data_err)
-! call routine_save_right
+ call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm)
+ call pt2_dealloc(pt2_data)
+ call pt2_dealloc(pt2_data_err)
end
diff --git a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
index 5fcce5eb..85518116 100644
--- a/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
+++ b/plugins/local/fci_tc_bi/diagonalize_ci.irp.f
@@ -1,7 +1,7 @@
! ---
-subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
+subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm )
BEGIN_DOC
! Replace the coefficients of the CI states by the coefficients of the
@@ -12,50 +12,10 @@ subroutine diagonalize_CI_tc_bi_ortho(ndet, E_tc, norm, pt2_data, print_pt2)
implicit none
integer, intent(inout) :: ndet ! number of determinants from before
double precision, intent(inout) :: E_tc(N_states), norm(N_states) ! E and norm from previous wave function
- type(pt2_type) , intent(in) :: pt2_data ! PT2 from previous wave function
- logical, intent(in) :: print_pt2
integer :: i, j,k
- double precision:: pt2_minus,pt2_plus,pt2_tot, pt2_abs,pt1_norm,rpt2_tot
- double precision :: error_pt2_minus, error_pt2_plus, error_pt2_tot, error_pt2_abs
PROVIDE mo_l_coef mo_r_coef
-! print*,'*****'
-! print*,'New wave function information'
-! print*,'N_det tc = ',N_det
-! do k = 1, N_states
-! print*,'************'
-! print*,'State ',k
-! pt2_plus = pt2_data % variance(k)
-! pt2_minus = pt2_data % pt2(k)
-! pt2_abs = pt2_plus - pt2_minus
-! pt2_tot = pt2_plus + pt2_minus
-!
-! pt1_norm = pt2_data % overlap(k,k)
-! rpt2_tot = pt2_tot / (1.d0 + pt1_norm)
-!
-!
-! print*,'norm_ground_left_right_bi_orth = ',norm_ground_left_right_bi_orth(k)
-! print*,'eigval_right_tc = ',eigval_right_tc_bi_orth(k)
-! 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_tot
-! print*,'rPT2 = ',rpt2_tot
-! print*,'|PT2| = ',pt2_abs
-! print*,'Positive PT2 = ',pt2_plus
-! print*,'Negative PT2 = ',pt2_minus
-! print*,'E(before) + PT2 = ',E_tc + pt2_tot/norm
-! print*,'E(before) +rPT2 = ',E_tc + rpt2_tot/norm
-! write(*,'(A28,X,I10,X,100(F16.8,X))')'Ndet,E,E+PT2,E+RPT2,|PT2|=',ndet,E_tc ,E_tc + pt2_tot/norm,E_tc + rpt2_tot/norm,pt2_minus, pt2_plus
-! print*,'*****'
-! endif
-! enddo
do k = 1, N_states
E_tc(k) = eigval_right_tc_bi_orth(k)
norm(k) = norm_ground_left_right_bi_orth(k)
diff --git a/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
index 5dad91ca..eef99de8 100644
--- a/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
+++ b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
@@ -11,10 +11,16 @@ BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ]
psi_average_norm_contrib_tc(:) = 0.d0
do k=1,N_states
do i=1,N_det
- psi_average_norm_contrib_tc(i) = &
+! print*,dabs(psi_l_coef_bi_ortho(i,k)*psi_r_coef_bi_ortho(i,k)),psi_l_coef_bi_ortho(i,k),psi_r_coef_bi_ortho(i,k)
+ 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
+! print*,'***'
+! do i = 1, N_det
+! print*,psi_average_norm_contrib_tc(i)
+! enddo
+ print*,'sum(psi_average_norm_contrib_tc(1:N_det))',sum(psi_average_norm_contrib_tc(1:N_det))
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
diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f
index 228e0ef1..bd5943da 100644
--- a/src/cipsi/pt2_stoch_routines.irp.f
+++ b/src/cipsi/pt2_stoch_routines.irp.f
@@ -1,3 +1,3 @@
subroutine provide_for_zmq_pt2
- PROVIDE psi_selectors_coef_transp psi_det_sorted psi_det_sorted_order
+ PROVIDE psi_selectors_coef_transp psi_det_sorted psi_det_sorted_order psi_det_hii
end
diff --git a/src/cipsi_utils/slave_cipsi.irp.f b/src/cipsi_utils/slave_cipsi.irp.f
index 8be48f40..3e778270 100644
--- a/src/cipsi_utils/slave_cipsi.irp.f
+++ b/src/cipsi_utils/slave_cipsi.irp.f
@@ -306,7 +306,7 @@ subroutine run_slave_main
PROVIDE psi_bilinear_matrix_rows psi_bilinear_matrix_order
PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp
- PROVIDE psi_det_hii selection_weight pseudo_sym pt2_min_parallel_tasks
+ PROVIDE selection_weight pseudo_sym pt2_min_parallel_tasks
call provide_for_zmq_pt2
if (mpi_master) then
From 1dbde5643920054cc16f148c50d84fed01a88b13 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Wed, 13 Mar 2024 07:04:54 +0100
Subject: [PATCH 057/140] O(N4) -> O(N3) transformations
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 19 ++++++++++++++++---
plugins/local/tc_keywords/EZFIO.cfg | 7 +++++++
2 files changed, 23 insertions(+), 3 deletions(-)
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index bf5cc36f..79bfd336 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -41,7 +41,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
implicit none
integer :: i, j, k, l, m, n, p, q, s, r
- double precision :: t1, t2
+ double precision :: t1, t2, tt1, tt2
double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:)
@@ -60,9 +60,11 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
allocate(a_kpq(ao_num,mo_num,mo_num))
allocate(a_pqr(mo_num,mo_num,mo_num))
- do s = 1, mo_num
- mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0
+ call wall_time(tt1)
+ do s = 1, mo_num
+
+ mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0
do l = 1, ao_num
call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
@@ -93,6 +95,17 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
!$OMP END PARALLEL
enddo ! l
+
+ if(s == 2) then
+ call wall_time(tt2)
+ print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0
+ elseif(s == 11) then
+ call wall_time(tt2)
+ print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/600.d0
+ endif
+
enddo ! s
deallocate(a_jkp, a_kpq, a_pqr)
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 93ff790f..a8491660 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -280,3 +280,10 @@ doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic
interface: ezfio,ocaml,provider
default: semi-analytic
+[ao_to_mo_tc_n3]
+type: logical
+doc: If |true|, memory scale of TC ao -> mo: O(N3)
+interface: ezfio,provider,ocaml
+default: False
+
+
From 88cf5d23f19985ec7bca38db6445a2b1607fc063 Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 13 Mar 2024 11:20:03 +0100
Subject: [PATCH 058/140] changed print_tc_wf
---
plugins/local/tc_bi_ortho/print_tc_wf.irp.f | 3 ++-
plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f | 4 ++++
2 files changed, 6 insertions(+), 1 deletion(-)
diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
index c755485b..2b88bc5b 100644
--- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
@@ -37,7 +37,8 @@ subroutine write_l_r_wf
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_l_coef_sorted_bi_ortho_left(1) &
+ write(i_unit_output,*)i, psi_coef_sorted_tc(i,1)/psi_coef_sorted_tc(i,1) &
+ , psi_l_coef_sorted_bi_ortho_left(i)/psi_l_coef_sorted_bi_ortho_left(1) &
, psi_r_coef_sorted_bi_ortho_right(i)/psi_r_coef_sorted_bi_ortho_right(1)
enddo
diff --git a/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
index eef99de8..3996ca4c 100644
--- a/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
+++ b/plugins/local/tc_bi_ortho/psi_det_tc_sorted.irp.f
@@ -25,6 +25,10 @@ BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_tc, (psi_det_size) ]
do i=1,N_det
psi_average_norm_contrib_tc(i) = psi_average_norm_contrib_tc(i)*f
enddo
+ f = 0.d0
+ do i=1,N_det
+ f+= psi_average_norm_contrib_tc(i)
+ enddo
END_PROVIDER
From cfdaf722df84c98ba231d3153e7ee3747300c193 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 15 Mar 2024 15:40:18 +0100
Subject: [PATCH 059/140] added the keyword to minimize tc angles at the end of
TC SCF
---
plugins/local/tc_keywords/EZFIO.cfg | 5 +++++
plugins/local/tc_scf/tc_scf.irp.f | 4 +++-
2 files changed, 8 insertions(+), 1 deletion(-)
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 93ff790f..bc691fc3 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -280,3 +280,8 @@ doc: approach used to evaluate TC integrals [ analytic | numeric | semi-analytic
interface: ezfio,ocaml,provider
default: semi-analytic
+[minimize_lr_angles]
+type: logical
+doc: If |true|, you minimize the angle between the left and right vectors associated to degenerate orbitals
+interface: ezfio,provider,ocaml
+default: False
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index d8c5ab66..768069d6 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -78,7 +78,9 @@ program tc_scf
! TODO
! rotate angles in separate code only if necessary
- !call minimize_tc_orb_angles()
+ if(minimize_lr_angles)then
+ call minimize_tc_orb_angles()
+ endif
call print_energy_and_mos(good_angles)
endif
From cb8c823a2c098f7023d0e858f77ab5b88cf9f518 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 15 Mar 2024 16:27:02 +0100
Subject: [PATCH 060/140] added script_tc_bh_h2o_gd_exc.sh in fci_tc_bi
---
.../fci_tc_bi/script_tc_bh_h2o_gd_exc.sh | 85 +++++++++++++++++++
1 file changed, 85 insertions(+)
create mode 100755 plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh
diff --git a/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh b/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh
new file mode 100755
index 00000000..0d655fdd
--- /dev/null
+++ b/plugins/local/fci_tc_bi/script_tc_bh_h2o_gd_exc.sh
@@ -0,0 +1,85 @@
+#!/bin/bash
+
+source ~/qp2/quantum_package.rc
+
+## Define the system/basis/charge/mult and genric keywords
+system=H2O
+xyz=${system}.xyz
+basis=6-31g
+mult=1
+charge=0
+j2e_type="Boys_Handy"
+thresh_tcscf=1e-10
+io_tc_integ="Write"
+nstates=4
+
+
+
+##################### Function to create the EZFIO
+function create_ezfio (){
+ qp create_ezfio -b $basis -m $mult -c $charge $xyz -o $ezfio
+ qp run scf | tee ${EZFIO_FILE}.scf.out
+}
+
+##################### Function to set parameters for BH9 jastrow
+function BH_9 (){
+ j2e_type="Boys_Handy" # type of correlation factor: Boys Handy type
+ env_type="None" # Boys Handy J does not use our envelopes
+ j1e_type="None" # Boys Handy J does not use our J1body
+ tc_integ_type="numeric" # Boys Handy requires numerical integrals
+ jBH_size=9 # Number of parameters for the BH
+
+######## All parameters for the H2O and Boys Handy Jastrow
+ jBH_c=[[0.50000,-0.57070,0.49861,-0.78663,0.01990,0.13386,-0.60446,-1.67160,1.36590],[0.0,0.0,0.0,0.0,0.12063,-0.18527,0.12324,-0.11187,-0.06558],[0.0,0.0,0.0,0.0,0.12063,-0.18527,0.12324,-0.11187,-0.06558]]
+ jBH_m=[[0,0,0,0,2,3,4,2,2],[0,0,0,0,2,3,4,2,2],[0,0,0,0,2,3,4,2,2]]
+ jBH_n=[[0,0,0,0,0,0,0,2,0],[0,0,0,0,0,0,0,2,0],[0,0,0,0,0,0,0,2,0]]
+ jBH_o=[[1,2,3,4,0,0,0,0,2],[1,2,3,4,0,0,0,0,2],[1,2,3,4,0,0,0,0,2]]
+ jBH_ee=[1.0,1.0,1.0]
+ jBH_en=[1.0,1.0,1.0]
+
+ set_BH_J_keywords
+}
+
+
+function set_BH_J_keywords (){
+ qp set jastrow j2e_type $j2e_type # set the jastrow two-e type
+ qp set jastrow env_type $env_type
+ qp set jastrow j1e_type $j1e_type
+ qp set jastrow jBH_size $jBH_size # set the number of parameters in Boys-Handy jastrow
+ qp set jastrow jBH_c "$jBH_c" # set the parameters which are lists for Boys-Handy
+ qp set jastrow jBH_m "$jBH_m" #
+ qp set jastrow jBH_n "$jBH_n" #
+ qp set jastrow jBH_o "$jBH_o" #
+ qp set jastrow jBH_ee $jBH_ee #
+ qp set jastrow jBH_en $jBH_en #
+ qp set tc_keywords tc_integ_type $tc_integ_type # set the analytical or numerical integrals
+ qp set tc_keywords thresh_tcscf $thresh_tcscf
+ qp set tc_keywords io_tc_integ $io_tc_integ # set the io
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+}
+
+function run_ground_state (){
+ qp set tc_keywords minimize_lr_angles True
+ qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
+ qp set_frozen_core
+ qp set determinants n_det_max 1e6
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi.out
+}
+
+function run_excited_state (){
+ qp set determinants n_states $nstates
+ qp run cis | tee ${EZFIO_FILE}.cis.out
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+ qp run tc_bi_ortho | tee ${EZFIO_FILE}.tc_cis_nst_${nstates}.out
+ qp set determinants read_wf True
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi_nst_${nstates}.out
+
+}
+
+
+## BH9 calculations
+ezfio=${system}_${charge}_${basis}_${j2e_type}
+create_ezfio
+BH_9
+run_ground_state
+run_excited_state
From a8de10987febc04dd3c416451e27a87ed50e4034 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 15 Mar 2024 17:10:22 +0100
Subject: [PATCH 061/140] added script_tc_jmu_h2o_gd_exc.sh
---
.../fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh | 84 +++++++++++++++++++
plugins/local/tc_bi_ortho/TODO | 2 +
2 files changed, 86 insertions(+)
create mode 100755 plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh
create mode 100644 plugins/local/tc_bi_ortho/TODO
diff --git a/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh b/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh
new file mode 100755
index 00000000..e74888ec
--- /dev/null
+++ b/plugins/local/fci_tc_bi/script_tc_jmu_h2o_gd_exc.sh
@@ -0,0 +1,84 @@
+#!/bin/bash
+source ~/qp2/quantum_package.rc
+
+## Define the system/basis/charge/mult and genric keywords
+system=H2O
+xyz=${system}.xyz
+basis=6-31g
+mult=1
+charge=0
+j2e_type=Mu
+thresh_tcscf=1e-10
+io_tc_integ="Write"
+nstates=4
+nol_standard=False
+tc_integ_type=numeric # can be changed for semi-analytic
+
+if (( $nol_standard == "False" ))
+then
+ three_body_h_tc=True
+else
+ three_body_h_tc=False
+fi
+
+
+##################### Function to create the EZFIO
+function create_ezfio (){
+ qp create_ezfio -b $basis -m $mult -c $charge $xyz -o $ezfio
+ qp run scf | tee ${EZFIO_FILE}.scf.out
+}
+
+function set_env_j_keywords (){
+
+ qp set hamiltonian mu_erf 0.87
+ qp set jastrow env_type Sum_Gauss
+ qp set jastrow env_coef "${coef}"
+ qp set tc_keywords tc_integ_type $tc_integ_type
+ qp set jastrow j1e_type $j1e_type
+ qp set jastrow j2e_type $j2e_type
+ qp set jastrow env_expo "${alpha}"
+}
+
+function run_ground_state (){
+ qp set tc_keywords minimize_lr_angles True
+ qp run tc_scf | tee ${EZFIO_FILE}.tc_scf.out
+ qp set_frozen_core
+ qp set determinants n_det_max 1e6
+ qp set perturbation pt2_max 0.001
+ qp set tc_keywords nol_standard $nol_standard
+ qp set tc_keywords three_body_h_tc $three_body_h_tc
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi.out
+}
+
+function run_excited_state (){
+ qp set determinants n_states $nstates
+ qp run cis | tee ${EZFIO_FILE}.cis.out
+ rm ${EZFIO_FILE}/tc_bi_ortho/psi_*
+ qp run tc_bi_ortho | tee ${EZFIO_FILE}.tc_cis_nst_${nstates}.out
+ qp set determinants read_wf True
+ qp run fci_tc_bi_ortho | tee ${EZFIO_FILE}.fci_tc_bi_nst_${nstates}.out
+
+}
+
+
+# Define J(mu) with envelope and without j1e
+j2e_type=Mu
+j1e_type=None
+ezfio=${system}_${charge}_${basis}_${j2e_type}_${j1e_type}
+create_ezfio
+alpha=[2.0,1000.,1000.] # parameters for H2O
+coef=[1.,1.,1.] # parameters for H2O
+set_env_j_keywords
+run_ground_state
+run_excited_state
+
+# Define J(mu) with envelope and with a charge Harmonizer for J1e
+j2e_type=Mu
+j1e_type=Charge_Harmonizer
+ezfio=${system}_${charge}_${basis}_${j2e_type}_${j1e_type}
+create_ezfio
+alpha=[2.5,1000.,1000.] # parameters for H2O
+coef=[1.,1.,1.] # parameters for H2O
+set_env_j_keywords
+run_ground_state
+run_excited_state
diff --git a/plugins/local/tc_bi_ortho/TODO b/plugins/local/tc_bi_ortho/TODO
new file mode 100644
index 00000000..e1f195b8
--- /dev/null
+++ b/plugins/local/tc_bi_ortho/TODO
@@ -0,0 +1,2 @@
+S^2 !!
+Bi orthonormalize the eigenvectors of H_tc after Davidson or lapack
From 0a8d57abd91ab3ae73d693756528f0fb11874c5b Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 15 Mar 2024 18:19:00 +0100
Subject: [PATCH 062/140] Accelerated BH Jastrow
---
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 226 +++++++++++-------
1 file changed, 144 insertions(+), 82 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 31ad5756..33563102 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -4,7 +4,7 @@
subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
BEGIN_DOC
- !
+ !
! grad_1 u(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -167,9 +167,9 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
integer :: jpoint
integer :: i_nucl, p, mpA, npA, opA
double precision :: r2(3)
- double precision :: dx, dy, dz, r12, tmp
+ double precision :: dx, dy, dz, r12, tmp, r12_inv
double precision :: mu_val, mu_tmp, mu_der(3)
- double precision :: rn(3), f1A, gard1_f1A(3), f2A, gard2_f2A(3), g12, gard1_g12(3)
+ double precision :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
double precision :: tmp1, tmp2
@@ -181,7 +181,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
! d/dy1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
! d/dz1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -191,15 +191,19 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt(dx * dx + dy * dy + dz * dz)
- if(r12 .lt. 1d-10) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ r12 = dx * dx + dy * dy + dz * dz
+
+ if(r12 .lt. 1d-20) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
- tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
+ r12_inv = 1.d0/dsqrt(r12)
+ r12 = r12*r12_inv
+
+ tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) * r12_inv
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
@@ -208,10 +212,10 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Mur") then
- ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
+ ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -220,23 +224,29 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt(dx * dx + dy * dy + dz * dz)
- call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
- mu_tmp = mu_val * r12
- tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
- gradx(jpoint) = tmp * mu_der(1)
- grady(jpoint) = tmp * mu_der(2)
- gradz(jpoint) = tmp * mu_der(3)
+ r12 = dx * dx + dy * dy + dz * dz
- if(r12 .lt. 1d-10) then
+ if(r12 .lt. 1d-20) then
gradx(jpoint) = 0.d0
grady(jpoint) = 0.d0
gradz(jpoint) = 0.d0
cycle
endif
- tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
+ r12_inv = 1.d0/dsqrt(r12)
+ r12 = r12*r12_inv
+
+ call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+
+ mu_tmp = mu_val * r12
+ tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+
+ gradx(jpoint) = tmp * mu_der(1)
+ grady(jpoint) = tmp * mu_der(2)
+ gradz(jpoint) = tmp * mu_der(3)
+
+ tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) * r12_inv
gradx(jpoint) = gradx(jpoint) + tmp * dx
grady(jpoint) = grady(jpoint) + tmp * dy
@@ -254,7 +264,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
PROVIDE a_boys
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -263,14 +273,17 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ r12 = dx * dx + dy * dy + dz * dz
+
if(r12 .lt. 1d-10) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
+ r12 = dsqrt(r12)
+
tmp = 1.d0 + a_boys * r12
tmp = 0.5d0 / (r12 * tmp * tmp)
@@ -281,24 +294,60 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Boys_Handy") then
+ integer :: powmax
+ powmax = max(maxval(jBH_m),maxval(jBH_n))
+
+ double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
+ allocate (f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
+
+ do p=0,powmax
+ double_p(p) = dble(p)
+ enddo
+
+ f1A_power(-1) = 0.d0
+ f2A_power(-1) = 0.d0
+ g12_power(-1) = 0.d0
+
+ f1A_power(0) = 1.d0
+ f2A_power(0) = 1.d0
+ g12_power(0) = 1.d0
+
do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
- do i_nucl = 1, nucl_num
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+
+ do i_nucl = 1, nucl_num
rn(1) = nucl_coord(i_nucl,1)
rn(2) = nucl_coord(i_nucl,2)
rn(3) = nucl_coord(i_nucl,3)
- call jBH_elem_fct_grad(jBH_en(i_nucl), r1, rn, f1A, gard1_f1A)
- call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, gard2_f2A)
- call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, gard1_g12)
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r1, rn, f1A, grad1_f1A)
+ call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, grad2_f2A)
+ call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, grad1_g12)
+
+
+ ! Compute powers of f1A and f2A
+
+ do p = 1, maxval(jBH_m(:,i_nucl))
+ f1A_power(p) = f1A_power(p-1) * f1A
+ enddo
+
+ do p = 1, maxval(jBH_n(:,i_nucl))
+ f2A_power(p) = f2A_power(p-1) * f2A
+ enddo
+
+ do p = 1, maxval(jBH_o(:,i_nucl))
+ g12_power(p) = g12_power(p-1) * g12
+ enddo
+
+
do p = 1, jBH_size
mpA = jBH_m(p,i_nucl)
@@ -309,23 +358,31 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
tmp = tmp * 0.5d0
endif
- tmp1 = 0.d0
- if(mpA .gt. 0) then
- tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
- endif
- if(npA .gt. 0) then
- tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
- endif
- tmp1 = tmp1 * g12**dble(opA)
+!TODO : Powers to optimize here
- tmp2 = 0.d0
- if(opA .gt. 0) then
- tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
- endif
+! tmp1 = 0.d0
+! if(mpA .gt. 0) then
+! tmp1 = tmp1 + dble(mpA) * f1A**(mpA-1) * f2A**npA
+! endif
+! if(npA .gt. 0) then
+! tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA
+! endif
+! tmp1 = tmp1 * g12**(opA)
+!
+! tmp2 = 0.d0
+! if(opA .gt. 0) then
+! tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(mpA))
+! endif
- gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * gard1_f1A(1) + tmp2 * gard1_g12(1))
- grady(jpoint) = grady(jpoint) + tmp * (tmp1 * gard1_f1A(2) + tmp2 * gard1_g12(2))
- gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * gard1_f1A(3) + tmp2 * gard1_g12(3))
+ tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
+ tmp1 = tmp1 * g12_power(opA)
+
+ tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
+
+
+ gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
+ grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
+ gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
enddo ! p
enddo ! i_nucl
enddo ! jpoint
@@ -361,10 +418,10 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
integer :: jpoint
double precision :: r2(3)
- double precision :: dx, dy, dz, r12, tmp
+ double precision :: dx, dy, dz, r12, r12_inv, tmp
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -374,15 +431,19 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt(dx * dx + dy * dy + dz * dz)
- if(r12 .lt. 1d-10) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ r12 = dx * dx + dy * dy + dz * dz
+
+ if(r12 .lt. 1d-20) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
- tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
+ r12_inv = 1.d0 / dsqrt(r12)
+ r12 = r12 * r12_inv
+
+ tmp = 0.5d0 * (1.d0 - derf(mu * r12)) * r12_inv
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
@@ -406,7 +467,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
integer :: jpoint
double precision :: r2(3)
double precision :: dx, dy, dz
- double precision :: mu_tmp, r12
+ double precision :: mu_tmp, r12, mu_erf_inv
PROVIDE final_grid_points_extra
@@ -414,20 +475,21 @@ subroutine j12_r1_seq(r1, n_grid2, res)
PROVIDE mu_erf
- do jpoint = 1, n_points_extra_final_grid ! r2
-
+ mu_erf_inv = 1.d0 / mu_erf
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
-
+
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
mu_tmp = mu_erf * r12
-
- res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
+
+ res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) * mu_erf_inv
enddo
elseif(j2e_type .eq. "Boys") then
@@ -436,7 +498,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
PROVIDE a_boys
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -478,19 +540,19 @@ subroutine jmu_r1_seq(mu, r1, n_grid2, res)
tmp1 = inv_sq_pi_2 / mu
- do jpoint = 1, n_points_extra_final_grid ! r2
-
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
-
+
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
tmp2 = mu * r12
-
+
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(tmp2)) - tmp1 * dexp(-tmp2*tmp2)
enddo
@@ -517,7 +579,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -536,7 +598,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -556,7 +618,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -574,7 +636,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -604,7 +666,7 @@ end
subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
BEGIN_DOC
- !
+ !
! grad_1 u_2e(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -724,7 +786,7 @@ end
subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
BEGIN_DOC
- !
+ !
! u_2e(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -820,11 +882,11 @@ end
! ---
-subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, gard1_fct)
+subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct)
implicit none
double precision, intent(in) :: alpha, r1(3), r2(3)
- double precision, intent(out) :: fct, gard1_fct(3)
+ double precision, intent(out) :: fct, grad1_fct(3)
double precision :: dist, tmp1, tmp2
dist = dsqrt( (r1(1) - r2(1)) * (r1(1) - r2(1)) &
@@ -836,18 +898,18 @@ subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, gard1_fct)
fct = alpha * dist * tmp1
if(dist .lt. 1d-10) then
- gard1_fct(1) = 0.d0
- gard1_fct(2) = 0.d0
- gard1_fct(3) = 0.d0
+ grad1_fct(1) = 0.d0
+ grad1_fct(2) = 0.d0
+ grad1_fct(3) = 0.d0
else
tmp2 = alpha * tmp1 * tmp1 / dist
- gard1_fct(1) = tmp2 * (r1(1) - r2(1))
- gard1_fct(2) = tmp2 * (r1(2) - r2(2))
- gard1_fct(3) = tmp2 * (r1(3) - r2(3))
+ grad1_fct(1) = tmp2 * (r1(1) - r2(1))
+ grad1_fct(2) = tmp2 * (r1(2) - r2(2))
+ grad1_fct(3) = tmp2 * (r1(3) - r2(3))
endif
return
-end
+end
! ---
From a29c67a7381c5240ddabf9c02ae9e37a89831ee8 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Sat, 16 Mar 2024 15:21:40 +0100
Subject: [PATCH 063/140] Implemented #322
---
scripts/ezfio_interface/qp_edit_template | 140 ++++++++++++++---------
1 file changed, 86 insertions(+), 54 deletions(-)
diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template
index fe718a50..65c77384 100644
--- a/scripts/ezfio_interface/qp_edit_template
+++ b/scripts/ezfio_interface/qp_edit_template
@@ -8,14 +8,14 @@ open Sexplib.Std
(** Interactive editing of the input.
-WARNING
+WARNING
This file is automatically generated by
`${{QP_ROOT}}/scripts/ezfio_interface/ei_handler.py`
*)
(** Keywords used to define input sections *)
-type keyword =
+type keyword =
| Ao_basis
| Determinants_by_hand
| Electrons
@@ -37,7 +37,7 @@ let keyword_to_string = function
(** Create the header of the temporary file *)
-let file_header filename =
+let file_header filename =
Printf.sprintf "
==================================================================
Quantum Package
@@ -47,7 +47,7 @@ Editing file `%s`
" filename
-
+
(** Creates the header of a section *)
let make_header kw =
@@ -58,14 +58,14 @@ let make_header kw =
(** Returns the rst string of section [s] *)
-let get s =
+let get s =
let header = (make_header s) in
- let f (read,to_rst) =
+ let f (read,to_rst) =
match read () with
| Some text -> header ^ (Rst_string.to_string (to_rst text))
| None -> ""
in
- let rst =
+ let rst =
try
begin
let open Input in
@@ -84,27 +84,27 @@ let get s =
end
with
| Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "")
- in
+ in
rst
(** Applies the changes from the string [str] corresponding to section [s] *)
-let set str s =
+let set str s =
let header = (make_header s) in
match String_ext.substr_index ~pos:0 ~pattern:header str with
| None -> ()
- | Some idx ->
+ | Some idx ->
begin
let index_begin = idx + (String.length header) in
- let index_end =
+ let index_end =
match ( String_ext.substr_index ~pos:(index_begin+(String.length header)+1)
~pattern:"==" str) with
| Some i -> i
| None -> String.length str
in
let l = index_end - index_begin in
- let str = String.sub str index_begin l
+ let str = String.sub str index_begin l
|> Rst_string.of_string
in
let write (of_rst,w) s =
@@ -129,28 +129,36 @@ let set str s =
(** Creates the temporary file for interactive editing *)
-let create_temp_file ezfio_filename fields =
- let temp_filename = Filename.temp_file "qp_edit_" ".rst" in
+let create_temp_file ?filename ezfio_filename fields =
+ let temp_filename =
+ match filename with
+ | None -> Filename.temp_file "qp_edit_" ".rst"
+ | Some f -> f
+ in
+ let () =
+ match filename with
+ | None -> at_exit (fun () -> Sys.remove temp_filename)
+ | _ -> ()
+ in
begin
let oc = open_out temp_filename in
- (file_header ezfio_filename) :: (List.map get fields)
- |> String.concat "\n"
+ (file_header ezfio_filename) :: (List.map get fields)
+ |> String.concat "\n"
|> Printf.fprintf oc "%s";
close_out oc;
- at_exit (fun () -> Sys.remove temp_filename);
temp_filename
end
-
-let run check_only ?ndet ?state ezfio_filename =
+
+let run check_only ?ndet ?state ?read ?write ezfio_filename =
(* Set check_only if the arguments are not empty *)
let check_only =
- match ndet, state with
- | None, None -> check_only
+ match ndet, state, read with
+ | None, None, None -> check_only
| _ -> true
in
@@ -163,7 +171,7 @@ let run check_only ?ndet ?state ezfio_filename =
(* Clean qp_stop status *)
[ "qpstop" ; "qpkill" ]
|> List.iter (fun f ->
- let stopfile =
+ let stopfile =
Filename.concat (Qpackage.ezfio_work ezfio_filename) f
in
if Sys.file_exists stopfile then
@@ -173,7 +181,7 @@ let run check_only ?ndet ?state ezfio_filename =
(* Reorder basis set *)
begin
match Input.Ao_basis.read() with
- | Some aos ->
+ | Some aos ->
let ordering = Input.Ao_basis.ordering aos in
let test = Array.copy ordering in
Array.sort compare test ;
@@ -184,7 +192,7 @@ let run check_only ?ndet ?state ezfio_filename =
Input.Ao_basis.write new_aos;
match Input.Mo_basis.read() with
| None -> ()
- | Some mos ->
+ | Some mos ->
let new_mos = Input.Mo_basis.reorder mos ordering in
Input.Mo_basis.write new_mos
end
@@ -200,7 +208,7 @@ let run check_only ?ndet ?state ezfio_filename =
begin
match state with
| None -> ()
- | Some range ->
+ | Some range ->
begin
Input.Determinants_by_hand.extract_states range
end
@@ -210,14 +218,14 @@ let run check_only ?ndet ?state ezfio_filename =
(*
let output = (file_header ezfio_filename) :: (
List.map get [
- Ao_basis ;
- Mo_basis ;
+ Ao_basis ;
+ Mo_basis ;
])
in
String.concat output
|> print_string
*)
-
+
let tasks = [
Nuclei_by_hand ;
Ao_basis;
@@ -230,33 +238,41 @@ let run check_only ?ndet ?state ezfio_filename =
(* Create the temp file *)
let temp_filename =
- create_temp_file ezfio_filename tasks
+ match read, write with
+ | None, None -> create_temp_file ezfio_filename tasks
+ | Some filename, None -> filename
+ | None, filename -> create_temp_file ?filename ezfio_filename tasks
+ | x, y -> failwith "read and write options are incompatible"
in
- (* Open the temp file with external editor *)
- let editor =
- try Sys.getenv "EDITOR"
- with Not_found -> "vi"
+
+ let () =
+ match check_only with
+ | true -> ()
+ | false ->
+ begin
+ (* Open the temp file with external editor *)
+ let editor =
+ try Sys.getenv "EDITOR"
+ with Not_found -> "vi"
+ in
+ Printf.sprintf "%s %s" editor temp_filename
+ |> Sys.command |> ignore
+ end
in
- match check_only with
- | true -> ()
- | false ->
- Printf.sprintf "%s %s" editor temp_filename
- |> Sys.command |> ignore
- ;
-
- (* Re-read the temp file *)
- let temp_string =
- let ic = open_in temp_filename in
- let result =
- input_lines ic
- |> String.concat "\n"
+ if write = None then
+ (* Re-read the temp file *)
+ let temp_string =
+ let ic = open_in temp_filename in
+ let result =
+ input_lines ic
+ |> String.concat "\n"
+ in
+ close_in ic;
+ result
in
- close_in ic;
- result
- in
- List.iter (fun x -> set temp_string x) tasks
+ List.iter (fun x -> set temp_string x) tasks
@@ -264,7 +280,7 @@ let run check_only ?ndet ?state ezfio_filename =
(** Remove the backup file *)
let remove_backup ezfio_filename =
- let backup_filename =
+ let backup_filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
try Sys.remove backup_filename
@@ -273,7 +289,7 @@ let remove_backup ezfio_filename =
(** Create a backup file in case of an exception *)
let create_backup ezfio_filename =
remove_backup ezfio_filename;
- let backup_filename =
+ let backup_filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
try
@@ -289,7 +305,7 @@ let create_backup ezfio_filename =
(** Restore the backup file when an exception occuprs *)
let restore_backup ezfio_filename =
- let filename =
+ let filename =
Printf.sprintf "%s/work/backup.tar" ezfio_filename
in
if Sys.file_exists filename then
@@ -312,6 +328,16 @@ let () =
doc="Checks the input data";
arg=Without_arg; }};
+ {{
+ short='w'; long="write"; opt=Optional;
+ doc="Writes the qp_edit file to a file\"";
+ arg=With_arg ""; }};
+
+ {{
+ short='r'; long="read"; opt=Optional;
+ doc="Reads the file and applies it to the EZFIO\"";
+ arg=With_arg ""; }};
+
{{ short='n'; long="ndet"; opt=Optional;
doc="Truncates the wavefunction to the target number of determinants";
arg=With_arg ""; }};
@@ -328,6 +354,12 @@ let () =
end;
(* Handle options *)
+ let write =
+ Command_line.get "write"
+ in
+ let read =
+ Command_line.get "read"
+ in
let ndet =
match Command_line.get "ndet" with
| None -> None
@@ -353,7 +385,7 @@ let () =
(* Run the program *)
try
if (not c) then create_backup ezfio_filename;
- run c ?ndet ?state ezfio_filename
+ run c ?ndet ?state ?read ?write ezfio_filename
with
| Failure exc
| Invalid_argument exc ->
From 00859876d5f82e0f0281b658ae118b8d3ba484fa Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 18 Mar 2024 17:53:22 +0100
Subject: [PATCH 064/140] Fixed read/write in qp_edit
---
scripts/ezfio_interface/qp_edit_template | 16 ++++++----------
1 file changed, 6 insertions(+), 10 deletions(-)
diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template
index 65c77384..2380660e 100644
--- a/scripts/ezfio_interface/qp_edit_template
+++ b/scripts/ezfio_interface/qp_edit_template
@@ -156,10 +156,10 @@ let create_temp_file ?filename ezfio_filename fields =
let run check_only ?ndet ?state ?read ?write ezfio_filename =
(* Set check_only if the arguments are not empty *)
- let check_only =
- match ndet, state, read with
- | None, None, None -> check_only
- | _ -> true
+ let open_editor =
+ match ndet, state, read, write with
+ | None, None, None, None -> not check_only
+ | _ -> false
in
(* Open EZFIO *)
@@ -246,10 +246,7 @@ let run check_only ?ndet ?state ?read ?write ezfio_filename =
in
- let () =
- match check_only with
- | true -> ()
- | false ->
+ if open_editor then
begin
(* Open the temp file with external editor *)
let editor =
@@ -258,8 +255,7 @@ let run check_only ?ndet ?state ?read ?write ezfio_filename =
in
Printf.sprintf "%s %s" editor temp_filename
|> Sys.command |> ignore
- end
- in
+ end;
if write = None then
(* Re-read the temp file *)
From 83ed57312d9bc86dc2ec4cbc486491ded16d7053 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Tue, 19 Mar 2024 17:23:41 +0100
Subject: [PATCH 065/140] few modif in ao tc integ
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 25 +++++++++++++++++--
.../local/non_h_ints_mu/tc_integ_num.irp.f | 2 +-
.../local/non_h_ints_mu/total_tc_int.irp.f | 3 ++-
3 files changed, 26 insertions(+), 4 deletions(-)
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 79bfd336..1e558038 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -50,7 +50,7 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
call print_memory_usage()
PROVIDE mo_r_coef mo_l_coef
- PROVIDe ao_two_e_tc_tot
+ PROVIDE ao_two_e_tc_tot
if(ao_to_mo_tc_n3) then
@@ -103,9 +103,30 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
elseif(s == 11) then
call wall_time(tt2)
print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0
- print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/600.d0
+ print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0)
+ elseif(s == 26) then
+ call wall_time(tt2)
+ print*, ' 25 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-25)*(tt2-tt1)/(60.d0*25.d0)
+ elseif(s == 51) then
+ call wall_time(tt2)
+ print*, ' 50 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-50)*(tt2-tt1)/(60.d0*50.d0)
+ elseif(s == 101) then
+ call wall_time(tt2)
+ print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0)
+ elseif(s == 201) then
+ call wall_time(tt2)
+ print*, ' 200 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-200)*(tt2-tt1)/(60.d0*200.d0)
+ elseif(s == 501) then
+ call wall_time(tt2)
+ print*, ' 500 / mo_num done in (min)', (tt2-tt1)/60.d0
+ print*, ' estimated time required (min)', dble(mo_num-500)*(tt2-tt1)/(60.d0*500.d0)
endif
+
enddo ! s
deallocate(a_jkp, a_kpq, a_pqr)
diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
index e5d75c3d..6d446037 100644
--- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
@@ -131,7 +131,7 @@
deallocate(tmp)
call wall_time(time1)
- print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num =', time1-time0
+ print*, ' wall time for int2_grad1_u12_ao_num & int2_grad1_u12_square_ao_num = (min)', (time1-time0) / 60.d0
call print_memory_usage()
END_PROVIDER
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index ba078d9b..c7230dc3 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -201,7 +201,8 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
!$OMP END DO
!$OMP END PARALLEL
- call clear_ao_map()
+ !call clear_ao_map()
+ FREE ao_integrals_map
if(tc_integ_type .eq. "numeric") then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
From 183980943298f9738968507392a815a4f49f94f7 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 19 Mar 2024 14:47:01 +0100
Subject: [PATCH 066/140] Introduced all_shells_closed
---
src/scf_utils/fock_matrix.irp.f | 18 ++++++++----------
src/scf_utils/scf_density_matrix_ao.irp.f | 10 +++++++++-
2 files changed, 17 insertions(+), 11 deletions(-)
diff --git a/src/scf_utils/fock_matrix.irp.f b/src/scf_utils/fock_matrix.irp.f
index 1942e542..6054b99c 100644
--- a/src/scf_utils/fock_matrix.irp.f
+++ b/src/scf_utils/fock_matrix.irp.f
@@ -11,13 +11,13 @@
! |-----------------------|
! | Fcv | F^a | Rvv |
!
- ! C: Core, O: Open, V: Virtual
- !
+ ! C: Core, O: Open, V: Virtual
+ !
! Rcc = Acc Fcc^a + Bcc Fcc^b
! Roo = Aoo Foo^a + Boo Foo^b
! Rvv = Avv Fvv^a + Bvv Fvv^b
! Fcv = (F^a + F^b)/2
- !
+ !
! F^a: Fock matrix alpha (MO), F^b: Fock matrix beta (MO)
! A,B: Coupling parameters
!
@@ -26,10 +26,10 @@
! cc oo vv
! A -0.5 0.5 1.5
! B 1.5 0.5 -0.5
- !
+ !
END_DOC
integer :: i,j,n
- if (elec_alpha_num == elec_beta_num) then
+ if (all_shells_closed) then
Fock_matrix_mo = Fock_matrix_mo_alpha
else
! Core
@@ -102,7 +102,7 @@
!
! END_DOC
!integer :: i,j,n
- !if (elec_alpha_num == elec_beta_num) then
+ !if (all_shells_closed) then
! Fock_matrix_mo = Fock_matrix_mo_alpha
!else
@@ -192,7 +192,7 @@
do j = 1, n_core_orb
jorb = list_core(j)
Fock_matrix_mo(iorb,jorb) = 0.d0
- Fock_matrix_mo(jorb,iorb) = 0.d0
+ Fock_matrix_mo(jorb,iorb) = 0.d0
enddo
enddo
endif
@@ -229,9 +229,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num, ao_num) ]
call mo_to_ao(Fock_matrix_mo,size(Fock_matrix_mo,1), &
Fock_matrix_ao,size(Fock_matrix_ao,1))
else
- if ( (elec_alpha_num == elec_beta_num).and. &
- (level_shift == 0.) ) &
- then
+ if (all_shells_closed.and. (level_shift == 0.)) then
integer :: i,j
do j=1,ao_num
do i=1,ao_num
diff --git a/src/scf_utils/scf_density_matrix_ao.irp.f b/src/scf_utils/scf_density_matrix_ao.irp.f
index 55fa8e7c..3813aa61 100644
--- a/src/scf_utils/scf_density_matrix_ao.irp.f
+++ b/src/scf_utils/scf_density_matrix_ao.irp.f
@@ -1,3 +1,11 @@
+BEGIN_PROVIDER [ logical, all_shells_closed ]
+ implicit none
+ BEGIN_DOC
+ !
+ END_DOC
+ all_shells_closed = (elec_alpha_num == elec_beta_num)
+END_PROVIDER
+
BEGIN_PROVIDER [double precision, SCF_density_matrix_ao_alpha, (ao_num,ao_num) ]
implicit none
BEGIN_DOC
@@ -30,7 +38,7 @@ BEGIN_PROVIDER [ double precision, SCF_density_matrix_ao, (ao_num,ao_num) ]
! Sum of $\alpha$ and $\beta$ density matrices
END_DOC
ASSERT (size(SCF_density_matrix_ao,1) == size(SCF_density_matrix_ao_alpha,1))
- if (elec_alpha_num== elec_beta_num) then
+ if (all_shells_closed) then
SCF_density_matrix_ao = SCF_density_matrix_ao_alpha + SCF_density_matrix_ao_alpha
else
ASSERT (size(SCF_density_matrix_ao,1) == size(SCF_density_matrix_ao_beta ,1))
From 7aff1a33a9b7d3871d7c5e8cda3bcf15258ce94a Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 20 Mar 2024 09:20:21 +0100
Subject: [PATCH 067/140] Fixed nested parallelism in cholesky
---
src/ao_two_e_ints/cholesky.irp.f | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/src/ao_two_e_ints/cholesky.irp.f b/src/ao_two_e_ints/cholesky.irp.f
index 2977f0f4..33304026 100644
--- a/src/ao_two_e_ints/cholesky.irp.f
+++ b/src/ao_two_e_ints/cholesky.irp.f
@@ -66,7 +66,8 @@ END_PROVIDER
else
- PROVIDE nucl_coord
+ PROVIDE nucl_coord ao_two_e_integral_schwartz
+ call set_multiple_levels_omp(.False.)
if (do_direct_integrals) then
if (ao_two_e_integral(1,1,1,1) < huge(1.d0)) then
From df9299c661c4b87adf69a03a5b91b080093f096f Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 20 Mar 2024 16:06:44 +0100
Subject: [PATCH 068/140] Updated documentation
---
.readthedocs.yaml | 32 +
docs/ref | 2 +-
docs/source/appendix/contributors.rst | 25 +-
docs/source/appendix/references.rst | 8 +
docs/source/appendix/research.rst | 8 -
docs/source/auto_generate.py | 3 +-
docs/source/conf.py | 4 +-
docs/source/intro/intro.rst | 32 +-
docs/source/intro/selected.bib | 182 ----
docs/source/modules/becke_numerical_grid.rst | 770 ++++++++++++++++-
docs/source/modules/cipsi.rst | 2 +-
docs/source/references.bib | 847 +++++++++++++++++++
external/irpf90 | 2 +-
src/cipsi/README.rst | 6 +-
src/cipsi_utils/pt2_stoch_routines.irp.f | 3 +
src/cipsi_utils/zmq_selection.irp.f | 3 +
src/trexio/import_trexio_determinants.irp.f | 2 +-
17 files changed, 1679 insertions(+), 252 deletions(-)
create mode 100644 .readthedocs.yaml
create mode 100644 docs/source/appendix/references.rst
delete mode 100644 docs/source/appendix/research.rst
delete mode 100644 docs/source/intro/selected.bib
create mode 100644 docs/source/references.bib
diff --git a/.readthedocs.yaml b/.readthedocs.yaml
new file mode 100644
index 00000000..f114dbf9
--- /dev/null
+++ b/.readthedocs.yaml
@@ -0,0 +1,32 @@
+# .readthedocs.yaml
+# Read the Docs configuration file
+# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details
+
+# Required
+version: 2
+
+# Set the OS, Python version and other tools you might need
+build:
+ os: ubuntu-22.04
+ tools:
+ python: "3.12"
+ # You can also specify other tool versions:
+ # nodejs: "19"
+ # rust: "1.64"
+ # golang: "1.19"
+
+# Build documentation in the "docs/" directory with Sphinx
+sphinx:
+ configuration: docs/source/conf.py
+
+# Optionally build your docs in additional formats such as PDF and ePub
+# formats:
+# - pdf
+# - epub
+
+# Optional but recommended, declare the Python requirements required
+# to build your documentation
+# See https://docs.readthedocs.io/en/stable/guides/reproducible-builds.html
+python:
+ install:
+ - requirements: docs/requirements.txt
diff --git a/docs/ref b/docs/ref
index 58cc4721..49599966 100644
--- a/docs/ref
+++ b/docs/ref
@@ -20,5 +20,5 @@ Then, to reference for "myref" just type :ref:`myref`
or use `IRPF90`_ and define
_IRPF90: http://irpf90.ups-tlse.fr
somewhere
-* References of published results with QP should be added into docs/source/research.bib in bibtex
+* References of published results with QP should be added into docs/source/references.bib in bibtex
format
diff --git a/docs/source/appendix/contributors.rst b/docs/source/appendix/contributors.rst
index bf58adc2..e3574e5a 100644
--- a/docs/source/appendix/contributors.rst
+++ b/docs/source/appendix/contributors.rst
@@ -2,13 +2,13 @@
Contributors
============
-The |qp| is maintained by
+The |qp| is maintained by
-Anthony Scemama
+Anthony Scemama
| `Laboratoire de Chimie et Physique Quantiques `_,
| CNRS - Université Paul Sabatier
| Toulouse, France
- | scemama@irsamc.ups-tlse.fr
+ | scemama@irsamc.ups-tlse.fr
Emmanuel Giner
@@ -18,27 +18,27 @@ Emmanuel Giner
| emmanuel.giner@lct.jussieu.fr
-Thomas Applencourt
- | `Argonne Leadership Computing Facility `_
- | Argonne, USA
- | tapplencourt@anl.gov
-
-
-
The following people have contributed to this project (by alphabetical order):
+* Abdallah Ammar
+* Thomas Applencourt
* Roland Assaraf
* Pierrette Barbaresco
* Anouar Benali
* Chandler Bennet
* Michel Caffarel
+* Vijay Gopal Chilkuri
+* Yann Damour
* Grégoire David
+* Amanda Dumi
* Anthony Ferté
-* Madeline Galbraith
+* Madeline Galbraith
* Yann Garniron
* Kevin Gasperich
+* Fabris Kossoski
* Pierre-François Loos
* Jean-Paul Malrieu
+* Antoine Marie
* Barry Moore
* Julien Paquier
* Barthélémy Pradines
@@ -49,6 +49,7 @@ The following people have contributed to this project (by alphabetical order):
* Mikaël Véril
-If you have contributed and don't appear in this list, please modify this file
+If you have contributed and don't appear in this list, please modify the file
+`$QP_ROOT/docs/source/appendix/contributors.rst`
and submit a pull request.
diff --git a/docs/source/appendix/references.rst b/docs/source/appendix/references.rst
new file mode 100644
index 00000000..b277a6ac
--- /dev/null
+++ b/docs/source/appendix/references.rst
@@ -0,0 +1,8 @@
+References
+==========
+
+.. bibliography:: /references.bib
+ :style: unsrt
+ :all:
+
+
diff --git a/docs/source/appendix/research.rst b/docs/source/appendix/research.rst
deleted file mode 100644
index 992cc1eb..00000000
--- a/docs/source/appendix/research.rst
+++ /dev/null
@@ -1,8 +0,0 @@
-Some research made with the |qp|
-================================
-
-.. bibliography:: /research.bib
- :style: unsrt
- :all:
-
-
diff --git a/docs/source/auto_generate.py b/docs/source/auto_generate.py
index d767b922..6b50bce9 100755
--- a/docs/source/auto_generate.py
+++ b/docs/source/auto_generate.py
@@ -29,7 +29,8 @@ def generate_modules(abs_module, entities):
rst += ["", "EZFIO parameters", "----------------", ""]
config_file = configparser.ConfigParser()
with open(EZFIO, 'r') as f:
- config_file.readfp(f)
+# config_file.readfp(f)
+ config_file.read_file(f)
for section in config_file.sections():
doc = config_file.get(section, "doc")
doc = " " + doc.replace("\n", "\n\n ")+"\n"
diff --git a/docs/source/conf.py b/docs/source/conf.py
index 21498968..bafd95fa 100644
--- a/docs/source/conf.py
+++ b/docs/source/conf.py
@@ -70,7 +70,7 @@ master_doc = 'index'
#
# This is also used if you do content translation via gettext catalogs.
# Usually you set "language" from the command line for these cases.
-language = None
+language = "en"
# List of patterns, relative to source directory, that match files and
# directories to ignore when looking for source files.
@@ -208,3 +208,5 @@ epub_exclude_files = ['search.html']
# -- Extension configuration -------------------------------------------------
+bibtex_bibfiles = [ "references.bib" ]
+
diff --git a/docs/source/intro/intro.rst b/docs/source/intro/intro.rst
index aecd072d..6561f11a 100644
--- a/docs/source/intro/intro.rst
+++ b/docs/source/intro/intro.rst
@@ -11,25 +11,25 @@ The |qp|
What it is
==========
-The |qp| is an open-source **programming environment** for quantum chemistry.
-It has been built from the **developper** point of view in order to help
-the design of new quantum chemistry methods,
-especially for `wave function theory `_ (|WFT|).
+The |qp| is an open-source **programming environment** for quantum chemistry.
+It has been built from the **developper** point of view in order to help
+the design of new quantum chemistry methods,
+especially for `wave function theory `_ (|WFT|).
-From the **user** point of view, the |qp| proposes a stand-alone path
-to use optimized selected configuration interaction |sCI| based on the
-|CIPSI| algorithm that can efficiently reach near-full configuration interaction
-|FCI| quality for relatively large systems (see for instance :cite:`Caffarel_2016,Caffarel_2016.2,Loos_2018,Scemama_2018,Dash_2018,Garniron_2017.2,Loos_2018,Garniron_2018,Giner2018Oct`).
-To have a simple example of how to use the |CIPSI| program, go to the `users_guide/quickstart`.
+From the **user** point of view, the |qp| proposes a stand-alone path
+to use optimized selected configuration interaction |sCI| based on the
+|CIPSI| algorithm that can efficiently reach near-full configuration interaction
+|FCI| quality for relatively large systems.
+To have a simple example of how to use the |CIPSI| program, go to the `users_guide/quickstart`.
The main goal is the development of selected configuration interaction |sCI|
methods and multi-reference perturbation theory |MRPT| in the
-determinant-driven paradigm. It also contains the very basics of Kohn-Sham `density functional theory `_ |KS-DFT| and `range-separated hybrids `_ |RSH|.
+determinant-driven paradigm. It also contains the very basics of Kohn-Sham `density functional theory `_ |KS-DFT| and `range-separated hybrids `_ |RSH|.
-The determinant-driven framework allows the programmer to include any arbitrary set of
-determinants in the variational space, and thus gives a complete freedom in the methodological
-development. The basic ingredients of |RSH| together with those of the |WFT| framework available in the |qp| library allows one to easily develop range-separated DFT (|RSDFT|) approaches (see for instance the plugins at ``_).
+The determinant-driven framework allows the programmer to include any arbitrary set of
+determinants in the variational space, and thus gives a complete freedom in the methodological
+development. The basic ingredients of |RSH| together with those of the |WFT| framework available in the |qp| library allows one to easily develop range-separated DFT (|RSDFT|) approaches (see for instance the plugins at ``_).
All the programs are developed with the `IRPF90`_ code generator, which considerably simplifies
the collaborative development, and the development of new features.
@@ -40,20 +40,20 @@ What it is not
==============
The |qp| is *not* a general purpose quantum chemistry program.
-First of all, it is a *library* to develop new theories and algorithms in quantum chemistry.
+First of all, it is a *library* to develop new theories and algorithms in quantum chemistry.
Therefore, beside the use of the programs of the core modules, the users of the |qp| should develop their own programs.
The |qp| has been designed specifically for |sCI|, so all the
algorithms which are programmed are not adapted to run SCF or DFT calculations
on thousands of atoms. Currently, the systems targeted have less than 600
-molecular orbitals. This limit is due to the memory bottleneck induced by the storring of the two-electron integrals (see ``mo_two_e_integrals`` and ``ao_two_e_integrals``).
+molecular orbitals. This limit is due to the memory bottleneck induced by the storring of the two-electron integrals (see ``mo_two_e_integrals`` and ``ao_two_e_integrals``).
The |qp| is *not* a massive production code. For conventional
methods such as Hartree-Fock, CISD or MP2, the users are recommended to use the
existing standard production codes which are designed to make these methods run
fast. Again, the role of the |qp| is to make life simple for the
developer. Once a new method is developed and tested, the developer is encouraged
-to consider re-expressing it with an integral-driven formulation, and to
+to consider re-expressing it with an integral-driven formulation, and to
implement the new method in open-source production codes, such as `NWChem`_
or |GAMESS|.
diff --git a/docs/source/intro/selected.bib b/docs/source/intro/selected.bib
deleted file mode 100644
index 32df8bce..00000000
--- a/docs/source/intro/selected.bib
+++ /dev/null
@@ -1,182 +0,0 @@
-@article{Bytautas_2009,
- doi = {10.1016/j.chemphys.2008.11.021},
- url = {https://doi.org/10.1016%2Fj.chemphys.2008.11.021},
- year = 2009,
- month = {feb},
- publisher = {Elsevier {BV}},
- volume = {356},
- number = {1-3},
- pages = {64--75},
- author = {Laimutis Bytautas and Klaus Ruedenberg},
- title = {A priori identification of configurational deadwood},
- journal = {Chemical Physics}
-}
-
-@article{Anderson_2018,
- doi = {10.1016/j.comptc.2018.08.017},
- url = {https://doi.org/10.1016%2Fj.comptc.2018.08.017},
- year = 2018,
- month = {oct},
- publisher = {Elsevier {BV}},
- volume = {1142},
- pages = {66--77},
- author = {James S.M. Anderson and Farnaz Heidar-Zadeh and Paul W. Ayers},
- title = {Breaking the curse of dimension for the electronic Schrodinger equation with functional analysis},
- journal = {Computational and Theoretical Chemistry}
-}
-
-@article{Bender_1969,
- doi = {10.1103/physrev.183.23},
- url = {http://dx.doi.org/10.1103/PhysRev.183.23},
- year = 1969,
- month = {jul},
- publisher = {American Physical Society ({APS})},
- volume = {183},
- number = {1},
- pages = {23--30},
- author = {Charles F. Bender and Ernest R. Davidson},
- title = {Studies in Configuration Interaction: The First-Row Diatomic Hydrides},
- journal = {Phys. Rev.}
-}
-
-@article{Whitten_1969,
- doi = {10.1063/1.1671985},
- url = {https://doi.org/10.1063%2F1.1671985},
- year = 1969,
- month = {dec},
- publisher = {{AIP} Publishing},
- volume = {51},
- number = {12},
- pages = {5584--5596},
- author = {J. L. Whitten and Melvyn Hackmeyer},
- title = {Configuration Interaction Studies of Ground and Excited States of Polyatomic Molecules. I. The {CI} Formulation and Studies of Formaldehyde},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Huron_1973,
- doi = {10.1063/1.1679199},
- url = {https://doi.org/10.1063%2F1.1679199},
- year = 1973,
- month = {jun},
- publisher = {{AIP} Publishing},
- volume = {58},
- number = {12},
- pages = {5745--5759},
- author = {B. Huron and J. P. Malrieu and P. Rancurel},
- title = {Iterative perturbation calculations of ground and excited state energies from multiconfigurational zeroth-order wavefunctions},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Knowles_1984,
- author="Peter J. Knowles and Nicholas C Handy",
- year=1984,
- journal={Chem. Phys. Letters},
- volume=111,
- pages="315--321",
- title="A New Determinant-based Full Configuration Interaction Method"
-}
-
-
-@article{Scemama_2013,
- author = {{Scemama}, A. and {Giner}, E.},
- title = "{An efficient implementation of Slater-Condon rules}",
- journal = {ArXiv [physics.comp-ph]},
- pages = {1311.6244},
- year = 2013,
- month = nov,
- url = {https://arxiv.org/abs/1311.6244}
-}
-
-@article{Sharma_2017,
- doi = {10.1021/acs.jctc.6b01028},
- url = {https://doi.org/10.1021%2Facs.jctc.6b01028},
- year = 2017,
- month = {mar},
- publisher = {American Chemical Society ({ACS})},
- volume = {13},
- number = {4},
- pages = {1595--1604},
- author = {Sandeep Sharma and Adam A. Holmes and Guillaume Jeanmairet and Ali Alavi and C. J. Umrigar},
- title = {Semistochastic Heat-Bath Configuration Interaction Method: Selected Configuration Interaction with Semistochastic Perturbation Theory},
- journal = {Journal of Chemical Theory and Computation}
-}
-
-@article{Holmes_2016,
- doi = {10.1021/acs.jctc.6b00407},
- url = {https://doi.org/10.1021%2Facs.jctc.6b00407},
- year = 2016,
- month = {aug},
- publisher = {American Chemical Society ({ACS})},
- volume = {12},
- number = {8},
- pages = {3674--3680},
- author = {Adam A. Holmes and Norm M. Tubman and C. J. Umrigar},
- title = {Heat-Bath Configuration Interaction: An Efficient Selected Configuration Interaction Algorithm Inspired by Heat-Bath Sampling},
- journal = {Journal of Chemical Theory and Computation}
-}
-@article{Evangelisti_1983,
- doi = {10.1016/0301-0104(83)85011-3},
- url = {https://doi.org/10.1016%2F0301-0104%2883%2985011-3},
- year = 1983,
- month = {feb},
- publisher = {Elsevier {BV}},
- volume = {75},
- number = {1},
- pages = {91--102},
- author = {Stefano Evangelisti and Jean-Pierre Daudey and Jean-Paul Malrieu},
- title = {Convergence of an improved {CIPSI} algorithm},
- journal = {Chemical Physics}
-}
-@article{Booth_2009,
- doi = {10.1063/1.3193710},
- url = {https://doi.org/10.1063%2F1.3193710},
- year = 2009,
- publisher = {{AIP} Publishing},
- volume = {131},
- number = {5},
- pages = {054106},
- author = {George H. Booth and Alex J. W. Thom and Ali Alavi},
- title = {Fermion Monte Carlo without fixed nodes: A game of life, death, and annihilation in Slater determinant space},
- journal = {The Journal of Chemical Physics}
-}
-@article{Booth_2010,
- doi = {10.1063/1.3407895},
- url = {https://doi.org/10.1063%2F1.3407895},
- year = 2010,
- month = {may},
- publisher = {{AIP} Publishing},
- volume = {132},
- number = {17},
- pages = {174104},
- author = {George H. Booth and Ali Alavi},
- title = {Approaching chemical accuracy using full configuration-interaction quantum Monte Carlo: A study of ionization potentials},
- journal = {The Journal of Chemical Physics}
-}
-@article{Cleland_2010,
- doi = {10.1063/1.3302277},
- url = {https://doi.org/10.1063%2F1.3302277},
- year = 2010,
- month = {jan},
- publisher = {{AIP} Publishing},
- volume = {132},
- number = {4},
- pages = {041103},
- author = {Deidre Cleland and George H. Booth and Ali Alavi},
- title = {Communications: Survival of the fittest: Accelerating convergence in full configuration-interaction quantum Monte Carlo},
- journal = {The Journal of Chemical Physics}
-}
-
-@article{Garniron_2017b,
- doi = {10.1063/1.4992127},
- url = {https://doi.org/10.1063%2F1.4992127},
- year = 2017,
- month = {jul},
- publisher = {{AIP} Publishing},
- volume = {147},
- number = {3},
- pages = {034101},
- author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
- title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
- journal = {The Journal of Chemical Physics}
-}
-
diff --git a/docs/source/modules/becke_numerical_grid.rst b/docs/source/modules/becke_numerical_grid.rst
index e67c443a..27a95877 100644
--- a/docs/source/modules/becke_numerical_grid.rst
+++ b/docs/source/modules/becke_numerical_grid.rst
@@ -99,6 +99,71 @@ EZFIO parameters
Default: 1.e-20
+.. option:: my_grid_becke
+
+ if True, the number of angular and radial grid points are read from EZFIO
+
+ Default: False
+
+.. option:: my_n_pt_r_grid
+
+ Number of radial grid points given from input
+
+ Default: 300
+
+.. option:: my_n_pt_a_grid
+
+ Number of angular grid points given from input. Warning, this number cannot be any integer. See file list_angular_grid
+
+ Default: 1202
+
+.. option:: n_points_extra_final_grid
+
+ Total number of extra_grid points
+
+
+.. option:: extra_grid_type_sgn
+
+ Type of extra_grid used for the Becke's numerical extra_grid. Can be, by increasing accuracy: [ 0 | 1 | 2 | 3 ]
+
+ Default: 0
+
+.. option:: thresh_extra_grid
+
+ threshold on the weight of a given extra_grid point
+
+ Default: 1.e-20
+
+.. option:: my_extra_grid_becke
+
+ if True, the number of angular and radial extra_grid points are read from EZFIO
+
+ Default: False
+
+.. option:: my_n_pt_r_extra_grid
+
+ Number of radial extra_grid points given from input
+
+ Default: 300
+
+.. option:: my_n_pt_a_extra_grid
+
+ Number of angular extra_grid points given from input. Warning, this number cannot be any integer. See file list_angular_extra_grid
+
+ Default: 1202
+
+.. option:: rad_grid_type
+
+ method used to sample the radial space. Possible choices are [KNOWLES | GILL]
+
+ Default: KNOWLES
+
+.. option:: extra_rad_grid_type
+
+ method used to sample the radial space. Possible choices are [KNOWLES | GILL]
+
+ Default: KNOWLES
+
Providers
---------
@@ -122,6 +187,8 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
@@ -156,6 +223,66 @@ Providers
* :c:data:`grid_points_per_atom`
+.. c:var:: angular_quadrature_points_extra
+
+
+ File : :file:`becke_numerical_grid/angular_extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: angular_quadrature_points_extra (n_points_extra_integration_angular,3)
+ double precision, allocatable :: weights_angular_points_extra (n_points_extra_integration_angular)
+
+
+ weights and grid points_extra for the integration on the angular variables on
+ the unit sphere centered on (0,0,0)
+ According to the LEBEDEV scheme
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
+.. c:var:: dr_radial_extra_integral
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_radial (n_points_extra_radial_grid)
+ double precision :: dr_radial_extra_integral
+
+
+ points_extra in [0,1] to map the radial integral [0,\infty]
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
.. c:var:: dr_radial_integral
@@ -223,6 +350,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -241,11 +373,60 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: final_grid_points_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: final_grid_points_per_atom
@@ -272,12 +453,28 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
+
+
+.. c:var:: final_grid_points_transp
+
+
+ File : :file:`becke_numerical_grid/grid_becke_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_transp (n_points_final_grid,3)
+
+
+ Transposed final_grid_points
+
+ Needs:
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
+ * :c:data:`final_grid_points`
+ * :c:data:`n_points_final_grid`
+
.. c:var:: final_weight_at_r
@@ -304,6 +501,8 @@ Providers
* :c:data:`m_knowles`
* :c:data:`n_points_radial_grid`
* :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`rad_grid_type`
* :c:data:`weight_at_r`
Needed by:
@@ -317,6 +516,43 @@ Providers
* :c:data:`n_pts_per_atom`
+.. c:var:: final_weight_at_r_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_weight_at_r_extra (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ Total weight on each grid point which takes into account all Lebedev, Voronoi and radial weights.
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`alpha_knowles`
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`extra_rad_grid_type`
+ * :c:data:`grid_atomic_number`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`m_knowles`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`weight_at_r_extra`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`n_points_extra_final_grid`
+
+
.. c:var:: final_weight_at_r_vector
@@ -355,6 +591,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -373,11 +614,60 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: final_weight_at_r_vector_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: final_weight_at_r_vector_per_atom
@@ -404,12 +694,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: grid_atomic_number
@@ -438,9 +722,77 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
+.. c:var:: grid_points_extra_per_atom
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_per_atom (3,n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ x,y,z coordinates of grid points_extra used for integration in 3d space
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`alpha_knowles`
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`extra_rad_grid_type`
+ * :c:data:`grid_atomic_number`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`m_knowles`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_coord`
+ * :c:data:`nucl_num`
+ * :c:data:`r_gill`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`weight_at_r_extra`
+
+
+.. c:var:: grid_points_extra_radial
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: grid_points_extra_radial (n_points_extra_radial_grid)
+ double precision :: dr_radial_extra_integral
+
+
+ points_extra in [0,1] to map the radial integral [0,\infty]
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
.. c:var:: grid_points_per_atom
@@ -466,6 +818,8 @@ Providers
* :c:data:`n_points_radial_grid`
* :c:data:`nucl_coord`
* :c:data:`nucl_num`
+ * :c:data:`r_gill`
+ * :c:data:`rad_grid_type`
Needed by:
@@ -544,6 +898,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -562,11 +921,101 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
+.. c:var:: index_final_points_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
+.. c:var:: index_final_points_extra_reverse
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: final_grid_points_extra (3,n_points_extra_final_grid)
+ double precision, allocatable :: final_weight_at_r_vector_extra (n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra (3,n_points_extra_final_grid)
+ integer, allocatable :: index_final_points_extra_reverse (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ final_grid_points_extra(1:3,j) = (/ x, y, z /) of the jth grid point
+
+ final_weight_at_r_vector_extra(i) = Total weight function of the ith grid point which contains the Lebedev, Voronoi and radial weights contributions
+
+ index_final_points_extra(1:3,i) = gives the angular, radial and atomic indices associated to the ith grid point
+
+ index_final_points_extra_reverse(i,j,k) = index of the grid point having i as angular, j as radial and l as atomic indices
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+
+
.. c:var:: index_final_points_per_atom
@@ -593,12 +1042,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: index_final_points_per_atom_reverse
@@ -627,12 +1070,6 @@ Providers
* :c:data:`nucl_num`
* :c:data:`thresh_grid`
- Needed by:
-
- .. hlist::
- :columns: 3
-
- * :c:data:`aos_in_r_array_per_atom`
.. c:var:: index_final_points_reverse
@@ -673,6 +1110,11 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_in_r_array`
* :c:data:`aos_lapl_in_r_array`
@@ -691,8 +1133,16 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_hf_ab`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_rsc_of_r`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
@@ -714,9 +1164,148 @@ Providers
:columns: 3
* :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
* :c:data:`grid_points_per_atom`
+.. c:var:: n_points_extra_final_grid
+
+
+ File : :file:`becke_numerical_grid/extra_grid_vector.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_final_grid
+
+
+ Number of points_extra which are non zero
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_num`
+ * :c:data:`thresh_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`aos_in_r_array_extra`
+ * :c:data:`aos_in_r_array_extra_transp`
+ * :c:data:`final_grid_points_extra`
+
+
+.. c:var:: n_points_extra_grid_per_atom
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_grid_per_atom
+
+
+ Number of grid points_extra per atom
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+
+
+.. c:var:: n_points_extra_integration_angular
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_radial_grid
+ integer :: n_points_extra_integration_angular
+
+
+ n_points_extra_radial_grid = number of radial grid points_extra per atom
+
+ n_points_extra_integration_angular = number of angular grid points_extra per atom
+
+ These numbers are automatically set by setting the grid_type_sgn parameter
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`extra_grid_type_sgn`
+ * :c:data:`my_extra_grid_becke`
+ * :c:data:`my_n_pt_a_extra_grid`
+ * :c:data:`my_n_pt_r_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_grid_per_atom`
+ * :c:data:`weight_at_r_extra`
+
+
+.. c:var:: n_points_extra_radial_grid
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ integer :: n_points_extra_radial_grid
+ integer :: n_points_extra_integration_angular
+
+
+ n_points_extra_radial_grid = number of radial grid points_extra per atom
+
+ n_points_extra_integration_angular = number of angular grid points_extra per atom
+
+ These numbers are automatically set by setting the grid_type_sgn parameter
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`extra_grid_type_sgn`
+ * :c:data:`my_extra_grid_becke`
+ * :c:data:`my_n_pt_a_extra_grid`
+ * :c:data:`my_n_pt_r_extra_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`angular_quadrature_points_extra`
+ * :c:data:`final_grid_points_extra`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_extra_radial`
+ * :c:data:`n_points_extra_final_grid`
+ * :c:data:`n_points_extra_grid_per_atom`
+ * :c:data:`weight_at_r_extra`
+
+
.. c:var:: n_points_final_grid
@@ -744,9 +1333,17 @@ Providers
.. hlist::
:columns: 3
+ * :c:data:`act_mos_in_r_array`
* :c:data:`alpha_dens_kin_in_r`
+ * :c:data:`ao_abs_int_grid`
+ * :c:data:`ao_overlap_abs_grid`
+ * :c:data:`ao_prod_abs_r`
+ * :c:data:`ao_prod_center`
+ * :c:data:`ao_prod_dist_grid`
* :c:data:`aos_grad_in_r_array`
* :c:data:`aos_grad_in_r_array_transp`
+ * :c:data:`aos_grad_in_r_array_transp_3`
+ * :c:data:`aos_grad_in_r_array_transp_bis`
* :c:data:`aos_in_r_array`
* :c:data:`aos_in_r_array_transp`
* :c:data:`aos_lapl_in_r_array`
@@ -759,6 +1356,14 @@ Providers
* :c:data:`aos_vxc_alpha_lda_w`
* :c:data:`aos_vxc_alpha_pbe_w`
* :c:data:`aos_vxc_alpha_sr_pbe_w`
+ * :c:data:`basis_mos_in_r_array`
+ * :c:data:`core_density`
+ * :c:data:`core_inact_act_mos_grad_in_r_array`
+ * :c:data:`core_inact_act_mos_in_r_array`
+ * :c:data:`core_inact_act_v_kl_contracted`
+ * :c:data:`core_mos_in_r_array`
+ * :c:data:`effective_alpha_dm`
+ * :c:data:`effective_spin_dm`
* :c:data:`elec_beta_num_grid_becke`
* :c:data:`energy_c_lda`
* :c:data:`energy_c_sr_lda`
@@ -766,14 +1371,39 @@ Providers
* :c:data:`energy_x_pbe`
* :c:data:`energy_x_sr_lda`
* :c:data:`energy_x_sr_pbe`
+ * :c:data:`f_psi_cas_ab`
+ * :c:data:`f_psi_cas_ab_old`
+ * :c:data:`f_psi_hf_ab`
* :c:data:`final_grid_points`
+ * :c:data:`final_grid_points_transp`
+ * :c:data:`full_occ_2_rdm_cntrctd`
+ * :c:data:`full_occ_2_rdm_cntrctd_trans`
+ * :c:data:`full_occ_v_kl_cntrctd`
+ * :c:data:`grad_total_cas_on_top_density`
+ * :c:data:`inact_density`
+ * :c:data:`inact_mos_in_r_array`
* :c:data:`kinetic_density_generalized`
+ * :c:data:`mo_grad_ints`
* :c:data:`mos_grad_in_r_array`
* :c:data:`mos_grad_in_r_array_tranp`
+ * :c:data:`mos_grad_in_r_array_transp_3`
+ * :c:data:`mos_grad_in_r_array_transp_bis`
* :c:data:`mos_in_r_array`
* :c:data:`mos_in_r_array_omp`
* :c:data:`mos_in_r_array_transp`
* :c:data:`mos_lapl_in_r_array`
+ * :c:data:`mos_lapl_in_r_array_tranp`
+ * :c:data:`mu_average_prov`
+ * :c:data:`mu_grad_rho`
+ * :c:data:`mu_of_r_dft`
+ * :c:data:`mu_of_r_dft_average`
+ * :c:data:`mu_of_r_hf`
+ * :c:data:`mu_of_r_prov`
+ * :c:data:`mu_of_r_psi_cas`
+ * :c:data:`mu_rsc_of_r`
+ * :c:data:`one_e_act_density_alpha`
+ * :c:data:`one_e_act_density_beta`
+ * :c:data:`one_e_cas_total_density`
* :c:data:`one_e_dm_and_grad_alpha_in_r`
* :c:data:`pot_grad_x_alpha_ao_pbe`
* :c:data:`pot_grad_x_alpha_ao_sr_pbe`
@@ -789,6 +1419,8 @@ Providers
* :c:data:`potential_x_alpha_ao_sr_lda`
* :c:data:`potential_xc_alpha_ao_lda`
* :c:data:`potential_xc_alpha_ao_sr_lda`
+ * :c:data:`total_cas_on_top_density`
+ * :c:data:`virt_mos_in_r_array`
.. c:var:: n_points_grid_per_atom
@@ -928,7 +1560,6 @@ Providers
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
* :c:data:`final_grid_points_per_atom`
@@ -960,10 +1591,31 @@ Providers
.. hlist::
:columns: 3
- * :c:data:`aos_in_r_array_per_atom`
* :c:data:`final_grid_points_per_atom`
+.. c:var:: r_gill
+
+
+ File : :file:`becke_numerical_grid/grid_becke.irp.f`
+
+ .. code:: fortran
+
+ double precision :: r_gill
+
+
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r`
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`grid_points_per_atom`
+
+
.. c:var:: weight_at_r
@@ -1001,6 +1653,43 @@ Providers
* :c:data:`final_weight_at_r`
+.. c:var:: weight_at_r_extra
+
+
+ File : :file:`becke_numerical_grid/extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: weight_at_r_extra (n_points_extra_integration_angular,n_points_extra_radial_grid,nucl_num)
+
+
+ Weight function at grid points_extra : w_n(r) according to the equation (22)
+ of Becke original paper (JCP, 88, 1988)
+
+ The "n" discrete variable represents the nucleis which in this array is
+ represented by the last dimension and the points_extra are labelled by the
+ other dimensions.
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`grid_points_extra_per_atom`
+ * :c:data:`n_points_extra_radial_grid`
+ * :c:data:`nucl_coord_transp`
+ * :c:data:`nucl_dist_inv`
+ * :c:data:`nucl_num`
+ * :c:data:`slater_bragg_type_inter_distance_ua`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+
+
.. c:var:: weights_angular_points
@@ -1032,6 +1721,37 @@ Providers
* :c:data:`grid_points_per_atom`
+.. c:var:: weights_angular_points_extra
+
+
+ File : :file:`becke_numerical_grid/angular_extra_grid.irp.f`
+
+ .. code:: fortran
+
+ double precision, allocatable :: angular_quadrature_points_extra (n_points_extra_integration_angular,3)
+ double precision, allocatable :: weights_angular_points_extra (n_points_extra_integration_angular)
+
+
+ weights and grid points_extra for the integration on the angular variables on
+ the unit sphere centered on (0,0,0)
+ According to the LEBEDEV scheme
+
+ Needs:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`n_points_extra_radial_grid`
+
+ Needed by:
+
+ .. hlist::
+ :columns: 3
+
+ * :c:data:`final_weight_at_r_extra`
+ * :c:data:`grid_points_extra_per_atom`
+
+
Subroutines / functions
-----------------------
@@ -1043,7 +1763,7 @@ Subroutines / functions
.. code:: fortran
- double precision function cell_function_becke(r,atom_number)
+ double precision function cell_function_becke(r, atom_number)
atom_number :: atom on which the cell function of Becke (1988, JCP,88(4))
@@ -1067,7 +1787,7 @@ Subroutines / functions
.. code:: fortran
- double precision function derivative_knowles_function(alpha,m,x)
+ double precision function derivative_knowles_function(alpha, m, x)
Derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points
@@ -1118,7 +1838,7 @@ Subroutines / functions
.. code:: fortran
- double precision function knowles_function(alpha,m,x)
+ double precision function knowles_function(alpha, m, x)
Function proposed by Knowles (JCP, 104, 1996) for distributing the radial points :
diff --git a/docs/source/modules/cipsi.rst b/docs/source/modules/cipsi.rst
index 501a91dd..77212469 100644
--- a/docs/source/modules/cipsi.rst
+++ b/docs/source/modules/cipsi.rst
@@ -21,7 +21,7 @@ The :c:func:`run_cipsi` subroutine iteratively:
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Diagonalizes |H| in the enlarged internal space
-* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017.2`
+* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017b`
or deterministically, depending on :option:`perturbation do_pt2`
* Extrapolates the variational energy by fitting
:math:`E=E_\text{FCI} - \alpha\, E_\text{PT2}`
diff --git a/docs/source/references.bib b/docs/source/references.bib
new file mode 100644
index 00000000..6580eefa
--- /dev/null
+++ b/docs/source/references.bib
@@ -0,0 +1,847 @@
+
+@article{Ammar_2023,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Transcorrelated selected configuration interaction in a bi-orthonormal basis and with a cheap three-body correlation factor}},
+ journal = {J. Chem. Phys.},
+ volume = {159},
+ number = {11},
+ year = {2023},
+ month = sep,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0163831}
+}
+
+@article{Ammar_2023.2,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Biorthonormal Orbital Optimization with a Cheap Core-Electron-Free Three-Body Correlation Factor for Quantum Monte Carlo and Transcorrelation}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {19},
+ number = {15},
+ pages = {4883--4896},
+ year = {2023},
+ month = aug,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.3c00257}
+}
+
+@article{Damour_2023,
+ author = {Damour, Yann and Quintero-Monsebaiz, Ra{\'{u}}l and Caffarel, Michel and Jacquemin, Denis and Kossoski, F{\'{a}}bris and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Ground- and Excited-State Dipole Moments and Oscillator Strengths of Full Configuration Interaction Quality}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {19},
+ number = {1},
+ pages = {221--234},
+ year = {2023},
+ month = jan,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.2c01111}
+}
+
+@article{Ammar_2022,
+ author = {Ammar, Abdallah and Scemama, Anthony and Giner, Emmanuel},
+ title = {{Extension of selected configuration interaction for transcorrelated methods}},
+ journal = {J. Chem. Phys.},
+ volume = {157},
+ number = {13},
+ year = {2022},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0115524}
+}
+
+@article{Ammar_2022.2,
+ author = {Ammar, Abdallah and Giner, Emmanuel and Scemama, Anthony},
+ title = {{Optimization of Large Determinant Expansions in Quantum Monte Carlo}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {18},
+ number = {9},
+ pages = {5325--5336},
+ year = {2022},
+ month = sep,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.2c00556}
+}
+
+@article{Monino_2022,
+ author = {Monino, Enzo and Boggio-Pasqua, Martial and Scemama, Anthony and Jacquemin, Denis and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Reference Energies for Cyclobutadiene: Automerization and Excited States}},
+ journal = {J. Phys. Chem. A},
+ volume = {126},
+ number = {28},
+ pages = {4664--4679},
+ year = {2022},
+ month = jul,
+ issn = {1089-5639},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpca.2c02480}
+}
+
+@article{Cuzzocrea_2022,
+ author = {Cuzzocrea, Alice and Moroni, Saverio and Scemama, Anthony and Filippi, Claudia},
+ title = {{Reference Excitation Energies of Increasingly Large Molecules: A QMC Study of Cyanine Dyes}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {18},
+ number = {2},
+ pages = {1089--1095},
+ year = {2022},
+ month = feb,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c01162}
+}
+
+@article{Damour_2021,
+ author = {Damour, Yann and V{\'{e}}ril, Micka{\"{e}}l and Kossoski, F{\'{a}}bris and Caffarel, Michel and Jacquemin, Denis and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Accurate full configuration interaction correlation energy estimates for five- and six-membered rings}},
+ journal = {J. Chem. Phys.},
+ volume = {155},
+ number = {13},
+ year = {2021},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0065314}
+}
+
+@article{Veril_2021,
+ author = {V{\'{e}}ril, Micka{\"{e}}l and Scemama, Anthony and Caffarel, Michel and Lipparini, Filippo and Boggio-Pasqua, Martial and Jacquemin, Denis and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{QUESTDB: A database of highly accurate excitation energies for the electronic structure community}},
+ journal = {WIREs Comput. Mol. Sci.},
+ volume = {11},
+ number = {5},
+ pages = {e1517},
+ year = {2021},
+ month = sep,
+ issn = {1759-0876},
+ publisher = {John Wiley {\&} Sons, Ltd},
+ doi = {10.1002/wcms.1517}
+}
+
+@article{Kossoski_2021,
+ author = {Kossoski, F{\'{a}}bris and Marie, Antoine and Scemama, Anthony and Caffarel, Michel and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Excited States from State-Specific Orbital-Optimized Pair Coupled Cluster}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {17},
+ number = {8},
+ pages = {4756--4768},
+ year = {2021},
+ month = aug,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c00348}
+}
+
+@article{Dash_2021,
+ author = {Dash, Monika and Moroni, Saverio and Filippi, Claudia and Scemama, Anthony},
+ title = {{Tailoring CIPSI Expansions for QMC Calculations of Electronic Excitations: The Case Study of Thiophene}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {17},
+ number = {6},
+ pages = {3426--3434},
+ year = {2021},
+ month = jun,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.1c00212}
+}
+
+@article{Loos_2020,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Lipparini, Filippo and Boggio-Pasqua, Martial and Scemama, Anthony and Jacquemin, Denis},
+ title = {{A Mountaineering Strategy to Excited States: Highly Accurate Energies and Benchmarks for Medium Sized Molecules}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {3},
+ pages = {1711--1741},
+ year = {2020},
+ month = mar,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b01216}
+}
+
+@article{Loos_2020.2,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Pradines, Barth{\'{e}}l{\'{e}}my and Scemama, Anthony and Giner, Emmanuel and Toulouse, Julien},
+ title = {{Density-Based Basis-Set Incompleteness Correction for GW Methods}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {2},
+ pages = {1018--1028},
+ year = {2020},
+ month = feb,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b01067}
+}
+
+@article{Loos_2020.3,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Jacquemin, Denis},
+ title = {{The Quest for Highly Accurate Excitation Energies: A Computational Perspective}},
+ journal = {J. Phys. Chem. Lett.},
+ volume = {11},
+ number = {6},
+ pages = {2374--2383},
+ year = {2020},
+ month = mar,
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpclett.0c00014}
+}
+
+@article{Giner_2020,
+ author = {Giner, Emmanuel and Scemama, Anthony and Loos, Pierre-Fran{\c{c}}ois and Toulouse, Julien},
+ title = {{A basis-set error correction based on density-functional theory for strongly correlated molecular systems}},
+ journal = {J. Chem. Phys.},
+ volume = {152},
+ number = {17},
+ year = {2020},
+ month = may,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0002892}
+}
+
+@article{Loos_2020.4,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Boggio-Pasqua, Martial and Jacquemin, Denis},
+ title = {{Mountaineering Strategy to Excited States: Highly Accurate Energies and Benchmarks for Exotic Molecules and Radicals}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {16},
+ number = {6},
+ pages = {3720--3736},
+ year = {2020},
+ month = jun,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.0c00227}
+}
+
+@article{Benali_2020,
+ author = {Benali, Anouar and Gasperich, Kevin and Jordan, Kenneth D. and Applencourt, Thomas and Luo, Ye and Bennett, M. Chandler and Krogel, Jaron T. and Shulenburger, Luke and Kent, Paul R. C. and Loos, Pierre-Fran{\c{c}}ois and Scemama, Anthony and Caffarel, Michel},
+ title = {{Toward a systematic improvement of the fixed-node approximation in diffusion Monte Carlo for solids{\textemdash}A case study in diamond}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {18},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0021036}
+}
+
+@article{Scemama_2020,
+ author = {Scemama, Anthony and Giner, Emmanuel and Benali, Anouar and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Taming the fixed-node error in diffusion Monte Carlo via range separation}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {17},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0026324}
+}
+
+@article{Loos_2020.5,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Damour, Yann and Scemama, Anthony},
+ title = {{The performance of CIPSI on the ground state electronic energy of benzene}},
+ journal = {J. Chem. Phys.},
+ volume = {153},
+ number = {17},
+ year = {2020},
+ month = nov,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/5.0027617}
+}
+
+@article{Loos_2019,
+ author = {Loos, Pierre-Fran{\c{c}}ois and Pradines, Barth{\'{e}}l{\'{e}}my and Scemama, Anthony and Toulouse, Julien and Giner, Emmanuel},
+ title = {{A Density-Based Basis-Set Correction for Wave Function Theory}},
+ journal = {J. Phys. Chem. Lett.},
+ volume = {10},
+ number = {11},
+ pages = {2931--2937},
+ year = {2019},
+ month = jun,
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpclett.9b01176}
+}
+
+@article{Dash_2019,
+ author = {Dash, Monika and Feldt, Jonas and Moroni, Saverio and Scemama, Anthony and Filippi, Claudia},
+ title = {{Excited States with Selected Configuration Interaction-Quantum Monte Carlo: Chemically Accurate Excitation Energies and Geometries}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {15},
+ number = {9},
+ pages = {4896--4906},
+ year = {2019},
+ month = sep,
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.9b00476}
+}
+
+@article{Burton2019May,
+ author = {Burton, Hugh G. A. and Thom, Alex J. W.},
+ title = {{A General Approach for Multireference Ground and Excited States using Non-Orthogonal Configuration Interaction}},
+ journal = {arXiv},
+ year = {2019},
+ month = {May},
+ eprint = {1905.02626},
+ url = {https://arxiv.org/abs/1905.02626}
+}
+
+
+@article{Giner_2019,
+ author = {Giner, Emmanuel and Scemama, Anthony and Toulouse, Julien and Loos, Pierre-Fran{\c{c}}ois},
+ title = {{Chemically accurate excitation energies with small basis sets}},
+ journal = {J. Chem. Phys.},
+ volume = {151},
+ number = {14},
+ year = {2019},
+ month = oct,
+ issn = {0021-9606},
+ publisher = {AIP Publishing},
+ doi = {10.1063/1.5122976}
+}
+
+
+
+@article{Garniron_2019,
+ doi = {10.1021/acs.jctc.9b00176},
+ url = {https://doi.org/10.1021%2Facs.jctc.9b00176},
+ year = 2019,
+ month = {may},
+ publisher = {American Chemical Society ({ACS})},
+ author = {Yann Garniron and Thomas Applencourt and Kevin Gasperich and Anouar Benali and Anthony Ferte and Julien Paquier and Bartélémy Pradines and Roland Assaraf and Peter Reinhardt and Julien Toulouse and Pierrette Barbaresco and Nicolas Renon and Gregoire David and Jean-Paul Malrieu and Mickael Veril and Michel Caffarel and Pierre-Francois Loos and Emmanuel Giner and Anthony Scemama},
+ title = {Quantum Package 2.0: An Open-Source Determinant-Driven Suite of Programs},
+ journal = {Journal of Chemical Theory and Computation}
+}
+
+@article{Scemama_2019,
+ doi = {10.1016/j.rechem.2019.100002},
+ url = {https://doi.org/10.1016%2Fj.rechem.2019.100002},
+ year = 2019,
+ month = {may},
+ publisher = {Elsevier {BV}},
+ pages = {100002},
+ author = {Anthony Scemama and Michel Caffarel and Anouar Benali and Denis Jacquemin and Pierre-Fran{\c{c}}ois Loos},
+ title = {Influence of pseudopotentials on excitation energies from selected configuration interaction and diffusion Monte Carlo},
+ journal = {Results in Chemistry}
+}
+
+
+@article{Applencourt2018Dec,
+ author = {Applencourt, Thomas and Gasperich, Kevin and Scemama, Anthony},
+ title = {{Spin adaptation with determinant-based selected configuration interaction}},
+ journal = {arXiv},
+ year = {2018},
+ month = {Dec},
+ eprint = {1812.06902},
+ url = {https://arxiv.org/abs/1812.06902}
+}
+
+@article{Loos2019Mar,
+ author = {Loos, Pierre-Fran\c{c}ois and Boggio-Pasqua, Martial and Scemama, Anthony and Caffarel, Michel and Jacquemin, Denis},
+ title = {{Reference Energies for Double Excitations}},
+ journal = {J. Chem. Theory Comput.},
+ volume = {15},
+ number = {3},
+ pages = {1939--1956},
+ year = {2019},
+ month = {Mar},
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.8b01205}
+}
+
+@article{PinedaFlores2019Feb,
+ author = {Pineda Flores, Sergio and Neuscamman, Eric},
+ title = {{Excited State Specific Multi-Slater Jastrow Wave Functions}},
+ journal = {J. Phys. Chem. A},
+ volume = {123},
+ number = {8},
+ pages = {1487--1497},
+ year = {2019},
+ month = {Feb},
+ issn = {1089-5639},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jpca.8b10671}
+}
+
+@phdthesis{yann_garniron_2019_2558127,
+ author = {Yann Garniron},
+ title = {{Development and parallel implementation of
+ selected configuration interaction methods}},
+ school = {Université de Toulouse},
+ year = 2019,
+ month = feb,
+ doi = {10.5281/zenodo.2558127},
+ url = {https://doi.org/10.5281/zenodo.2558127}
+}
+
+@article{Giner_2018,
+ doi = {10.1063/1.5052714},
+ url = {https://doi.org/10.1063%2F1.5052714},
+ year = 2018,
+ month = {nov},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {19},
+ pages = {194301},
+ author = {Emmanuel Giner and Barth{\'{e}}lemy Pradines and Anthony Fert{\'{e}} and Roland Assaraf and Andreas Savin and Julien Toulouse},
+ title = {Curing basis-set convergence of wave-function theory using density-functional theory: A systematically improvable approach},
+ journal = {The Journal of Chemical Physics}
+}
+
+
+@article{Giner2018Oct,
+ author = {Giner, Emmanuel and Tew, David and Garniron, Yann and Alavi, Ali},
+ title = {{Interplay between electronic correlation and metal-ligand delocalization in the spectroscopy of transition metal compounds: case study on a series of planar Cu2+complexes.}},
+ journal = {J. Chem. Theory Comput.},
+ year = {2018},
+ month = {Oct},
+ issn = {1549-9618},
+ publisher = {American Chemical Society},
+ doi = {10.1021/acs.jctc.8b00591}
+}
+
+@article{Loos_2018,
+ doi = {10.1021/acs.jctc.8b00406},
+ url = {https://doi.org/10.1021%2Facs.jctc.8b00406},
+ year = 2018,
+ month = {jul},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {8},
+ pages = {4360--4379},
+ author = {Pierre-Fran{\c{c}}ois Loos and Anthony Scemama and Aymeric Blondel and Yann Garniron and Michel Caffarel and Denis Jacquemin},
+ title = {A Mountaineering Strategy to Excited States: Highly Accurate Reference Energies and Benchmarks},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Scemama_2018,
+ doi = {10.1021/acs.jctc.7b01250},
+ url = {https://doi.org/10.1021%2Facs.jctc.7b01250},
+ year = 2018,
+ month = {jan},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {3},
+ pages = {1395--1402},
+ author = {Anthony Scemama and Yann Garniron and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Deterministic Construction of Nodal Surfaces within Quantum Monte Carlo: The Case of {FeS}},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Scemama_2018.2,
+ doi = {10.1063/1.5041327},
+ url = {https://doi.org/10.1063%2F1.5041327},
+ year = 2018,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {3},
+ pages = {034108},
+ author = {Anthony Scemama and Anouar Benali and Denis Jacquemin and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Excitation energies from diffusion Monte Carlo using selected configuration interaction nodes},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Dash_2018,
+ doi = {10.1021/acs.jctc.8b00393},
+ url = {https://doi.org/10.1021%2Facs.jctc.8b00393},
+ year = 2018,
+ month = {jun},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {14},
+ number = {8},
+ pages = {4176--4182},
+ author = {Monika Dash and Saverio Moroni and Anthony Scemama and Claudia Filippi},
+ title = {Perturbatively Selected Configuration-Interaction Wave Functions for Efficient Geometry Optimization in Quantum Monte Carlo},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Garniron_2018,
+ doi = {10.1063/1.5044503},
+ url = {https://doi.org/10.1063%2F1.5044503},
+ year = 2018,
+ month = {aug},
+ publisher = {{AIP} Publishing},
+ volume = {149},
+ number = {6},
+ pages = {064103},
+ author = {Yann Garniron and Anthony Scemama and Emmanuel Giner and Michel Caffarel and Pierre-Fran{\c{c}}ois Loos},
+ title = {Selected configuration interaction dressed by perturbation},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Giner_2017,
+ doi = {10.1063/1.4984616},
+ url = {https://doi.org/10.1063%2F1.4984616},
+ year = 2017,
+ month = {jun},
+ publisher = {{AIP} Publishing},
+ volume = {146},
+ number = {22},
+ pages = {224108},
+ author = {Emmanuel Giner and Celestino Angeli and Yann Garniron and Anthony Scemama and Jean-Paul Malrieu},
+ title = {A Jeziorski-Monkhorst fully uncontracted multi-reference perturbative treatment. I. Principles, second-order versions, and tests on ground state potential energy curves},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Garniron_2017,
+ doi = {10.1063/1.4980034},
+ url = {https://doi.org/10.1063%2F1.4980034},
+ year = 2017,
+ month = {apr},
+ publisher = {{AIP} Publishing},
+ volume = {146},
+ number = {15},
+ pages = {154107},
+ author = {Yann Garniron and Emmanuel Giner and Jean-Paul Malrieu and Anthony Scemama},
+ title = {Alternative definition of excitation amplitudes in multi-reference state-specific coupled cluster},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Garniron_2017.2,
+ doi = {10.1063/1.4992127},
+ url = {https://doi.org/10.1063%2F1.4992127},
+ year = 2017,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {147},
+ number = {3},
+ pages = {034101},
+ author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
+ title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Giner_2017.2,
+ doi = {10.1016/j.comptc.2017.03.001},
+ url = {https://doi.org/10.1016%2Fj.comptc.2017.03.001},
+ year = 2017,
+ month = {sep},
+ publisher = {Elsevier {BV}},
+ volume = {1116},
+ pages = {134--140},
+ author = {E. Giner and C. Angeli and A. Scemama and J.-P. Malrieu},
+ title = {Orthogonal Valence Bond Hamiltonians incorporating dynamical correlation effects},
+ journal = {Computational and Theoretical Chemistry}
+}
+
+@article{Giner_2017.3,
+ author = {Giner, Emmanuel and Tenti, Lorenzo and Angeli, Celestino and Ferré, Nicolas},
+ title = {Computation of the Isotropic Hyperfine Coupling Constant: Efficiency and Insights from a New Approach Based on Wave Function Theory},
+ journal = {Journal of Chemical Theory and Computation},
+ volume = {13},
+ number = {2},
+ pages = {475-487},
+ year = {2017},
+ doi = {10.1021/acs.jctc.6b00827},
+ note ={PMID: 28094936},
+ URL = {https://doi.org/10.1021/acs.jctc.6b00827},
+ eprint = {https://doi.org/10.1021/acs.jctc.6b00827}
+}
+
+@article{Giner2016Mar,
+ author = {Giner, Emmanuel and Angeli, Celestino},
+ title = {{Spin density and orbital optimization in open shell systems: A rational and computationally efficient proposal}},
+ journal = {J. Chem. Phys.},
+ volume = {144},
+ number = {10},
+ pages = {104104},
+ year = {2016},
+ month = {Mar},
+ issn = {0021-9606},
+ publisher = {American Institute of Physics},
+ doi = {10.1063/1.4943187}
+}
+@article{Giner_2016,
+ doi = {10.1063/1.4940781},
+ url = {https://doi.org/10.1063%2F1.4940781},
+ year = 2016,
+ month = {feb},
+ publisher = {{AIP} Publishing},
+ volume = {144},
+ number = {6},
+ pages = {064101},
+ author = {E. Giner and G. David and A. Scemama and J. P. Malrieu},
+ title = {A simple approach to the state-specific {MR}-{CC} using the intermediate Hamiltonian formalism},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Caffarel_2016,
+ doi = {10.1063/1.4947093},
+ url = {https://doi.org/10.1063%2F1.4947093},
+ year = 2016,
+ month = {apr},
+ publisher = {{AIP} Publishing},
+ volume = {144},
+ number = {15},
+ pages = {151103},
+ author = {Michel Caffarel and Thomas Applencourt and Emmanuel Giner and Anthony Scemama},
+ title = {Communication: Toward an improved control of the fixed-node error in quantum Monte Carlo: The case of the water molecule},
+ journal = {The Journal of Chemical Physics}
+}
+@incollection{Caffarel_2016.2,
+ doi = {10.1021/bk-2016-1234.ch002},
+ url = {https://doi.org/10.1021%2Fbk-2016-1234.ch002},
+ year = 2016,
+ month = {jan},
+ publisher = {American Chemical Society},
+ pages = {15--46},
+ author = {Michel Caffarel and Thomas Applencourt and Emmanuel Giner and Anthony Scemama},
+ title = {Using CIPSI Nodes in Diffusion Monte Carlo},
+ booktitle = {{ACS} Symposium Series}
+}
+@article{Giner_2015,
+ doi = {10.1063/1.4905528},
+ url = {https://doi.org/10.1063%2F1.4905528},
+ year = 2015,
+ month = {jan},
+ publisher = {{AIP} Publishing},
+ volume = {142},
+ number = {4},
+ pages = {044115},
+ author = {Emmanuel Giner and Anthony Scemama and Michel Caffarel},
+ title = {Fixed-node diffusion Monte Carlo potential energy curve of the fluorine molecule F2 using selected configuration interaction trial wavefunctions},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Giner2015Sep,
+ author = {Giner, Emmanuel and Angeli, Celestino},
+ title = {{Metal-ligand delocalization and spin density in the CuCl2 and [CuCl4]2{-} molecules: Some insights from wave function theory}},
+ journal = {J. Chem. Phys.},
+ volume = {143},
+ number = {12},
+ pages = {124305},
+ year = {2015},
+ month = {Sep},
+ issn = {0021-9606},
+ publisher = {American Institute of Physics},
+ doi = {10.1063/1.4931639}
+}
+
+@article{Scemama_2014,
+ doi = {10.1063/1.4903985},
+ url = {https://doi.org/10.1063%2F1.4903985},
+ year = 2014,
+ month = {dec},
+ publisher = {{AIP} Publishing},
+ volume = {141},
+ number = {24},
+ pages = {244110},
+ author = {A. Scemama and T. Applencourt and E. Giner and M. Caffarel},
+ title = {Accurate nonrelativistic ground-state energies of 3d transition metal atoms},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Caffarel_2014,
+ doi = {10.1021/ct5004252},
+ url = {https://doi.org/10.1021%2Fct5004252},
+ year = 2014,
+ month = {nov},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {10},
+ number = {12},
+ pages = {5286--5296},
+ author = {Michel Caffarel and Emmanuel Giner and Anthony Scemama and Alejandro Ram{\'{\i}}rez-Sol{\'{\i}}s},
+ title = {Spin Density Distribution in Open-Shell Transition Metal Systems: A Comparative Post-Hartree-Fock, Density Functional Theory, and Quantum Monte Carlo Study of the CuCl2 Molecule},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Giner_2013,
+ doi = {10.1139/cjc-2013-0017},
+ url = {https://doi.org/10.1139%2Fcjc-2013-0017},
+ year = 2013,
+ month = {sep},
+ publisher = {Canadian Science Publishing},
+ volume = {91},
+ number = {9},
+ pages = {879--885},
+ author = {Emmanuel Giner and Anthony Scemama and Michel Caffarel},
+ title = {Using perturbatively selected configuration interaction in quantum Monte Carlo calculations},
+ journal = {Canadian Journal of Chemistry}
+}
+
+@article{Scemama2013Nov,
+ author = {Scemama, Anthony and Giner, Emmanuel},
+ title = {{An efficient implementation of Slater-Condon rules}},
+ journal = {arXiv},
+ year = {2013},
+ month = {Nov},
+ eprint = {1311.6244},
+ url = {https://arxiv.org/abs/1311.6244}
+}
+
+
+
+@article{Bytautas_2009,
+ doi = {10.1016/j.chemphys.2008.11.021},
+ url = {https://doi.org/10.1016%2Fj.chemphys.2008.11.021},
+ year = 2009,
+ month = {feb},
+ publisher = {Elsevier {BV}},
+ volume = {356},
+ number = {1-3},
+ pages = {64--75},
+ author = {Laimutis Bytautas and Klaus Ruedenberg},
+ title = {A priori identification of configurational deadwood},
+ journal = {Chemical Physics}
+}
+
+@article{Anderson_2018,
+ doi = {10.1016/j.comptc.2018.08.017},
+ url = {https://doi.org/10.1016%2Fj.comptc.2018.08.017},
+ year = 2018,
+ month = {oct},
+ publisher = {Elsevier {BV}},
+ volume = {1142},
+ pages = {66--77},
+ author = {James S.M. Anderson and Farnaz Heidar-Zadeh and Paul W. Ayers},
+ title = {Breaking the curse of dimension for the electronic Schrodinger equation with functional analysis},
+ journal = {Computational and Theoretical Chemistry}
+}
+
+@article{Bender_1969,
+ doi = {10.1103/physrev.183.23},
+ url = {http://dx.doi.org/10.1103/PhysRev.183.23},
+ year = 1969,
+ month = {jul},
+ publisher = {American Physical Society ({APS})},
+ volume = {183},
+ number = {1},
+ pages = {23--30},
+ author = {Charles F. Bender and Ernest R. Davidson},
+ title = {Studies in Configuration Interaction: The First-Row Diatomic Hydrides},
+ journal = {Phys. Rev.}
+}
+
+@article{Whitten_1969,
+ doi = {10.1063/1.1671985},
+ url = {https://doi.org/10.1063%2F1.1671985},
+ year = 1969,
+ month = {dec},
+ publisher = {{AIP} Publishing},
+ volume = {51},
+ number = {12},
+ pages = {5584--5596},
+ author = {J. L. Whitten and Melvyn Hackmeyer},
+ title = {Configuration Interaction Studies of Ground and Excited States of Polyatomic Molecules. I. The {CI} Formulation and Studies of Formaldehyde},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Huron_1973,
+ doi = {10.1063/1.1679199},
+ url = {https://doi.org/10.1063%2F1.1679199},
+ year = 1973,
+ month = {jun},
+ publisher = {{AIP} Publishing},
+ volume = {58},
+ number = {12},
+ pages = {5745--5759},
+ author = {B. Huron and J. P. Malrieu and P. Rancurel},
+ title = {Iterative perturbation calculations of ground and excited state energies from multiconfigurational zeroth-order wavefunctions},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Knowles_1984,
+ author="Peter J. Knowles and Nicholas C Handy",
+ year=1984,
+ journal={Chem. Phys. Letters},
+ volume=111,
+ pages="315--321",
+ title="A New Determinant-based Full Configuration Interaction Method"
+}
+
+
+@article{Sharma_2017,
+ doi = {10.1021/acs.jctc.6b01028},
+ url = {https://doi.org/10.1021%2Facs.jctc.6b01028},
+ year = 2017,
+ month = {mar},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {13},
+ number = {4},
+ pages = {1595--1604},
+ author = {Sandeep Sharma and Adam A. Holmes and Guillaume Jeanmairet and Ali Alavi and C. J. Umrigar},
+ title = {Semistochastic Heat-Bath Configuration Interaction Method: Selected Configuration Interaction with Semistochastic Perturbation Theory},
+ journal = {Journal of Chemical Theory and Computation}
+}
+
+@article{Holmes_2016,
+ doi = {10.1021/acs.jctc.6b00407},
+ url = {https://doi.org/10.1021%2Facs.jctc.6b00407},
+ year = 2016,
+ month = {aug},
+ publisher = {American Chemical Society ({ACS})},
+ volume = {12},
+ number = {8},
+ pages = {3674--3680},
+ author = {Adam A. Holmes and Norm M. Tubman and C. J. Umrigar},
+ title = {Heat-Bath Configuration Interaction: An Efficient Selected Configuration Interaction Algorithm Inspired by Heat-Bath Sampling},
+ journal = {Journal of Chemical Theory and Computation}
+}
+@article{Evangelisti_1983,
+ doi = {10.1016/0301-0104(83)85011-3},
+ url = {https://doi.org/10.1016%2F0301-0104%2883%2985011-3},
+ year = 1983,
+ month = {feb},
+ publisher = {Elsevier {BV}},
+ volume = {75},
+ number = {1},
+ pages = {91--102},
+ author = {Stefano Evangelisti and Jean-Pierre Daudey and Jean-Paul Malrieu},
+ title = {Convergence of an improved {CIPSI} algorithm},
+ journal = {Chemical Physics}
+}
+@article{Booth_2009,
+ doi = {10.1063/1.3193710},
+ url = {https://doi.org/10.1063%2F1.3193710},
+ year = 2009,
+ publisher = {{AIP} Publishing},
+ volume = {131},
+ number = {5},
+ pages = {054106},
+ author = {George H. Booth and Alex J. W. Thom and Ali Alavi},
+ title = {Fermion Monte Carlo without fixed nodes: A game of life, death, and annihilation in Slater determinant space},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Booth_2010,
+ doi = {10.1063/1.3407895},
+ url = {https://doi.org/10.1063%2F1.3407895},
+ year = 2010,
+ month = {may},
+ publisher = {{AIP} Publishing},
+ volume = {132},
+ number = {17},
+ pages = {174104},
+ author = {George H. Booth and Ali Alavi},
+ title = {Approaching chemical accuracy using full configuration-interaction quantum Monte Carlo: A study of ionization potentials},
+ journal = {The Journal of Chemical Physics}
+}
+@article{Cleland_2010,
+ doi = {10.1063/1.3302277},
+ url = {https://doi.org/10.1063%2F1.3302277},
+ year = 2010,
+ month = {jan},
+ publisher = {{AIP} Publishing},
+ volume = {132},
+ number = {4},
+ pages = {041103},
+ author = {Deidre Cleland and George H. Booth and Ali Alavi},
+ title = {Communications: Survival of the fittest: Accelerating convergence in full configuration-interaction quantum Monte Carlo},
+ journal = {The Journal of Chemical Physics}
+}
+
+@article{Garniron_2017b,
+ doi = {10.1063/1.4992127},
+ url = {https://doi.org/10.1063%2F1.4992127},
+ year = 2017,
+ month = {jul},
+ publisher = {{AIP} Publishing},
+ volume = {147},
+ number = {3},
+ pages = {034101},
+ author = {Yann Garniron and Anthony Scemama and Pierre-Fran{\c{c}}ois Loos and Michel Caffarel},
+ title = {Hybrid stochastic-deterministic calculation of the second-order perturbative contribution of multireference perturbation theory},
+ journal = {The Journal of Chemical Physics}
+}
+
+
+
diff --git a/external/irpf90 b/external/irpf90
index 4ab1b175..ba1a2837 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
+Subproject commit ba1a2837aa61cb8f9892860cec544d7c6659badd
diff --git a/src/cipsi/README.rst b/src/cipsi/README.rst
index 054f938f..7385de5b 100644
--- a/src/cipsi/README.rst
+++ b/src/cipsi/README.rst
@@ -15,18 +15,18 @@ The :c:func:`run_cipsi` subroutine iteratively:
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Diagonalizes |H| in the enlarged internal space
-* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017.2`
+* Computes the |PT2| contribution to the energy stochastically :cite:`Garniron_2017b`
or deterministically, depending on :option:`perturbation do_pt2`
* Extrapolates the variational energy by fitting
:math:`E=E_\text{FCI} - \alpha\, E_\text{PT2}`
The difference between :c:func:`run_stochastic_cipsi` and :c:func:`run_cipsi` is that
:c:func:`run_stochastic_cipsi` selects the determinants on the fly with the computation
-of the stochastic |PT2| :cite:`Garniron_2017.2`. Hence, it is a semi-stochastic selection. It
+of the stochastic |PT2| :cite:`Garniron_2017b`. Hence, it is a semi-stochastic selection. It
* Selects the most important determinants from the external space and adds them to the
internal space, on the fly with the computation of the PT2 with the stochastic algorithm
- presented in :cite:`Garniron_2017.2`.
+ presented in :cite:`Garniron_2017b`.
* If :option:`determinants s2_eig` is |true|, it adds all the necessary
determinants to allow the eigenstates of |H| to be eigenstates of |S^2|
* Extrapolates the variational energy by fitting
diff --git a/src/cipsi_utils/pt2_stoch_routines.irp.f b/src/cipsi_utils/pt2_stoch_routines.irp.f
index f067d0be..c33dcfe7 100644
--- a/src/cipsi_utils/pt2_stoch_routines.irp.f
+++ b/src/cipsi_utils/pt2_stoch_routines.irp.f
@@ -117,6 +117,9 @@ subroutine ZMQ_pt2(E, pt2_data, pt2_data_err, relative_error, N_in)
use selection_types
implicit none
+ BEGIN_DOC
+! Computes the PT2 energy using ZMQ
+ END_DOC
integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
integer, intent(in) :: N_in
diff --git a/src/cipsi_utils/zmq_selection.irp.f b/src/cipsi_utils/zmq_selection.irp.f
index 1bfe87c0..5c2f8fc8 100644
--- a/src/cipsi_utils/zmq_selection.irp.f
+++ b/src/cipsi_utils/zmq_selection.irp.f
@@ -3,6 +3,9 @@ subroutine ZMQ_selection(N_in, pt2_data)
use selection_types
implicit none
+ BEGIN_DOC
+! Performs the determinant selection using ZeroMQ
+ END_DOC
integer(ZMQ_PTR) :: zmq_to_qp_run_socket , zmq_socket_pull
integer, intent(in) :: N_in
diff --git a/src/trexio/import_trexio_determinants.irp.f b/src/trexio/import_trexio_determinants.irp.f
index 1759bb94..7be576c6 100644
--- a/src/trexio/import_trexio_determinants.irp.f
+++ b/src/trexio/import_trexio_determinants.irp.f
@@ -1,4 +1,4 @@
-program import_determinants_ao
+program import_trexio_determinants
call run
end
From c63b69e8dac8017d6415df602c5f7f5c02e35a2a Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 20 Mar 2024 16:12:34 +0100
Subject: [PATCH 069/140] Fixing ReadtheDocs
---
docs/requirements.txt | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/docs/requirements.txt b/docs/requirements.txt
index b73f3706..135f6044 100644
--- a/docs/requirements.txt
+++ b/docs/requirements.txt
@@ -1,2 +1,2 @@
-sphinxcontrib-bibtex==0.4.0
-sphinx-rtd-theme==0.4.2
+sphinxcontrib-bibtex
+sphinx-rtd-theme
From 1fd93d76b6ad7d7733834bae2da0b9dbbea8d49f Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 21 Mar 2024 15:31:06 +0100
Subject: [PATCH 070/140] working on the tuto
---
plugins/README.rst | 76 +++++++++++++++
plugins/tuto_plugins/n2.xyz | 4 +
.../tuto_plugins/tuto_I/print_one_e_h.irp.f | 20 ++++
plugins/tuto_plugins/tuto_I/tuto_I.rst | 97 +++++++++++++++++++
4 files changed, 197 insertions(+)
create mode 100644 plugins/README.rst
create mode 100644 plugins/tuto_plugins/n2.xyz
create mode 100644 plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f
create mode 100644 plugins/tuto_plugins/tuto_I/tuto_I.rst
diff --git a/plugins/README.rst b/plugins/README.rst
new file mode 100644
index 00000000..7f3f3c75
--- /dev/null
+++ b/plugins/README.rst
@@ -0,0 +1,76 @@
+==============================
+Tutorial for creating a plugin
+==============================
+
+Introduction: what is a plugin, and what this tuto will be about ?
+============================================================
+The QP is split into two kinds of routines/global variables (i.e. providers):
+ i) the core modules locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
+ ii) the plugins which are external stuffs connected to the qp2/src/ stuffs.
+
+More precisely, a plugin of the QP is a directory where you can create routines,
+providers and executables that use all the global variables/functions/routines already created
+in the modules ofqp2/src or in other plugins.
+
+Instead of giving a theoretical lecture on what is a plugin,
+we will go through a series of examples that allow you to do the following thing:
+ I) print out one- and two-electron integrals on the AO/MO basis,
+ creates two providers which manipulate these objects,
+ print out these providers,
+ II) browse the Slater determinants stored in the EZFIO wave function and compute their matrix elements,
+ III) build the Hamiltonian matrix and diagonalize it either with Lapck or Davidson,
+ IV) print out the one- and two-electron rdms,
+ V) obtain the AOs and MOs on the DFT grid, together with the density,
+
+This tuto is as follows:
+ i) you READ THIS FILE UNTIL THE END in order to get the big picture and vocabulary,
+ ii) you go to the directory qp2/plugins/tuto_plugins/ and you will find detailed tuto there for each of the 5 examples.
+
+Creating a plugin: the basic
+----------------------------
+The first thing to do is to be in the QPSH mode: you execute the qp2/bin/qpsh script that essentially loads all
+the environement variables and allows for the completion of command lines in bash (that is an AMAZING feature :)
+
+Then, you need to known where you want to create your plugin, and what is the name of the plugin.
+!!!! WARINING: The plugins are NECESSARILY located in qp2/plugins/ !!!!
+Ex: If you want to create a plugin named "my_fancy_plugin" in the directory plugins/plugins_test/,
+this goes with the command
+qp plugins create -n my_fancy_plugin -r plugins_test/
+
+Then, to create plugin of your dreams, the two questions you need to answer are the following:
+a) What do I need to compute what I want, which means what are the objects that I need ?
+ There are two kind of objects:
+ + the routines/functions
+ Ex: Linear algebra routines, integration routines etc ...
+ + the global variables which are called the PROVIDERS
+ Ex: one-electron integrals, Slater determinants, density matrices etc ...
+b) Where do I find these objects ?
+ The objects (routines/functions/providers) are necessarily created in other modules/plugins
+ Ex: the routine "lapack_diagd" (which diagonalises a real hermitian matrix) is located in the file
+ qp2/src/utils/linear_algebra.irp.f
+ therefore it "belongs" to the module "utils"
+ : the routine "ao_to_mo" (which converts a given matrix A from the AO basis to the MO basis) is located in the file
+ qp2/src/mo_one_e_ints/ao_to_mo.irp.f
+ therefore it "belongs" to the module "mo_one_e_ints"
+ : the provider "ao_one_e_integrals" (which is the integrals of one-body part of H on the AO basis) is located in the file
+ qp2/src/mo_one_e_ints/ao_to_mo.irp.f
+ therefore it belongs to the module "mo_one_e_ints"
+ : the provider "one_e_dm_mo_beta_average" (which is the state average beta density matrix on the MO basis) is located in the file
+ qp2/src/determinants/density_matrix.irp.f
+ therefore it belongs to the module "determinants"
+
+To import all the variables that you need, you just need to write the name of the plugins in the file "NEED"
+Ex: to import all the variables/routines of the module "utils", "determinants" and "mo_one_e_ints" you will have the following NEED file:
+utils
+determinants
+mo_one_e_ints
+
+TIPS
+----
+There are many many routines/providers in the core modules of QP. Nevertheless, as everything is coded with the IRPF90, you can use the following amazing tools: irpman
+irpman can be used in command line in bash to obtain all the info on a routine or variable !
+Ex: execute the following command line :
+irpman ao_one_e_integrals
+Then it appears all the information you want on ao_one_e_integrals, including where it is created, the type, dimension if it is an array, what providers it needs to be built, and what providers need this provider.
+
+
diff --git a/plugins/tuto_plugins/n2.xyz b/plugins/tuto_plugins/n2.xyz
new file mode 100644
index 00000000..016732d8
--- /dev/null
+++ b/plugins/tuto_plugins/n2.xyz
@@ -0,0 +1,4 @@
+2
+N2 Geo: Experiment Mult: 1 symmetry: 14
+N 0.0 0.0 0.5488
+N 0.0 0.0 -0.5488
diff --git a/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f b/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f
new file mode 100644
index 00000000..5d8dc1e7
--- /dev/null
+++ b/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f
@@ -0,0 +1,20 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j
+ print*,'AO integrals '
+ do i = 1, ao_num
+ do j = 1, ao_num
+ print*,j,i,ao_one_e_integrals(j,i)
+ enddo
+ enddo
+
+ print*,'MO integrals '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ print*,j,i,mo_one_e_integrals(j,i)
+ enddo
+ enddo
+end
diff --git a/plugins/tuto_plugins/tuto_I/tuto_I.rst b/plugins/tuto_plugins/tuto_I/tuto_I.rst
new file mode 100644
index 00000000..05db8635
--- /dev/null
+++ b/plugins/tuto_plugins/tuto_I/tuto_I.rst
@@ -0,0 +1,97 @@
+======================================
+Tutorial for plugin I: One-e integrals
+======================================
+
+!!! Requirements:
+ a) you know how to create an EZFIO file and run calculations with QP
+ (check the tuto: ``),
+ b) you have an EZFIO file in the sto-3g from the file H2.xyz in plugins/tuto_plugins,
+ and you have run an HF calculation giving an energy of -1.116759 a.u.,
+ c) you made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to be,
+ d) you have READ the ../README.rst file to HAVE THE VOCABULARY.
+
+Our goals:
+----------
+We want to create a plugin to do the following things:
+ a) print out one- and two-electron integrals on the AO/MO basis,
+ b) creates two providers which manipulate these objects,
+ c) print out these providers,
+
+I) Starting: creating the plugin
+--------------------------------
+We will go step-by-step through these plugins.
+
+The name of the plugin will be "plugin_I", and its location is in "tuto_plugins".
+Therefore to create the plugin, we do
+
+$ qp plugins create -n plugin_I -r tuto_plugins
+Then to an "ls" in qp2/plugins/tuto_plugins/
+and you will find a directory called "plugin_I".
+In that directory you will find:
+ i) a "NEED" file that will eventually contain all the other modules/plugins needed by our "plugin_I"
+ ii) a "README.rst" file that you can AND SHOULD modify in order to document what is doing the plugin.
+ iii) a "plugin_I.irp.f" file that is a program to be compiled and just printing "Hello world"
+
+II) Specifying the dependencies
+-------------------------------
+The next step is to know what are the other modules/plugins that we need to do what we want.
+We need here
+ a) the one-electron integrals on the AO basis, which are computed in qp2/src/ao_one_e_ints/
+ b) the one-electron integrals on the MO basis, which are computed in qp2/src/mo_one_e_ints/
+ c) the two-electron integrals on the AO basis, which are computed in qp2/src/ao_two_e_ints/
+ d) the two-electron integrals on the MO basis, which are computed in qp2/src/mo_two_e_ints/
+
+Therefore, we will need the following four modules:
+a) ao_one_e_ints
+b) mo_one_e_ints
+c) ao_two_e_ints
+d) mo_two_e_ints
+
+You can then create the following "NEED" file by executing the following command
+$ cat < NEED
+ao_one_e_ints
+mo_one_e_ints
+ao_two_e_ints
+mo_two_e_ints
+EOF
+
+II) Installing the plugin
+-------------------------
+Now that we have specified the various depenencies we need now to INSTALL the plugin, which means to create the equivalent of a Makefile for the compilation.
+To do it we simply do
+$ qp plugins install plugin_I
+
+III) Compiling the void plugin
+------------------------------
+It is customary to compile first your "void" plugin, void in the sense that it does not contain anything else than the program printing "Hello world".
+To do so, just go in the plugin and execute the following command
+$ ninja
+It does a lot of stuffs, but it must conclude with something like
+"
+make: Leaving directory 'SOME_PATH_TOWARD_YOUR_QP2_DIRECTORY/qp2/ocaml'
+"
+
+Since that it has compiled, an executable "plugin_I" has been created.
+Also, if you make "ls" in the "plugin_I" you will notice that many symbolink links have been created, and among which the four modules that you included in the NEED file.
+All the other modules (Ex:"ao_basis", "utils") are here because they are need by some of the four modules that you need.
+The variables that we need are
+ao_one_e_integrals
+mo_one_e_integrals
+You can check them with
+irpman ao_one_e_integral
+irpman mo_one_e_integral
+in order to get some information on where they are created, and many more information.
+We will modify the executable such that it prints out the integrals.
+
+
+IV) Printing out the one-electron integrals
+--------------------------------------------
+We will create a program that will print out the one-electron integrals on the AO and MO basis.
+You can then copy the file "print_one_e_h.irp.f" in your plugin.
+In the file you will see that we simply browse the two arrays "ao_one_e_integrals" and "mo_one_e_integrals", which are global variables (providers) and we browse them until either "ao_num" or "mo_num" which are also providers representing the number of AOs or MOs.
+You can check these variables with irpman !
+If you recompile using "ninja" as before, and another executable has been created "print_one_e_h".
+Then, you can run the program on the ezfio file by doing
+qp run print_one_e_h
+and will print out the data you need :)
+
From 7bc6b888549cf976ce7bee7b06e85109636552a7 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 21 Mar 2024 15:31:23 +0100
Subject: [PATCH 071/140] added H2.xyz in tuto_plugins
---
plugins/tuto_plugins/H2.xyz | 6 ++++++
1 file changed, 6 insertions(+)
create mode 100644 plugins/tuto_plugins/H2.xyz
diff --git a/plugins/tuto_plugins/H2.xyz b/plugins/tuto_plugins/H2.xyz
new file mode 100644
index 00000000..7af12291
--- /dev/null
+++ b/plugins/tuto_plugins/H2.xyz
@@ -0,0 +1,6 @@
+2
+H2, equilibrium geometry
+H 0.0 0.0 0.
+H 0.0 0.0 0.74
+
+
From 9d3743e530f2b7d342778a32bc2ca89e36f97044 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 22 Mar 2024 14:56:39 +0100
Subject: [PATCH 072/140] added some providers and the first tutorial for
plugins
---
plugins/README.rst | 4 +-
.../tuto_I/print_traces_on_e.irp.f | 24 ++++
.../tuto_plugins/tuto_I/print_two_e_h.irp.f | 32 +++++
.../tuto_plugins/tuto_I/traces_one_e.irp.f | 111 ++++++++++++++++++
plugins/tuto_plugins/tuto_I/tuto_I.rst | 65 +++++++---
src/ao_one_e_ints/ao_one_e_ints.irp.f | 10 ++
src/scf_utils/fock_matrix.irp.f | 4 +
src/utils/linear_algebra.irp.f | 19 +++
8 files changed, 250 insertions(+), 19 deletions(-)
create mode 100644 plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f
create mode 100644 plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f
create mode 100644 plugins/tuto_plugins/tuto_I/traces_one_e.irp.f
diff --git a/plugins/README.rst b/plugins/README.rst
index 7f3f3c75..7fc011a3 100644
--- a/plugins/README.rst
+++ b/plugins/README.rst
@@ -22,6 +22,8 @@ we will go through a series of examples that allow you to do the following thing
IV) print out the one- and two-electron rdms,
V) obtain the AOs and MOs on the DFT grid, together with the density,
+How the tutorial will be done
+-----------------------------
This tuto is as follows:
i) you READ THIS FILE UNTIL THE END in order to get the big picture and vocabulary,
ii) you go to the directory qp2/plugins/tuto_plugins/ and you will find detailed tuto there for each of the 5 examples.
@@ -32,7 +34,7 @@ The first thing to do is to be in the QPSH mode: you execute the qp2/bin/qpsh sc
the environement variables and allows for the completion of command lines in bash (that is an AMAZING feature :)
Then, you need to known where you want to create your plugin, and what is the name of the plugin.
-!!!! WARINING: The plugins are NECESSARILY located in qp2/plugins/ !!!!
+!!!! WARNING: The plugins are NECESSARILY located in qp2/plugins/ !!!!
Ex: If you want to create a plugin named "my_fancy_plugin" in the directory plugins/plugins_test/,
this goes with the command
qp plugins create -n my_fancy_plugin -r plugins_test/
diff --git a/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f b/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f
new file mode 100644
index 00000000..2bf3b86b
--- /dev/null
+++ b/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f
@@ -0,0 +1,24 @@
+program my_program
+ implicit none
+ BEGIN_DOC
+! This program is there essentially to show how one can use providers in programs
+ END_DOC
+ integer :: i,j
+ double precision :: accu
+ print*,'Trace on the AO basis '
+ print*,trace_ao_one_e_ints
+ print*,'Trace on the AO basis after projection on the MO basis'
+ print*,trace_ao_one_e_ints_from_mo
+ print*,'Trace of MO integrals '
+ print*,trace_mo_one_e_ints
+ print*,'ao_num = ',ao_num
+ print*,'mo_num = ',mo_num
+ if(ao_num .ne. mo_num)then
+ print*,'The AO basis and MO basis are different ...'
+ print*,'Trace on the AO basis should not be the same as Trace of MO integrals'
+ print*,'Only the second one must be equal to the trace on the MO integrals'
+ else
+ print*,'The AO basis and MO basis are the same !'
+ print*,'All traces should coincide '
+ endif
+end
diff --git a/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f b/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f
new file mode 100644
index 00000000..eaeb6c98
--- /dev/null
+++ b/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f
@@ -0,0 +1,32 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j,k,l
+ double precision :: integral
+ double precision :: get_ao_two_e_integral, get_two_e_integral ! declaration of the functions
+ print*,'AO integrals, physicist notations : '
+ do i = 1, ao_num
+ do j = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ print*,i,j,k,l,integral
+ enddo
+ enddo
+ enddo
+ enddo
+
+ print*,'MO integrals, physicist notations : '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ integral = get_two_e_integral(i, j, k, l, mo_integrals_map)
+ print*,i,j,k,l,integral
+ enddo
+ enddo
+ enddo
+ enddo
+end
diff --git a/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f b/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f
new file mode 100644
index 00000000..e71d49fc
--- /dev/null
+++ b/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f
@@ -0,0 +1,111 @@
+
+! This file is an example of the kind of manipulations that you can do with providers
+!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!! Main providers useful for the program !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!! type name
+BEGIN_PROVIDER [ double precision, trace_mo_one_e_ints]
+ implicit none
+ BEGIN_DOC
+! trace_mo_one_e_ints = Trace of the one-electron integrals on the MO basis
+!
+! = sum_i mo_one_e_integrals(i,i)
+ END_DOC
+ integer :: i
+ trace_mo_one_e_ints = 0.d0
+ do i = 1, mo_num
+ trace_mo_one_e_ints += mo_one_e_integrals(i,i)
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, trace_ao_one_e_ints]
+ implicit none
+ BEGIN_DOC
+! trace_ao_one_e_ints = Trace of the one-electron integrals on the AO basis taking into account the non orthogonality
+!
+! Be aware that the trace of an operator in a non orthonormal basis is Tr(A S^{-1}) = \sum_{m,n}(A_mn S^{-1}_mn)
+!
+! WARNING: it is equal to the trace on the MO basis if and only if the AO basis and MO basis
+! have the same number of functions
+ END_DOC
+ integer :: i,j
+ double precision, allocatable :: inv_overlap_times_integrals(:,:) ! = h S^{-1}
+ allocate(inv_overlap_times_integrals(ao_num,ao_num))
+ ! routine that computes the product of two matrices, you can check it with
+ ! irpman get_AB_prod
+ call get_AB_prod(ao_one_e_integrals,ao_num,ao_num,s_inv,ao_num,inv_overlap_times_integrals)
+ ! Tr(inv_overlap_times_integrals) = Tr(h S^{-1})
+ trace_ao_one_e_ints = 0.d0
+ do i = 1, ao_num
+ trace_ao_one_e_ints += inv_overlap_times_integrals(i,i)
+ enddo
+ !
+ ! testing the formula Tr(A S^{-1}) = \sum_{m,n}(A_mn S^{-1}_mn)
+ double precision :: test
+ test = 0.d0
+ do i = 1, ao_num
+ do j = 1, ao_num
+ test += ao_one_e_integrals(j,i) * s_inv(i,j)
+ enddo
+ enddo
+ if(dabs(accu - trace_ao_one_e_ints).gt.1.d-12)then
+ print*,'Warning ! '
+ print*,'Something is wrong because Tr(AB) \ne sum_{mn}A_mn B_nm'
+ endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, trace_ao_one_e_ints_from_mo]
+ implicit none
+ BEGIN_DOC
+! trace_ao_one_e_ints_from_mo = Trace of the one-electron integrals on the AO basis after projection on the MO basis
+!
+! = Tr([SC h {SC}^+] S^{-1})
+!
+! = Be aware that the trace of an operator in a non orthonormal basis is = Tr(A S^{-1}) where S is the metric
+! Must be equal to the trace_mo_one_e_ints
+ END_DOC
+ integer :: i
+ double precision, allocatable :: inv_overlap_times_integrals(:,:)
+ allocate(inv_overlap_times_integrals(ao_num,ao_num))
+ ! Using the provider ao_one_e_integrals_from_mo = [SC h {SC}^+]
+ call get_AB_prod(ao_one_e_integrals_from_mo,ao_num,ao_num,s_inv,ao_num,inv_overlap_times_integrals)
+ ! inv_overlap_times_integrals = [SC h {SC}^+] S^{-1}
+ trace_ao_one_e_ints_from_mo = 0.d0
+ ! Computing the trace
+ do i = 1, ao_num
+ trace_ao_one_e_ints_from_mo += inv_overlap_times_integrals(i,i)
+ enddo
+END_PROVIDER
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Additional providers to check some stuffs !!!!!!!!!!!!!!!!!!!!!!!!!
+
+BEGIN_PROVIDER [ double precision, ao_one_e_int_no_ov_from_mo, (ao_num, ao_num) ]
+ BEGIN_DOC
+ ! ao_one_e_int_no_ov_from_mo = C mo_one_e_integrals C^T
+ !
+ ! WARNING : NON EQUAL TO ao_one_e_integrals due to the non orthogonality
+ END_DOC
+ call mo_to_ao_no_overlap(mo_one_e_integrals,mo_num,ao_one_e_int_no_ov_from_mo,ao_num)
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, ao_one_e_int_no_ov_from_mo_ov_ov, (ao_num, ao_num)]
+ BEGIN_DOC
+ ! ao_one_e_int_no_ov_from_mo_ov_ov = S ao_one_e_int_no_ov_from_mo S = SC mo_one_e_integrals (SC)^T
+ !
+ ! EQUAL TO ao_one_e_integrals ONLY IF ao_num = mo_num
+ END_DOC
+ double precision, allocatable :: tmp(:,:)
+ allocate(tmp(ao_num, ao_num))
+ call get_AB_prod(ao_overlap,ao_num,ao_num,ao_one_e_int_no_ov_from_mo,ao_num,tmp)
+ call get_AB_prod(tmp,ao_num,ao_num,ao_overlap,ao_num,ao_one_e_int_no_ov_from_mo_ov_ov)
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, c_t_s_c, (mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+! C^T S C = should be the identity
+ END_DOC
+ call get_AB_prod(mo_coef_transp,mo_num,ao_num,S_mo_coef,mo_num,c_t_s_c)
+END_PROVIDER
+
diff --git a/plugins/tuto_plugins/tuto_I/tuto_I.rst b/plugins/tuto_plugins/tuto_I/tuto_I.rst
index 05db8635..fea07e3d 100644
--- a/plugins/tuto_plugins/tuto_I/tuto_I.rst
+++ b/plugins/tuto_plugins/tuto_I/tuto_I.rst
@@ -1,14 +1,15 @@
-======================================
-Tutorial for plugin I: One-e integrals
-======================================
+=====================================================================
+Tutorial for plugin I: One-e integrals (duration: 20 minutes at most)
+=====================================================================
-!!! Requirements:
- a) you know how to create an EZFIO file and run calculations with QP
+Requirements
+------------
+ a) You know how to create an EZFIO file and run calculations with QP
(check the tuto: ``),
- b) you have an EZFIO file in the sto-3g from the file H2.xyz in plugins/tuto_plugins,
- and you have run an HF calculation giving an energy of -1.116759 a.u.,
- c) you made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to be,
- d) you have READ the ../README.rst file to HAVE THE VOCABULARY.
+ b) You have an EZFIO file with MOs created (with the 'scf' executable for instance).
+ As we are going to print out some integrals, don't take a too large system/basis (Ex: H2, cc-pVDZ is ok :)
+ c) You made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to work on that ezfio folder,
+ d) You have READ the ../README.rst file to HAVE THE VOCABULARY.
Our goals:
----------
@@ -22,14 +23,14 @@ I) Starting: creating the plugin
We will go step-by-step through these plugins.
The name of the plugin will be "plugin_I", and its location is in "tuto_plugins".
-Therefore to create the plugin, we do
+Therefore to create the plugin, we do:
-$ qp plugins create -n plugin_I -r tuto_plugins
-Then to an "ls" in qp2/plugins/tuto_plugins/
-and you will find a directory called "plugin_I".
+qp plugins create -n plugin_I -r tuto_plugins
+
+Then do an "ls" in qp2/plugins/tuto_plugins/ and you will find a directory called "plugin_I".
In that directory you will find:
- i) a "NEED" file that will eventually contain all the other modules/plugins needed by our "plugin_I"
- ii) a "README.rst" file that you can AND SHOULD modify in order to document what is doing the plugin.
+ i) a "NEED" file that will eventually contain all the other modules/plugins needed by our "plugin_I"
+ ii) a "README.rst" file that you can AND SHOULD modify in order to document what is doing the plugin.
iii) a "plugin_I.irp.f" file that is a program to be compiled and just printing "Hello world"
II) Specifying the dependencies
@@ -78,8 +79,8 @@ The variables that we need are
ao_one_e_integrals
mo_one_e_integrals
You can check them with
-irpman ao_one_e_integral
-irpman mo_one_e_integral
+irpman ao_one_e_integrals
+irpman mo_one_e_integrals
in order to get some information on where they are created, and many more information.
We will modify the executable such that it prints out the integrals.
@@ -87,7 +88,7 @@ We will modify the executable such that it prints out the integrals.
IV) Printing out the one-electron integrals
--------------------------------------------
We will create a program that will print out the one-electron integrals on the AO and MO basis.
-You can then copy the file "print_one_e_h.irp.f" in your plugin.
+You can then copy the file "print_one_e_h.irp.f" located in "plugins/tuto_plugins/tuto_I" in your plugin.
In the file you will see that we simply browse the two arrays "ao_one_e_integrals" and "mo_one_e_integrals", which are global variables (providers) and we browse them until either "ao_num" or "mo_num" which are also providers representing the number of AOs or MOs.
You can check these variables with irpman !
If you recompile using "ninja" as before, and another executable has been created "print_one_e_h".
@@ -95,3 +96,31 @@ Then, you can run the program on the ezfio file by doing
qp run print_one_e_h
and will print out the data you need :)
+By the way, as the file "plugin_I.irp.f" contains nothing but a "Hello world" print, you can simply remove it if you want.
+V) Printing out the two-electron integrals
+------------------------------------------
+We will now create a file that prints out the two-electron integrals in the AO and MO basis.
+These can be accessed with the following subroutines :
++) get_ao_two_e_integral for the AO basis
++) get_two_e_integral for the MO basis
+check them with irpman !
+To print the two-electron integrals, you can copy the file "print_two_e_h.irp.f" in your plugin and recompile.
+Then just run the program
+qp run print_two_e_h
+and it will print all the things you want :)
+
+VI) Creating new providers and a program to print them
+------------------------------------------------------
+We will now create new providers that manipulates the objects that we just printed.
+As an example, we will compute the trace of the one electron integrals in the AO and MO basis.
+In the file "traces_one_e.irp.f" you will find the several new providers among which
+ a) trace_mo_one_e_ints : simply the sum of the diagonal matrix element of the one-electron integrals
+ b) trace_ao_one_e_ints : the corresponding trace on the AO basis : Sum(m,n) S^{-1}_{mn} h_{mn}
+ c) trace_ao_one_e_ints_from_mo : the trace on the AO basis with the integrals obtained first from the MO basis
+As explained in these files, "trace_mo_one_e_ints" is equal to "trace_ao_one_e_ints" only if the number of AO basis functions is equal to the number of MO basis functions, which means if you work with cartesian functions.
+(You can check with "qp create_ezfio -h" for the option to create an EZFIO with cartesian basis functions)
+
+In the file "print_traces_on_e.irp.f" you will find an example of executable that prints out the various providers.
+Copy these two files in your plugin and recompile to execute it.
+
+Execute the program print_traces_on_e and check for the results !
diff --git a/src/ao_one_e_ints/ao_one_e_ints.irp.f b/src/ao_one_e_ints/ao_one_e_ints.irp.f
index 65981dc9..9b914dee 100644
--- a/src/ao_one_e_ints/ao_one_e_ints.irp.f
+++ b/src/ao_one_e_ints/ao_one_e_ints.irp.f
@@ -45,3 +45,13 @@ BEGIN_PROVIDER [ double precision, ao_one_e_integrals_imag,(ao_num,ao_num)]
END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, ao_one_e_integrals_from_mo, (ao_num, ao_num)]
+ implicit none
+ BEGIN_DOC
+! Integrals of the one e hamiltonian obtained from the integrals on the MO basis
+!
+! WARNING : this is equal to ao_one_e_integrals only if the AO and MO basis have the same number of functions
+ END_DOC
+ call mo_to_ao(mo_one_e_integrals,mo_num,ao_one_e_integrals_from_mo,ao_num)
+END_PROVIDER
diff --git a/src/scf_utils/fock_matrix.irp.f b/src/scf_utils/fock_matrix.irp.f
index 1942e542..c8fa8333 100644
--- a/src/scf_utils/fock_matrix.irp.f
+++ b/src/scf_utils/fock_matrix.irp.f
@@ -166,6 +166,10 @@
if(frozen_orb_scf)then
integer :: iorb,jorb
+ ! active|core|active
+ !active | | 0 |
+ !core | 0 | | 0
+ !active | | 0 |
do i = 1, n_core_orb
iorb = list_core(i)
do j = 1, n_act_orb
diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f
index 26e390b7..20386b30 100644
--- a/src/utils/linear_algebra.irp.f
+++ b/src/utils/linear_algebra.irp.f
@@ -2041,3 +2041,22 @@ subroutine get_A_squared(A,n,A2)
double precision, intent(out):: A2(n,n)
call dgemm('N','N',n,n,n,1.d0,A,size(A,1),A,size(A,1),0.d0,A2,size(A2,1))
end
+
+subroutine get_AB_prod(A,n,m,B,l,AB)
+ implicit none
+ BEGIN_DOC
+! AB = A B where A is n x m, B is m x l. Use the dgemm routine
+ END_DOC
+ double precision, intent(in) :: A(n,m),B(m,l)
+ integer, intent(in) :: n,m,l
+ double precision, intent(out):: AB(n,l)
+ if(size(A,2).ne.m.or.size(B,1).ne.m)then
+ print*,'error in get_AB_prod ! '
+ print*,'matrices do not have the good dimension '
+ print*,'size(A,2) = ',size(A,2)
+ print*,'size(B,1) = ',size(B,1)
+ print*,'m = ',m
+ stop
+ endif
+ call dgemm('N','N',n,l,m,1.d0,A,size(A,1),B,size(B,1),0.d0,AB,size(AB,1))
+end
From dd2f0a2c0770b9d1e26522fa7a80f1ee55865408 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 22 Mar 2024 16:30:08 +0100
Subject: [PATCH 073/140] added the introduction to the plugins tutorial
---
docs/source/appendix/contributors.rst | 1 +
docs/source/index.rst | 3 +-
external/irpf90 | 2 +-
plugins/README.rst | 148 +++++++++++++++++---------
4 files changed, 104 insertions(+), 50 deletions(-)
diff --git a/docs/source/appendix/contributors.rst b/docs/source/appendix/contributors.rst
index e3574e5a..74837282 100644
--- a/docs/source/appendix/contributors.rst
+++ b/docs/source/appendix/contributors.rst
@@ -46,6 +46,7 @@ The following people have contributed to this project (by alphabetical order):
* Nicolas Renon
* Lorenzo Tenti
* Julien Toulouse
+* Diata Traoré
* Mikaël Véril
diff --git a/docs/source/index.rst b/docs/source/index.rst
index 4231b1f8..e7e63260 100644
--- a/docs/source/index.rst
+++ b/docs/source/index.rst
@@ -39,9 +39,9 @@
programmers_guide/programming
programmers_guide/ezfio
programmers_guide/plugins
+ programmers_guide/plugins_tuto_intro
programmers_guide/new_ks
programmers_guide/index
- programmers_guide/plugins
.. toctree::
@@ -52,5 +52,6 @@
appendix/benchmarks
appendix/license
appendix/contributors
+ appendix/references
diff --git a/external/irpf90 b/external/irpf90
index ba1a2837..4ab1b175 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit ba1a2837aa61cb8f9892860cec544d7c6659badd
+Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
diff --git a/plugins/README.rst b/plugins/README.rst
index 7fc011a3..3214a619 100644
--- a/plugins/README.rst
+++ b/plugins/README.rst
@@ -3,76 +3,128 @@ Tutorial for creating a plugin
==============================
Introduction: what is a plugin, and what this tuto will be about ?
-============================================================
-The QP is split into two kinds of routines/global variables (i.e. providers):
- i) the core modules locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
- ii) the plugins which are external stuffs connected to the qp2/src/ stuffs.
+==================================================================
+
+The |QP| is split into two kinds of routines/global variables (i.e. *providers*):
+ i) the **core modules** locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
+ ii) the **plugins** which are external routines/*providers* connected to the qp2/src/ routines/*providers*.
-More precisely, a plugin of the QP is a directory where you can create routines,
+More precisely, a **plugin** of the |QP| is a directory where you can create routines,
providers and executables that use all the global variables/functions/routines already created
-in the modules ofqp2/src or in other plugins.
+in the modules of qp2/src or in other plugins.
Instead of giving a theoretical lecture on what is a plugin,
we will go through a series of examples that allow you to do the following thing:
- I) print out one- and two-electron integrals on the AO/MO basis,
- creates two providers which manipulate these objects,
- print out these providers,
- II) browse the Slater determinants stored in the EZFIO wave function and compute their matrix elements,
- III) build the Hamiltonian matrix and diagonalize it either with Lapck or Davidson,
- IV) print out the one- and two-electron rdms,
- V) obtain the AOs and MOs on the DFT grid, together with the density,
+
+i) print out **one- and two-electron integrals** on the AO/MO basis, creates two providers which manipulate these objects, print out these providers,
+
+ii) browse the **Slater determinants stored** in the |EZFIO| wave function and compute their matrix elements,
+
+iii) build the **Hamiltonian matrix** and **diagonalize** it either with **Lapack or Davidson**,
+
+iv) print out the **one- and two-electron rdms**,
+
+v) obtain the **AOs** and **MOs** on the **DFT grid**, together with the **density**,
How the tutorial will be done
-----------------------------
+
This tuto is as follows:
- i) you READ THIS FILE UNTIL THE END in order to get the big picture and vocabulary,
- ii) you go to the directory qp2/plugins/tuto_plugins/ and you will find detailed tuto there for each of the 5 examples.
+
+ i) you **READ THIS FILE UNTIL THE END** in order to get the big picture and vocabulary,
+
+ ii) you go to the directory :file:`qp2/plugins/tuto_plugins/` and you will find detailed tutorials for each of the 5 examples.
Creating a plugin: the basic
----------------------------
+
The first thing to do is to be in the QPSH mode: you execute the qp2/bin/qpsh script that essentially loads all
the environement variables and allows for the completion of command lines in bash (that is an AMAZING feature :)
-Then, you need to known where you want to create your plugin, and what is the name of the plugin.
-!!!! WARNING: The plugins are NECESSARILY located in qp2/plugins/ !!!!
+Then, you need to known **where** you want to create your plugin, and what is the **name** of the plugin.
+
+.. important::
+
+ The plugins are **NECESSARILY** located in qp2/plugins/, and from there you can create any structures of directories.
+
+
Ex: If you want to create a plugin named "my_fancy_plugin" in the directory plugins/plugins_test/,
this goes with the command
-qp plugins create -n my_fancy_plugin -r plugins_test/
-Then, to create plugin of your dreams, the two questions you need to answer are the following:
-a) What do I need to compute what I want, which means what are the objects that I need ?
+.. code:: bash
+
+ qp plugins create -n my_fancy_plugin -r plugins_test/
+
+Then, to create the plugin of your dreams, the two questions you need to answer are the following:
+
+1) What do I **need** to compute what I want, which means what are the **objects** that I need ?
+
There are two kind of objects:
- + the routines/functions
+
+ + the *routines/functions*:
+
Ex: Linear algebra routines, integration routines etc ...
- + the global variables which are called the PROVIDERS
+
+ + the global variables which are called the *providers*:
+
Ex: one-electron integrals, Slater determinants, density matrices etc ...
-b) Where do I find these objects ?
- The objects (routines/functions/providers) are necessarily created in other modules/plugins
- Ex: the routine "lapack_diagd" (which diagonalises a real hermitian matrix) is located in the file
- qp2/src/utils/linear_algebra.irp.f
- therefore it "belongs" to the module "utils"
- : the routine "ao_to_mo" (which converts a given matrix A from the AO basis to the MO basis) is located in the file
- qp2/src/mo_one_e_ints/ao_to_mo.irp.f
- therefore it "belongs" to the module "mo_one_e_ints"
- : the provider "ao_one_e_integrals" (which is the integrals of one-body part of H on the AO basis) is located in the file
- qp2/src/mo_one_e_ints/ao_to_mo.irp.f
- therefore it belongs to the module "mo_one_e_ints"
- : the provider "one_e_dm_mo_beta_average" (which is the state average beta density matrix on the MO basis) is located in the file
- qp2/src/determinants/density_matrix.irp.f
- therefore it belongs to the module "determinants"
-To import all the variables that you need, you just need to write the name of the plugins in the file "NEED"
-Ex: to import all the variables/routines of the module "utils", "determinants" and "mo_one_e_ints" you will have the following NEED file:
-utils
-determinants
-mo_one_e_ints
+2) **Where do I find** these objects ?
-TIPS
-----
-There are many many routines/providers in the core modules of QP. Nevertheless, as everything is coded with the IRPF90, you can use the following amazing tools: irpman
-irpman can be used in command line in bash to obtain all the info on a routine or variable !
-Ex: execute the following command line :
-irpman ao_one_e_integrals
-Then it appears all the information you want on ao_one_e_integrals, including where it is created, the type, dimension if it is an array, what providers it needs to be built, and what providers need this provider.
+ The objects (routines/functions/providers) are necessarily created in other *modules/plugins*.
+
+.. seealso::
+
+ The routine :c:func:`lapack_diagd` (which diagonalises a real hermitian matrix) is located in the file
+ :file:`qp2/src/utils/linear_algebra.irp.f`
+ therefore it "belongs" to the module "utils"
+
+ The routine :c:func:`ao_to_mo` (which converts a given matrix A from the AO basis to the MO basis) is located in the file
+ :file:`qp2/src/mo_one_e_ints/ao_to_mo.irp.f`
+ therefore it "belongs" to the module "mo_one_e_ints"
+
+ The provider :c:data:`ao_one_e_integrals` (which is the integrals of one-body part of H on the AO basis) is located in the file
+ :file:`qp2/src/mo_one_e_ints/ao_to_mo.irp.f`
+ therefore it belongs to the module "mo_one_e_ints"
+
+ The provider :c:data:`one_e_dm_mo_beta_average` (which is the state average beta density matrix on the MO basis) is located in the file
+ :file:`qp2/src/determinants/density_matrix.irp.f`
+ therefore it belongs to the module "determinants"
+
+To import all the variables that you need, you just need to write the name of the plugins in the :file:`NEED` file .
+
+To import all the variables/routines of the module "utils", "determinants" and "mo_one_e_ints", the :file:`NEED` file you will need is simply the following:
+
+.. code:: bash
+
+ cat NEED
+
+ utils
+ determinants
+ mo_one_e_ints
+
+
+.. important::
+
+ There are **many** routines/providers in the core modules of QP.
+
+ Nevertheless, as everything is coded with the |IRPF90|, you can use the following amazing tools: :command:`irpman`
+
+ :command:`irpman` can be used in command line in bash to obtain all the info on a routine or variable !
+
+
+Example: execute the following command line :
+
+.. code:: bash
+
+ irpman ao_one_e_integrals
+
+Then all the information you need on :c:data:`ao_one_e_integrals` will appear on the screen.
+This includes
+ - **where** the provider is created, (*i.e.* the actual file where the provider is designed)
+ - the **type** of the provider (*i.e.* a logical, integer etc ...)
+ - the **dimension** if it is an array,
+ - what other *providers* are **needed** to build this provider,
+ - what other *providers* **need** this provider.
From e0af6d84258ebc3540628d59c62d3d937ca5a9e3 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 22 Mar 2024 17:29:32 +0100
Subject: [PATCH 074/140] added properly the first tuto!
---
docs/source/index.rst | 1 +
plugins/README.rst | 35 ++--
plugins/tuto_plugins/tuto_I/tuto_I.rst | 220 ++++++++++++++++++-------
3 files changed, 175 insertions(+), 81 deletions(-)
diff --git a/docs/source/index.rst b/docs/source/index.rst
index e7e63260..273582d4 100644
--- a/docs/source/index.rst
+++ b/docs/source/index.rst
@@ -40,6 +40,7 @@
programmers_guide/ezfio
programmers_guide/plugins
programmers_guide/plugins_tuto_intro
+ programmers_guide/plugins_tuto_I
programmers_guide/new_ks
programmers_guide/index
diff --git a/plugins/README.rst b/plugins/README.rst
index 3214a619..3dc50873 100644
--- a/plugins/README.rst
+++ b/plugins/README.rst
@@ -2,12 +2,12 @@
Tutorial for creating a plugin
==============================
-Introduction: what is a plugin, and what this tuto will be about ?
-==================================================================
+Introduction: what is a plugin, and what tutorial will be about ?
+=================================================================
The |QP| is split into two kinds of routines/global variables (i.e. *providers*):
- i) the **core modules** locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
- ii) the **plugins** which are external routines/*providers* connected to the qp2/src/ routines/*providers*.
+ 1) the **core modules** locatedin qp2/src/, which contains all the bulk of a quantum chemistry software (integrals, matrix elements between Slater determinants, linear algebra routines, DFT stuffs etc..)
+ 2) the **plugins** which are external routines/*providers* connected to the qp2/src/ routines/*providers*.
More precisely, a **plugin** of the |QP| is a directory where you can create routines,
providers and executables that use all the global variables/functions/routines already created
@@ -16,24 +16,24 @@ in the modules of qp2/src or in other plugins.
Instead of giving a theoretical lecture on what is a plugin,
we will go through a series of examples that allow you to do the following thing:
-i) print out **one- and two-electron integrals** on the AO/MO basis, creates two providers which manipulate these objects, print out these providers,
+1) print out **one- and two-electron integrals** on the AO/MO basis, creates two providers which manipulate these objects, print out these providers,
-ii) browse the **Slater determinants stored** in the |EZFIO| wave function and compute their matrix elements,
+2) browse the **Slater determinants stored** in the |EZFIO| wave function and compute their matrix elements,
-iii) build the **Hamiltonian matrix** and **diagonalize** it either with **Lapack or Davidson**,
+3) build the **Hamiltonian matrix** and **diagonalize** it either with **Lapack or Davidson**,
-iv) print out the **one- and two-electron rdms**,
+4) print out the **one- and two-electron rdms**,
-v) obtain the **AOs** and **MOs** on the **DFT grid**, together with the **density**,
+5) obtain the **AOs** and **MOs** on the **DFT grid**, together with the **density**,
How the tutorial will be done
-----------------------------
This tuto is as follows:
- i) you **READ THIS FILE UNTIL THE END** in order to get the big picture and vocabulary,
+ 1) you **READ THIS FILE UNTIL THE END** in order to get the big picture and vocabulary,
- ii) you go to the directory :file:`qp2/plugins/tuto_plugins/` and you will find detailed tutorials for each of the 5 examples.
+ 2) you go to the directory :file:`qp2/plugins/tuto_plugins/` and you will find detailed tutorials for each of the 5 examples.
Creating a plugin: the basic
----------------------------
@@ -77,23 +77,23 @@ Then, to create the plugin of your dreams, the two questions you need to answer
The routine :c:func:`lapack_diagd` (which diagonalises a real hermitian matrix) is located in the file
:file:`qp2/src/utils/linear_algebra.irp.f`
- therefore it "belongs" to the module "utils"
+ therefore it "belongs" to the module :ref:`module_utils`
The routine :c:func:`ao_to_mo` (which converts a given matrix A from the AO basis to the MO basis) is located in the file
:file:`qp2/src/mo_one_e_ints/ao_to_mo.irp.f`
- therefore it "belongs" to the module "mo_one_e_ints"
+ therefore it "belongs" to the module :ref:`module_mo_one_e_ints`
The provider :c:data:`ao_one_e_integrals` (which is the integrals of one-body part of H on the AO basis) is located in the file
- :file:`qp2/src/mo_one_e_ints/ao_to_mo.irp.f`
- therefore it belongs to the module "mo_one_e_ints"
+ :file:`qp2/src/ao_one_e_ints/ao_one_e_ints.irp.f`
+ therefore it belongs to the module :ref:`module_ao_one_e_ints`
The provider :c:data:`one_e_dm_mo_beta_average` (which is the state average beta density matrix on the MO basis) is located in the file
:file:`qp2/src/determinants/density_matrix.irp.f`
- therefore it belongs to the module "determinants"
+ therefore it belongs to the module :ref:`module_determinants`
To import all the variables that you need, you just need to write the name of the plugins in the :file:`NEED` file .
-To import all the variables/routines of the module "utils", "determinants" and "mo_one_e_ints", the :file:`NEED` file you will need is simply the following:
+To import all the variables/routines of the module :ref:`module_utils`, :ref:`module_determinants` and :ref:`module_mo_one_e_ints`, the :file:`NEED` file you will need is simply the following:
.. code:: bash
@@ -121,6 +121,7 @@ Example: execute the following command line :
Then all the information you need on :c:data:`ao_one_e_integrals` will appear on the screen.
This includes
+
- **where** the provider is created, (*i.e.* the actual file where the provider is designed)
- the **type** of the provider (*i.e.* a logical, integer etc ...)
- the **dimension** if it is an array,
diff --git a/plugins/tuto_plugins/tuto_I/tuto_I.rst b/plugins/tuto_plugins/tuto_I/tuto_I.rst
index fea07e3d..43b4af0b 100644
--- a/plugins/tuto_plugins/tuto_I/tuto_I.rst
+++ b/plugins/tuto_plugins/tuto_I/tuto_I.rst
@@ -1,126 +1,218 @@
-=====================================================================
-Tutorial for plugin I: One-e integrals (duration: 20 minutes at most)
-=====================================================================
+=============================================
+Tuto I: One- and two-e integrals (20 minutes)
+=============================================
Requirements
------------
- a) You know how to create an EZFIO file and run calculations with QP
- (check the tuto: ``),
- b) You have an EZFIO file with MOs created (with the 'scf' executable for instance).
- As we are going to print out some integrals, don't take a too large system/basis (Ex: H2, cc-pVDZ is ok :)
- c) You made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to work on that ezfio folder,
- d) You have READ the ../README.rst file to HAVE THE VOCABULARY.
+1) You know how to create an |EZFIO| file and run calculations with |QP| (check the tuto: ``_),
+
+2) You have an |EZFIO| file with MOs created (with the :ref:`scf` executable for instance). As we are going to print out some integrals, don't take a too large system/basis (Ex: H2, cc-pVDZ is ok :)
+
+3) You made an qp set_file YOUR_EZFIO_FILE_FOR_H2 in order to work on that ezfio folder.
+
+4) You have READ the :file:`qp2/plugins/README.rst` file to HAVE THE **VOCABULARY**.
Our goals:
----------
We want to create a plugin to do the following things:
- a) print out one- and two-electron integrals on the AO/MO basis,
- b) creates two providers which manipulate these objects,
- c) print out these providers,
+ 1) print out one- and two-electron integrals on the AO/MO basis,
-I) Starting: creating the plugin
---------------------------------
+ 2) creates two providers which manipulate these objects,
+
+ 3) print out these providers.
+
+I) Getting started: creating the plugin
+---------------------------------------
We will go step-by-step through these plugins.
-The name of the plugin will be "plugin_I", and its location is in "tuto_plugins".
+We will create a plugin named "plugin_I", and its location will be in "tuto_plugins".
Therefore to create the plugin, we do:
-qp plugins create -n plugin_I -r tuto_plugins
+.. code:: bash
+
+ qp plugins create -n plugin_I -r tuto_plugins
Then do an "ls" in qp2/plugins/tuto_plugins/ and you will find a directory called "plugin_I".
+
In that directory you will find:
- i) a "NEED" file that will eventually contain all the other modules/plugins needed by our "plugin_I"
- ii) a "README.rst" file that you can AND SHOULD modify in order to document what is doing the plugin.
- iii) a "plugin_I.irp.f" file that is a program to be compiled and just printing "Hello world"
+
+1) a :file:`NEED` file that will eventually contain all the other modules/plugins needed by our "plugin_I",
+
+2) a :file:`README.rst` file that you can and **SHOULD** modify in order to **DOCUMENT** what is doing the plugin,
+
+3) a :file:`plugin_I.irp.f` file that is a program to be compiled and just printing "Hello world"
II) Specifying the dependencies
-------------------------------
The next step is to know what are the other modules/plugins that we need to do what we want.
We need here
- a) the one-electron integrals on the AO basis, which are computed in qp2/src/ao_one_e_ints/
- b) the one-electron integrals on the MO basis, which are computed in qp2/src/mo_one_e_ints/
- c) the two-electron integrals on the AO basis, which are computed in qp2/src/ao_two_e_ints/
- d) the two-electron integrals on the MO basis, which are computed in qp2/src/mo_two_e_ints/
+
+a) the one-electron integrals on the AO basis, which are computed in :file:`qp2/src/ao_one_e_ints/`
+
+b) the one-electron integrals on the MO basis, which are computed in :file:`qp2/src/mo_one_e_ints/`
+
+c) the two-electron integrals on the AO basis, which are computed in :file:`qp2/src/ao_two_e_ints/`
+
+d) the two-electron integrals on the MO basis, which are computed in :file:`qp2/src/mo_two_e_ints/`
Therefore, we will need the following four modules:
-a) ao_one_e_ints
-b) mo_one_e_ints
-c) ao_two_e_ints
-d) mo_two_e_ints
+
+ a) ao_one_e_ints
+ b) mo_one_e_ints
+ c) ao_two_e_ints
+ d) mo_two_e_ints
You can then create the following "NEED" file by executing the following command
-$ cat < NEED
-ao_one_e_ints
-mo_one_e_ints
-ao_two_e_ints
-mo_two_e_ints
-EOF
+
+.. code:: bash
+
+ cat < NEED
+ ao_one_e_ints
+ mo_one_e_ints
+ ao_two_e_ints
+ mo_two_e_ints
+ EOF
II) Installing the plugin
-------------------------
Now that we have specified the various depenencies we need now to INSTALL the plugin, which means to create the equivalent of a Makefile for the compilation.
+
To do it we simply do
-$ qp plugins install plugin_I
+
+.. code:: bash
+
+ qp plugins install plugin_I
+
III) Compiling the void plugin
------------------------------
It is customary to compile first your "void" plugin, void in the sense that it does not contain anything else than the program printing "Hello world".
+
To do so, just go in the plugin and execute the following command
-$ ninja
+
+.. code:: bash
+
+ ninja
+
It does a lot of stuffs, but it must conclude with something like
-"
-make: Leaving directory 'SOME_PATH_TOWARD_YOUR_QP2_DIRECTORY/qp2/ocaml'
-"
+
+.. code:: bash
+
+ make: Leaving directory 'SOME_PATH_TOWARD_YOUR_QP2_DIRECTORY/qp2/ocaml'
+
Since that it has compiled, an executable "plugin_I" has been created.
+
Also, if you make "ls" in the "plugin_I" you will notice that many symbolink links have been created, and among which the four modules that you included in the NEED file.
-All the other modules (Ex:"ao_basis", "utils") are here because they are need by some of the four modules that you need.
+
+All the other modules (Ex::ref:`module_ao_basis`, :ref:`module_utils`) are here because they are need by some of the four modules that you need.
The variables that we need are
-ao_one_e_integrals
-mo_one_e_integrals
+
+:data:`ao_one_e_integrals`
+
+:data:`mo_one_e_integrals`
+
You can check them with
-irpman ao_one_e_integrals
-irpman mo_one_e_integrals
+
+.. code:: bash
+
+ irpman ao_one_e_integrals
+
+
+.. code:: bash
+
+ irpman mo_one_e_integrals
+
in order to get some information on where they are created, and many more information.
-We will modify the executable such that it prints out the integrals.
+We will now create an executable such that it prints out the integrals.
IV) Printing out the one-electron integrals
--------------------------------------------
-We will create a program that will print out the one-electron integrals on the AO and MO basis.
-You can then copy the file "print_one_e_h.irp.f" located in "plugins/tuto_plugins/tuto_I" in your plugin.
-In the file you will see that we simply browse the two arrays "ao_one_e_integrals" and "mo_one_e_integrals", which are global variables (providers) and we browse them until either "ao_num" or "mo_num" which are also providers representing the number of AOs or MOs.
-You can check these variables with irpman !
-If you recompile using "ninja" as before, and another executable has been created "print_one_e_h".
+We will now create a program that will print out the one-electron integrals on the AO and MO basis.
+
+You can then copy the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f` in your plugin.
+
+In this file you will see that we simply browse the two arrays :data:`ao_one_e_integrals` and :data:`mo_one_e_integrals`, which are the providers and we browse them until either :data:`ao_num` or :data:`mo_num` which are also providers representing the number of AOs or MOs.
+
+
+.. seealso::
+
+ You can check these variables with :command:`irpman` !
+
+If you recompile using |ninja| as before, and another executable has been created "print_one_e_h".
Then, you can run the program on the ezfio file by doing
-qp run print_one_e_h
+
+.. code:: bash
+
+ qp run print_one_e_h
+
and will print out the data you need :)
-By the way, as the file "plugin_I.irp.f" contains nothing but a "Hello world" print, you can simply remove it if you want.
+By the way, as the file :file:`plugin_I.irp.f` contains nothing but a "Hello world" print, you can simply remove it if you want.
+
V) Printing out the two-electron integrals
------------------------------------------
We will now create a file that prints out the two-electron integrals in the AO and MO basis.
These can be accessed with the following subroutines :
-+) get_ao_two_e_integral for the AO basis
-+) get_two_e_integral for the MO basis
-check them with irpman !
-To print the two-electron integrals, you can copy the file "print_two_e_h.irp.f" in your plugin and recompile.
+
+1- :c:func:`get_ao_two_e_integral` for the AO basis
+
+2- :c:func:`get_two_e_integral` for the MO basis
+
+
+.. seealso::
+
+ check them with irpman !
+
+To print the two-electron integrals, you can copy the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f` in your plugin and recompile with |ninja|.
Then just run the program
-qp run print_two_e_h
+
+.. code:: bash
+
+ qp run print_two_e_h
+
and it will print all the things you want :)
VI) Creating new providers and a program to print them
------------------------------------------------------
We will now create new providers that manipulates the objects that we just printed.
As an example, we will compute the trace of the one electron integrals in the AO and MO basis.
-In the file "traces_one_e.irp.f" you will find the several new providers among which
- a) trace_mo_one_e_ints : simply the sum of the diagonal matrix element of the one-electron integrals
- b) trace_ao_one_e_ints : the corresponding trace on the AO basis : Sum(m,n) S^{-1}_{mn} h_{mn}
- c) trace_ao_one_e_ints_from_mo : the trace on the AO basis with the integrals obtained first from the MO basis
-As explained in these files, "trace_mo_one_e_ints" is equal to "trace_ao_one_e_ints" only if the number of AO basis functions is equal to the number of MO basis functions, which means if you work with cartesian functions.
-(You can check with "qp create_ezfio -h" for the option to create an EZFIO with cartesian basis functions)
+In the file :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` you will find the several new providers among which
-In the file "print_traces_on_e.irp.f" you will find an example of executable that prints out the various providers.
+ 1- :c:data:`trace_mo_one_e_ints` : simply the sum of the diagonal matrix element of the one-electron integrals
+
+ 2- :c:data:`trace_ao_one_e_ints` : the corresponding trace on the AO basis
+ .. math::
+
+ \text{Tr}({\bf h}{\bf S}^{-1}) = \sum_{m,n} S^{-1}_{mn} h_{mn}
+
+
+ 3- :c:data:`trace_ao_one_e_ints_from_mo` : the trace on the AO basis with the integrals obtained first from the MO basis
+ .. math::
+
+ \text{Tr}({\bf \tilde{h}}{\bf S}^{-1}) = \text{Tr}\big({\bf SC h}({\bf SC }^T){\bf S}^{-1}\big)
+
+Just copy the :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` in your plugin and recompile.
+
+.. seealso::
+
+ Once it has compiled, check your new providers with :command:`irpman` !
+
+As explained in the files :file:`qp2/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f` and :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f`, :c:data:`trace_mo_one_e_ints` is equal to :c:data:`trace_ao_one_e_ints` only if the number of AO basis functions is equal to the number of MO basis functions, which means if you work with cartesian functions.
+
+
+.. seealso::
+
+ You can check with :command:`qp create_ezfio -h` for the option to create an |EZFIO| with cartesian basis functions
+
+In the file :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f` you will find an example of executable that prints out the various providers.
Copy these two files in your plugin and recompile to execute it.
-Execute the program print_traces_on_e and check for the results !
+Execute the program print_traces_on_e and check for the results with
+
+.. code:: bash
+
+ qp run print_traces_on_e
+
+The code in :file:`qp2/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f` should be easy to read, I let the reader interpret it.
From 64523de3aecf31a90ed791fbb87be40094f1f930 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 22 Mar 2024 18:33:17 +0100
Subject: [PATCH 075/140] minor modifs in cipsi_tc_bi_ortho/selection.irp.f
---
plugins/local/cipsi_tc_bi_ortho/selection.irp.f | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index e0637fa5..12163e06 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -960,7 +960,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
! endif
e_pert(istate) = 0.25 * val / delta_E
! e_pert(istate) = 0.5d0 * (tmp - delta_E)
- if(dsqrt(dabs(tmp)).gt.1.d-4.and.dabs(alpha_h_psi).gt.1.d-4)then
+ if(dsqrt(tmp).gt.1.d-4.and.dabs(psi_h_alpha).gt.1.d-4)then
coef(istate) = e_pert(istate) / psi_h_alpha
else
coef(istate) = alpha_h_psi / delta_E
From 9abc0c996af808e0cd77c4cbe0fb4ffa1c585a47 Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 25 Mar 2024 17:00:14 +0100
Subject: [PATCH 076/140] mv tuto_plugins in local
---
plugins/{ => local}/tuto_plugins/H2.xyz | 0
plugins/{ => local}/tuto_plugins/n2.xyz | 0
plugins/{ => local}/tuto_plugins/tuto_I/print_one_e_h.irp.f | 0
plugins/{ => local}/tuto_plugins/tuto_I/print_traces_on_e.irp.f | 0
plugins/{ => local}/tuto_plugins/tuto_I/print_two_e_h.irp.f | 0
plugins/{ => local}/tuto_plugins/tuto_I/traces_one_e.irp.f | 0
plugins/{ => local}/tuto_plugins/tuto_I/tuto_I.rst | 0
7 files changed, 0 insertions(+), 0 deletions(-)
rename plugins/{ => local}/tuto_plugins/H2.xyz (100%)
rename plugins/{ => local}/tuto_plugins/n2.xyz (100%)
rename plugins/{ => local}/tuto_plugins/tuto_I/print_one_e_h.irp.f (100%)
rename plugins/{ => local}/tuto_plugins/tuto_I/print_traces_on_e.irp.f (100%)
rename plugins/{ => local}/tuto_plugins/tuto_I/print_two_e_h.irp.f (100%)
rename plugins/{ => local}/tuto_plugins/tuto_I/traces_one_e.irp.f (100%)
rename plugins/{ => local}/tuto_plugins/tuto_I/tuto_I.rst (100%)
diff --git a/plugins/tuto_plugins/H2.xyz b/plugins/local/tuto_plugins/H2.xyz
similarity index 100%
rename from plugins/tuto_plugins/H2.xyz
rename to plugins/local/tuto_plugins/H2.xyz
diff --git a/plugins/tuto_plugins/n2.xyz b/plugins/local/tuto_plugins/n2.xyz
similarity index 100%
rename from plugins/tuto_plugins/n2.xyz
rename to plugins/local/tuto_plugins/n2.xyz
diff --git a/plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f b/plugins/local/tuto_plugins/tuto_I/print_one_e_h.irp.f
similarity index 100%
rename from plugins/tuto_plugins/tuto_I/print_one_e_h.irp.f
rename to plugins/local/tuto_plugins/tuto_I/print_one_e_h.irp.f
diff --git a/plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f b/plugins/local/tuto_plugins/tuto_I/print_traces_on_e.irp.f
similarity index 100%
rename from plugins/tuto_plugins/tuto_I/print_traces_on_e.irp.f
rename to plugins/local/tuto_plugins/tuto_I/print_traces_on_e.irp.f
diff --git a/plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f b/plugins/local/tuto_plugins/tuto_I/print_two_e_h.irp.f
similarity index 100%
rename from plugins/tuto_plugins/tuto_I/print_two_e_h.irp.f
rename to plugins/local/tuto_plugins/tuto_I/print_two_e_h.irp.f
diff --git a/plugins/tuto_plugins/tuto_I/traces_one_e.irp.f b/plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f
similarity index 100%
rename from plugins/tuto_plugins/tuto_I/traces_one_e.irp.f
rename to plugins/local/tuto_plugins/tuto_I/traces_one_e.irp.f
diff --git a/plugins/tuto_plugins/tuto_I/tuto_I.rst b/plugins/local/tuto_plugins/tuto_I/tuto_I.rst
similarity index 100%
rename from plugins/tuto_plugins/tuto_I/tuto_I.rst
rename to plugins/local/tuto_plugins/tuto_I/tuto_I.rst
From a7a43dafb6cb6f41b41a5b417206c6d090f24186 Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 25 Mar 2024 17:02:28 +0100
Subject: [PATCH 077/140] modified the doc according to the new path of tuto
plugin
---
docs/source/programmers_guide/plugins_tuto_I.rst | 1 +
docs/source/programmers_guide/plugins_tuto_intro.rst | 1 +
2 files changed, 2 insertions(+)
create mode 100644 docs/source/programmers_guide/plugins_tuto_I.rst
create mode 100644 docs/source/programmers_guide/plugins_tuto_intro.rst
diff --git a/docs/source/programmers_guide/plugins_tuto_I.rst b/docs/source/programmers_guide/plugins_tuto_I.rst
new file mode 100644
index 00000000..27864487
--- /dev/null
+++ b/docs/source/programmers_guide/plugins_tuto_I.rst
@@ -0,0 +1 @@
+.. include:: ../../../plugins/local/tuto_plugins/tuto_I/tuto_I.rst
diff --git a/docs/source/programmers_guide/plugins_tuto_intro.rst b/docs/source/programmers_guide/plugins_tuto_intro.rst
new file mode 100644
index 00000000..63482462
--- /dev/null
+++ b/docs/source/programmers_guide/plugins_tuto_intro.rst
@@ -0,0 +1 @@
+.. include:: ../../../plugins/README.rst
From 54d836f029d9f28b5bf1e86c03704d19239d5654 Mon Sep 17 00:00:00 2001
From: ydamour
Date: Tue, 26 Mar 2024 11:31:04 +0100
Subject: [PATCH 078/140] state following
---
.../diagonalization_hs2_dressed.irp.f | 158 +++++++++++++-----
src/davidson/diagonalize_ci.irp.f | 89 +++++++++-
2 files changed, 206 insertions(+), 41 deletions(-)
diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f
index 1ead9d78..3513f215 100644
--- a/src/davidson/diagonalization_hs2_dressed.irp.f
+++ b/src/davidson/diagonalization_hs2_dressed.irp.f
@@ -522,6 +522,84 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
enddo
endif
+ if (state_following) then
+ if (.not. only_expected_s2) then
+ print*,''
+ print*,'!!! State following only available with only_expected_s2 = .True. !!!'
+ STOP
+ endif
+ endif
+
+ if (state_following) then
+
+ integer :: state(N_st), idx
+ double precision :: omax
+ logical :: used
+ logical, allocatable :: ok(:)
+ double precision, allocatable :: overlp(:,:)
+
+ allocate(overlp(shift2,N_st),ok(shift2))
+
+ overlp = 0d0
+ do j = 1, shift2-1, N_st_diag
+
+ ! Computes some states from the guess vectors
+ ! Psi(:,j:j+N_st_diag) = U y(:,j:j+N_st_diag) and put them
+ ! in U(1,shift2+1:shift2+1+N_st_diag) as temporary array
+ call dgemm('N','N', sze, N_st_diag, shift2, &
+ 1.d0, U, size(U,1), y(1,j), size(y,1), 0.d0, U(1,shift2+1), size(U,1))
+
+ ! Overlap
+ do l = 1, N_st
+ do k = 1, N_st_diag
+ do i = 1, sze
+ overlp(k+j-1,l) += U(i,l) * U(i,shift2+k)
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ state = 0
+ do l = 1, N_st
+
+ omax = 0d0
+ idx = 0
+ do k = 1, shift2
+
+ ! Already used ?
+ used = .False.
+ do i = 1, N_st
+ if (state(i) == k) then
+ used = .True.
+ endif
+ enddo
+
+ ! Maximum overlap
+ if (dabs(overlp(k,l)) > omax .and. .not. used .and. state_ok(k)) then
+ omax = dabs(overlp(k,l))
+ idx = k
+ endif
+ enddo
+
+ state(l) = idx
+ enddo
+
+ ! tmp array before setting state_ok
+ ok = .False.
+ do l = 1, N_st
+ ok(state(l)) = .True.
+ enddo
+
+ do k = 1, shift2
+ if (.not. ok(k)) then
+ state_ok(k) = .False.
+ endif
+ enddo
+
+ deallocate(overlp,ok)
+ endif
+
do k=1,shift2
if (.not. state_ok(k)) then
do l=k+1,shift2
@@ -537,46 +615,46 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
endif
enddo
- 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)
- overlap(k,2) = s2(k)
- enddo
- do k=1,N_st
- l = order(k)
- if (k /= l) then
- lambda(k) = overlap(l,1)
- s2(k) = overlap(l,2)
- endif
- enddo
-
- endif
+! 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)
+! overlap(k,2) = s2(k)
+! enddo
+! do k=1,N_st
+! l = order(k)
+! if (k /= l) then
+! lambda(k) = overlap(l,1)
+! s2(k) = overlap(l,2)
+! endif
+! enddo
+!
+! endif
! Express eigenvectors of h in the determinant basis
diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f
index 46ad8f78..8fbac58a 100644
--- a/src/davidson/diagonalize_ci.irp.f
+++ b/src/davidson/diagonalize_ci.irp.f
@@ -123,6 +123,7 @@ END_PROVIDER
endif
enddo
+
if (N_states_diag > N_states_diag_save) then
N_states_diag = N_states_diag_save
TOUCH N_states_diag
@@ -133,24 +134,95 @@ END_PROVIDER
print *, 'Diagonalization of H using Lapack'
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det))
+
if (s2_eig) then
+
double precision, parameter :: alpha = 0.1d0
allocate (H_prime(N_det,N_det) )
+
H_prime(1:N_det,1:N_det) = H_matrix_all_dets(1:N_det,1:N_det) + &
alpha * S2_matrix_all_dets(1:N_det,1:N_det)
+
do j=1,N_det
H_prime(j,j) = H_prime(j,j) - alpha*expected_s2
enddo
+
call lapack_diag(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
call nullify_small_elements(N_det,N_det,eigenvectors,size(eigenvectors,1),1.d-12)
+
CI_electronic_energy(:) = 0.d0
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))
- if (only_expected_s2) then
+
+ if (state_following) then
+ if (.not. only_expected_s2) then
+ print*,''
+ print*,'!!! State following only available with only_expected_s2 = .True. !!!'
+ STOP
+ endif
+ if (N_det < N_states) then
+ print*,''
+ print*,'!!! State following requires at least N_states determinants to be activated !!!'
+ STOP
+ endif
+ endif
+
+ if (state_following .and. only_expected_s2) then
+
+ integer :: state(N_states), idx,l
+ double precision :: overlp(N_det), omax
+ logical :: ok(N_det), used
+
+ i_state = 0
+ state = 0
+ do l = 1, N_states
+
+ ! Overlap wrt each state
+ overlp = 0d0
+ do k = 1, N_det
+ do i = 1, N_det
+ overlp(k) = overlp(k) + psi_coef(i,l) * eigenvectors(i,k)
+ enddo
+ enddo
+
+ ! Idx of the state with the maximum overlap not already "used"
+ omax = 0d0
+ idx = 0
+ do k = 1, N_det
+
+ ! Already used ?
+ used = .False.
+ do i = 1, N_states
+ if (state(i) == k) then
+ used = .True.
+ endif
+ enddo
+
+ ! Maximum overlap
+ if (dabs(overlp(k)) > omax .and. .not. used) then
+ if (dabs(s2_eigvalues(k)-expected_s2) > 0.5d0) cycle
+ omax = dabs(overlp(k))
+ idx = k
+ endif
+ enddo
+
+ state(l) = idx
+ i_state +=1
+ enddo
+
+ do i = 1, i_state
+ index_good_state_array(i) = state(i)
+ good_state_array(i) = .True.
+ enddo
+
+ else if (only_expected_s2) then
+
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
@@ -158,17 +230,23 @@ END_PROVIDER
index_good_state_array(i_state) = j
good_state_array(j) = .True.
endif
+
if(i_state.eq.N_states) then
exit
endif
enddo
+
else
+
do j=1,N_det
index_good_state_array(j) = j
good_state_array(j) = .True.
enddo
+
endif
+
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
@@ -177,6 +255,7 @@ END_PROVIDER
CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
CI_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo
+
i_other_state = 0
do j = 1, N_det
if(good_state_array(j))cycle
@@ -201,6 +280,7 @@ END_PROVIDER
print*,' as the CI_eigenvectors'
print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
print*,''
+
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
@@ -209,14 +289,18 @@ END_PROVIDER
CI_s2(j) = s2_eigvalues(j)
enddo
endif
+
deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
+
else
+
call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy(:) = 0.d0
call u_0_S2_u_0(CI_s2,eigenvectors,N_det,psi_det,N_int, &
min(N_det,N_states_diag),size(eigenvectors,1))
+
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
do i=1,N_det
@@ -224,7 +308,9 @@ END_PROVIDER
enddo
CI_electronic_energy(j) = eigenvalues(j)
enddo
+
endif
+
do k=1,N_states_diag
CI_electronic_energy(k) = 0.d0
do j=1,N_det
@@ -235,6 +321,7 @@ END_PROVIDER
enddo
enddo
enddo
+
deallocate(eigenvectors,eigenvalues)
endif
From 57657cb1636cace7d49026c15bca8cb299598907 Mon Sep 17 00:00:00 2001
From: ydamour
Date: Tue, 26 Mar 2024 15:22:20 +0100
Subject: [PATCH 079/140] bugfix large N_det
---
src/davidson/diagonalize_ci.irp.f | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f
index 8fbac58a..59c8313a 100644
--- a/src/davidson/diagonalize_ci.irp.f
+++ b/src/davidson/diagonalize_ci.irp.f
@@ -176,8 +176,12 @@ END_PROVIDER
if (state_following .and. only_expected_s2) then
integer :: state(N_states), idx,l
- double precision :: overlp(N_det), omax
- logical :: ok(N_det), used
+ double precision :: omax
+ double precision, allocatable :: overlp(:)
+ logical :: used
+ logical, allocatable :: ok(:)
+
+ allocate(overlp(N_det), ok(N_det))
i_state = 0
state = 0
@@ -216,6 +220,8 @@ END_PROVIDER
i_state +=1
enddo
+ deallocate(overlp, ok)
+
do i = 1, i_state
index_good_state_array(i) = state(i)
good_state_array(i) = .True.
From f07db955f8c4c8151921e13686bd34cd37a8a24a Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 26 Mar 2024 16:15:20 +0100
Subject: [PATCH 080/140] Fix qp_set_frozen_core
---
bin/qp_set_frozen_core | 1 +
1 file changed, 1 insertion(+)
diff --git a/bin/qp_set_frozen_core b/bin/qp_set_frozen_core
index f9761144..d2821bd9 100755
--- a/bin/qp_set_frozen_core
+++ b/bin/qp_set_frozen_core
@@ -83,6 +83,7 @@ def main(arguments):
elif charge <= 118: n_frozen += 43
elif arguments["--small"]:
+ for charge in ezfio.nuclei_nucl_charge:
if charge <= 4: pass
elif charge <= 18: n_frozen += 1
elif charge <= 36: n_frozen += 5
From 868988b44604ac494341e28285e78126cf9a27cc Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 27 Mar 2024 14:18:23 +0100
Subject: [PATCH 081/140] Restored PT2 print
---
src/cipsi_utils/pt2_stoch_routines.irp.f | 52 +++++++++++++++++++-----
1 file changed, 42 insertions(+), 10 deletions(-)
diff --git a/src/cipsi_utils/pt2_stoch_routines.irp.f b/src/cipsi_utils/pt2_stoch_routines.irp.f
index c33dcfe7..100335f6 100644
--- a/src/cipsi_utils/pt2_stoch_routines.irp.f
+++ b/src/cipsi_utils/pt2_stoch_routines.irp.f
@@ -543,27 +543,59 @@ 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 = sqrt(eqt / (dble(c) - 1.5d0))
+ eqt = dsqrt(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 = sqrt(eqt / (dble(c) - 1.5d0))
+ eqt = dsqrt(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(:) = sqrt(eqta(:) / (dble(c) - 1.5d0))
+ eqta(:) = dsqrt(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
- 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), &
+
+ 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
if (stop_now .or. ( &
(do_exit .and. (dabs(pt2_data_err % pt2(pt2_stoch_istate)) / &
From 7a3379a43ec7924d7836fe7750b818a4e5a67634 Mon Sep 17 00:00:00 2001
From: ydamour
Date: Wed, 27 Mar 2024 16:56:05 +0100
Subject: [PATCH 082/140] bugfix davidson recontraction + update
---
.../diagonalization_hs2_dressed.irp.f | 22 ++++++++++++++-----
1 file changed, 17 insertions(+), 5 deletions(-)
diff --git a/src/davidson/diagonalization_hs2_dressed.irp.f b/src/davidson/diagonalization_hs2_dressed.irp.f
index 3513f215..fd967ecc 100644
--- a/src/davidson/diagonalization_hs2_dressed.irp.f
+++ b/src/davidson/diagonalization_hs2_dressed.irp.f
@@ -139,7 +139,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
integer :: iter2, itertot
double precision, allocatable :: y(:,:), h(:,:), h_p(:,:), lambda(:), s2(:)
real, allocatable :: y_s(:,:)
- double precision, allocatable :: s_(:,:), s_tmp(:,:)
+ double precision, allocatable :: s_(:,:), s_tmp(:,:), prev_y(:,:)
double precision :: diag_h_mat_elem
double precision, allocatable :: residual_norm(:)
character*(16384) :: write_buffer
@@ -288,6 +288,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
h(N_st_diag*itermax,N_st_diag*itermax), &
! h_p(N_st_diag*itermax,N_st_diag*itermax), &
y(N_st_diag*itermax,N_st_diag*itermax), &
+ prev_y(N_st_diag*itermax,N_st_diag*itermax), &
s_(N_st_diag*itermax,N_st_diag*itermax), &
s_tmp(N_st_diag*itermax,N_st_diag*itermax), &
residual_norm(N_st_diag), &
@@ -301,6 +302,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
s_ = 0.d0
s_tmp = 0.d0
+ prev_y = 0.d0
+ do i = 1, N_st_diag*itermax
+ prev_y(i,i) = 1d0
+ enddo
ASSERT (N_st > 0)
ASSERT (N_st_diag >= N_st)
@@ -479,6 +484,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
if (info > 0) then
! Numerical errors propagate. We need to reduce the number of iterations
itermax = iter-1
+
+ ! eigenvectors of the previous iteration
+ y = prev_y
+ shift2 = shift2 - N_st_diag
exit
endif
@@ -553,7 +562,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
do l = 1, N_st
do k = 1, N_st_diag
do i = 1, sze
- overlp(k+j-1,l) += U(i,l) * U(i,shift2+k)
+ overlp(k+j-1,l) += u_in(i,l) * U(i,shift2+k)
enddo
enddo
enddo
@@ -576,7 +585,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
enddo
! Maximum overlap
- if (dabs(overlp(k,l)) > omax .and. .not. used .and. state_ok(k)) then
+ if ((dabs(overlp(k,l)) > omax) .and. (.not. used) .and. state_ok(k)) then
omax = dabs(overlp(k,l))
idx = k
endif
@@ -615,6 +624,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
endif
enddo
+ ! Swapped eigenvectors
+ prev_y = y
+
! if (state_following) then
!
! overlap = -1.d0
@@ -677,7 +689,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,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)
+ /max(dabs(H_jj(i) - lambda (k)),1.d-2) * dsign(1d0,H_jj(i) - lambda (k))
enddo
if (k <= N_st) then
@@ -792,7 +804,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_
residual_norm, &
U, overlap, &
h, y_s, S_d, &
- y, s_, s_tmp, &
+ y, s_, s_tmp, prev_y, &
lambda &
)
FREE nthreads_davidson
From 4e692558a653bd1ccc36a2e19551dea8201e2ab3 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 2 Apr 2024 17:41:19 +0200
Subject: [PATCH 083/140] Changed total memory to resident memory in check
---
src/utils/memory.irp.f | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f
index ab85c21b..e69bf71e 100644
--- a/src/utils/memory.irp.f
+++ b/src/utils/memory.irp.f
@@ -107,7 +107,7 @@ subroutine check_mem(rss_in,routine)
double precision, intent(in) :: rss_in
character*(*) :: routine
double precision :: mem
- call total_memory(mem)
+ call resident_memory(mem)
mem += rss_in
if (mem > qp_max_mem) then
call print_memory_usage()
From d93b529b36ed27b611bcfb7196b7b51727d8be18 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 3 Apr 2024 11:49:55 +0200
Subject: [PATCH 084/140] Improve (T)
---
src/ccsd/ccsd_t_space_orb_stoch.irp.f | 32 ++++++++++++++++-----------
1 file changed, 19 insertions(+), 13 deletions(-)
diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
index 13fa4f1a..293baa2d 100644
--- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f
+++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
@@ -181,8 +181,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
integer :: nbuckets
nbuckets = 100
+ double precision, allocatable :: ED(:)
double precision, allocatable :: wsum(:)
- allocate(wsum(nbuckets))
converged = .False.
Ncomputed = 0_8
@@ -197,7 +197,8 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
iright = Nabc
integer*8, allocatable :: bounds(:,:)
- allocate (bounds(2,nbuckets))
+ allocate(wsum(nbuckets), ED(nbuckets), bounds(2,nbuckets))
+ ED(:) = 0.d0
do isample=1,nbuckets
eta = 1.d0/dble(nbuckets) * dble(isample)
ieta = binary_search(waccu,eta,Nabc)
@@ -233,7 +234,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
! Deterministic part
- if (imin < Nabc) then
+ if (imin <= Nabc) then
ieta=imin
sampled(ieta) = 0_8
a = abc(1,ieta)
@@ -254,7 +255,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
! Stochastic part
call random_number(eta)
do isample=1,nbuckets
- if (imin >= bounds(2,isample)) then
+ if (imin > bounds(2,isample)) then
cycle
endif
ieta = binary_search(waccu,(eta + dble(isample-1))/dble(nbuckets),Nabc)+1
@@ -280,7 +281,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
call wall_time(t01)
- if ((t01-t00 > 1.0d0).or.(imin >= Nabc)) then
+ if ((t01-t00 > 1.0d0).or.(imin > Nabc)) then
!$OMP TASKWAIT
call wall_time(t01)
@@ -300,8 +301,11 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do isample=1,nbuckets
- if (imin >= bounds(2,isample)) then
- energy_det = energy_det + sum(memo(bounds(1,isample):bounds(2,isample)))
+ if (imin > bounds(2,isample)) then
+ if (ED(isample) == 0.d0) then
+ ED(isample) = sum(memo(bounds(1,isample):bounds(2,isample)))
+ endif
+ energy_det = energy_det + ED(isample)
scale = scale - wsum(isample)
else
exit
@@ -310,12 +314,14 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
isample = min(isample,nbuckets)
do ieta=bounds(1,isample), Nabc
- w = dble(max(sampled(ieta),0_8))
- tmp = w * memo(ieta) * Pabc(ieta)
- ET = ET + tmp
- ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta)
- norm = norm + w
+ if (sampled(ieta) < 0_8) cycle
+ w = dble(sampled(ieta))
+ tmp = w * memo(ieta) * Pabc(ieta)
+ ET = ET + tmp
+ ET2 = ET2 + tmp * memo(ieta) * Pabc(ieta)
+ norm = norm + w
enddo
+
norm = norm/scale
if (norm > 0.d0) then
energy_stoch = ET / norm
@@ -327,7 +333,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
print '('' '',F20.8, '' '', ES12.4,'' '', F8.2,'' '')', eccsd+energy, dsqrt(variance/(norm-1.d0)), 100.*real(Ncomputed)/real(Nabc)
endif
!$OMP END MASTER
- if (imin >= Nabc) exit
+ if (imin > Nabc) exit
enddo
!$OMP END PARALLEL
From e4ce9ef2193529ff1887d7ec62abb2233869f50f Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 3 Apr 2024 15:32:56 +0200
Subject: [PATCH 085/140] Upgrade trexio version in configure
---
configure | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/configure b/configure
index e211cfd7..41c0123d 100755
--- a/configure
+++ b/configure
@@ -9,7 +9,7 @@ echo "QP_ROOT="$QP_ROOT
unset CC
unset CCXX
-TREXIO_VERSION=2.3.2
+TREXIO_VERSION=2.4.2
# Force GCC instead of ICC for dependencies
export CC=gcc
@@ -219,7 +219,7 @@ EOF
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} --without-hdf5 CFLAGS='-g'
- make -j 8 && make -j 8 check && make -j 8 install
+ (make -j 8 || make) && make check && make -j 8 install
tar -zxvf "\${QP_ROOT}"/external/qp2-dependencies/${ARCHITECTURE}/ninja.tar.gz
mv ninja "\${QP_ROOT}"/bin/
EOF
@@ -233,7 +233,7 @@ EOF
tar -zxf trexio-${VERSION}.tar.gz && rm trexio-${VERSION}.tar.gz
cd trexio-${VERSION}
./configure --prefix=\${QP_ROOT} CFLAGS="-g"
- make -j 8 && make -j 8 check && make -j 8 install
+ (make -j 8 || make) && make check && make -j 8 install
EOF
elif [[ ${PACKAGE} = qmckl ]] ; then
@@ -245,7 +245,7 @@ EOF
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc CFLAGS='-g'
- make && make -j 4 check && make install
+ (make -j 8 || make) && make check && make install
EOF
elif [[ ${PACKAGE} = qmckl-intel ]] ; then
@@ -257,7 +257,7 @@ EOF
tar -zxf qmckl-${VERSION}.tar.gz && rm qmckl-${VERSION}.tar.gz
cd qmckl-${VERSION}
./configure --prefix=\${QP_ROOT} --enable-hpc --disable-doc --with-icc --with-ifort CFLAGS='-g'
- make && make -j 4 check && make install
+ (make -j 8 || make) && make check && make install
EOF
From b22c835ec8d415c7cecfa76ab98ea6ed9f4903f2 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 3 Apr 2024 16:59:15 +0200
Subject: [PATCH 086/140] Add nthreads_pt2 to (T)
---
src/ccsd/ccsd_t_space_orb_stoch.irp.f | 4 +++-
src/{cipsi_utils => ezfio_files}/environment.irp.f | 0
2 files changed, 3 insertions(+), 1 deletion(-)
rename src/{cipsi_utils => ezfio_files}/environment.irp.f (100%)
diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
index 293baa2d..618d50e4 100644
--- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f
+++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
@@ -110,6 +110,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
double precision :: eocc
double precision :: norm
integer :: isample
+ PROVIDE nthreads_pt2
! Prepare table of triplets (a,b,c)
@@ -216,11 +217,12 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
print '(A)', ' ======================= ============== =========='
+ call set_multiple_levels_omp(.False.)
call wall_time(t00)
imin = 1_8
!$OMP PARALLEL &
!$OMP PRIVATE(ieta,eta,a,b,c,kiter,isample) &
- !$OMP DEFAULT(SHARED)
+ !$OMP DEFAULT(SHARED) NUM_THREADS(nthreads_pt2)
do kiter=1,Nabc
diff --git a/src/cipsi_utils/environment.irp.f b/src/ezfio_files/environment.irp.f
similarity index 100%
rename from src/cipsi_utils/environment.irp.f
rename to src/ezfio_files/environment.irp.f
From 0c8845f5f208e1c405a6aa5aba1ceb276ddbdcdf Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 4 Apr 2024 15:06:30 +0200
Subject: [PATCH 087/140] Fix qp_convert
---
bin/qp_convert_output_to_ezfio | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio
index 1b33f156..6f2d02d0 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -227,8 +227,8 @@ def write_ezfio(res, filename):
shell_index += [nshell_tot] * len(b.prim)
shell_num = len(ang_mom)
- assert(shell_index[0] = 1)
- assert(shell_index[-1] = shell_num)
+ assert(shell_index[0] == 1)
+ assert(shell_index[-1] == shell_num)
# ~#~#~#~#~ #
# W r i t e #
From 43648cddb04771bf269e791d76cec68b742f27f1 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 5 Apr 2024 14:24:42 +0200
Subject: [PATCH 088/140] Fixed qp_plugins update
---
bin/qp_plugins | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/bin/qp_plugins b/bin/qp_plugins
index e53b08e9..b1fbeec0 100755
--- a/bin/qp_plugins
+++ b/bin/qp_plugins
@@ -97,7 +97,7 @@ end
def get_repositories():
l_result = [f for f in os.listdir(QP_PLUGINS) \
- if f not in [".gitignore", "local"] ]
+ if f not in [".gitignore", "local", "README.rst"] ]
return sorted(l_result)
From 6848470850c946da9a3b1b8af0d6037fd9d5de92 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 5 Apr 2024 14:25:32 +0200
Subject: [PATCH 089/140] Fix underflow in EZFIO
---
src/mo_basis/utils.irp.f | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/src/mo_basis/utils.irp.f b/src/mo_basis/utils.irp.f
index 5f664c41..987c394a 100644
--- a/src/mo_basis/utils.irp.f
+++ b/src/mo_basis/utils.irp.f
@@ -228,7 +228,11 @@ subroutine mo_as_svd_vectors_of_mo_matrix_eig(matrix,lda,m,n,eig,label)
call dgemm('N','N',ao_num,m,m,1.d0,mo_coef_new,size(mo_coef_new,1),U,size(U,1),0.d0,mo_coef,size(mo_coef,1))
do i=1,m
- eig(i) = D(i)
+ if (eig(i) > 1.d-20) then
+ eig(i) = D(i)
+ else
+ eig(i) = 0.d0
+ endif
enddo
deallocate(A,mo_coef_new,U,Vt,D)
From 8e0a9be9ad3a5e21b5b3c05c7e78e4a4fff8960e Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 5 Apr 2024 14:25:45 +0200
Subject: [PATCH 090/140] Add metadata to TREXIO
---
src/trexio/export_trexio_routines.irp.f | 54 ++++++++++++++++++++++++-
1 file changed, 53 insertions(+), 1 deletion(-)
diff --git a/src/trexio/export_trexio_routines.irp.f b/src/trexio/export_trexio_routines.irp.f
index 034b142e..63630243 100644
--- a/src/trexio/export_trexio_routines.irp.f
+++ b/src/trexio/export_trexio_routines.irp.f
@@ -59,7 +59,59 @@ subroutine export_trexio(update,full_path)
enddo
call ezfio_set_trexio_trexio_file(trexio_filename)
-
+
+
+! ------------------------------------------------------------------------------
+
+! Metadata
+! --------
+
+ integer :: code_num, author_num
+ character*(64) :: code(100), author(100), user
+ character*(64), parameter :: qp2_code = "QuantumPackage"
+
+ call getenv("USER",user)
+ do k=1,N_states
+ rc = trexio_read_metadata_code_num(f(k), code_num)
+ if (rc == TREXIO_ATTR_MISSING) then
+ i = 1
+ code(:) = ""
+ else
+ rc = trexio_read_metadata_code(f(k), code, 64)
+ do i=1, code_num
+ if (trim(code(i)) == trim(qp2_code)) then
+ exit
+ endif
+ enddo
+ endif
+ if (i == code_num+1) then
+ code(i) = qp2_code
+ rc = trexio_write_metadata_code_num(f(k), i)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ rc = trexio_write_metadata_code(f(k), code, 64)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ endif
+
+ rc = trexio_read_metadata_author_num(f(k), author_num)
+ if (rc == TREXIO_ATTR_MISSING) then
+ i = 1
+ author(:) = ""
+ else
+ rc = trexio_read_metadata_author(f(k), author, 64)
+ do i=1, author_num
+ if (trim(author(i)) == trim(user)) then
+ exit
+ endif
+ enddo
+ endif
+ if (i == author_num+1) then
+ author(i) = user
+ rc = trexio_write_metadata_author_num(f(k), i)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ rc = trexio_write_metadata_author(f(k), author, 64)
+ call trexio_assert(rc, TREXIO_SUCCESS)
+ endif
+ enddo
! ------------------------------------------------------------------------------
From 88cffcb26999f685b9c7ef78d61bb71961cf3d9d Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Fri, 5 Apr 2024 17:51:48 +0200
Subject: [PATCH 091/140] Force MOs to be on axes. Nice for atoms
---
src/ao_one_e_ints/ao_ortho_canonical.irp.f | 2 ++
src/scf_utils/diagonalize_fock.irp.f | 2 +-
src/scf_utils/roothaan_hall_scf.irp.f | 26 +++++++++++++++++++---
3 files changed, 26 insertions(+), 4 deletions(-)
diff --git a/src/ao_one_e_ints/ao_ortho_canonical.irp.f b/src/ao_one_e_ints/ao_ortho_canonical.irp.f
index 668b920d..eff7e7be 100644
--- a/src/ao_one_e_ints/ao_ortho_canonical.irp.f
+++ b/src/ao_one_e_ints/ao_ortho_canonical.irp.f
@@ -138,6 +138,8 @@ END_PROVIDER
deallocate(S)
endif
+ FREE ao_overlap
+
END_PROVIDER
BEGIN_PROVIDER [double precision, ao_ortho_canonical_overlap, (ao_ortho_canonical_num,ao_ortho_canonical_num)]
diff --git a/src/scf_utils/diagonalize_fock.irp.f b/src/scf_utils/diagonalize_fock.irp.f
index 5188581a..b9042b29 100644
--- a/src/scf_utils/diagonalize_fock.irp.f
+++ b/src/scf_utils/diagonalize_fock.irp.f
@@ -47,7 +47,7 @@ BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num,mo_num)
do j = 1, n_core_orb
jorb = list_core(j)
F(iorb,jorb) = 0.d0
- F(jorb,iorb) = 0.d0
+ F(jorb,iorb) = 0.d0
enddo
enddo
endif
diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f
index 730cb496..3f5c8549 100644
--- a/src/scf_utils/roothaan_hall_scf.irp.f
+++ b/src/scf_utils/roothaan_hall_scf.irp.f
@@ -13,9 +13,9 @@ END_DOC
integer :: iteration_SCF,dim_DIIS,index_dim_DIIS
logical :: converged
- integer :: i,j
+ integer :: i,j,m
logical, external :: qp_stop
- double precision, allocatable :: mo_coef_save(:,:)
+ double precision, allocatable :: mo_coef_save(:,:), S(:,:)
PROVIDE ao_md5 mo_occ level_shift
@@ -208,9 +208,29 @@ END_DOC
size(Fock_matrix_mo,2),mo_label,1,.true.)
call restore_symmetry(ao_num, mo_num, mo_coef, size(mo_coef,1), 1.d-10)
call orthonormalize_mos
- call save_mos
endif
+
+ ! Identify degenerate MOs and force them on the axes
+ allocate(S(ao_num,ao_num))
+ i=1
+ do while (i1) then
+ call dgemm('N','T',ao_num,ao_num,m,1.d0,mo_coef(1,i),size(mo_coef,1),mo_coef(1,i),size(mo_coef,1),0.d0,S,size(S,1))
+ call pivoted_cholesky( S, m, -1.d0, ao_num, mo_coef(1,i))
+ endif
+ i = j+1
+ enddo
+
+
+ call save_mos
+
call write_double(6, Energy_SCF, 'SCF energy')
call write_time(6)
From d872d60e70f8eedb3913f5566d4f35d198d4aad5 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 7 Apr 2024 00:29:40 +0200
Subject: [PATCH 092/140] saving olympe2 modif
---
plugins/local/bi_ortho_mos/overlap.irp.f | 8 +-
.../lapack_diag_non_hermit.irp.f | 1 +
plugins/local/tc_scf/minimize_tc_angles.irp.f | 2 +-
plugins/local/tc_scf/routines_rotates.irp.f | 79 ++++++++++---------
src/tools/print_detweights.irp.f | 35 +++++++-
src/utils/block_diag_degen.irp.f | 2 +-
6 files changed, 81 insertions(+), 46 deletions(-)
diff --git a/plugins/local/bi_ortho_mos/overlap.irp.f b/plugins/local/bi_ortho_mos/overlap.irp.f
index ff5d5c84..7f07929f 100644
--- a/plugins/local/bi_ortho_mos/overlap.irp.f
+++ b/plugins/local/bi_ortho_mos/overlap.irp.f
@@ -56,10 +56,10 @@
print*,'Average trace of overlap_bi_ortho is different from 1 by ', dabs(accu_d-1.d0)
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
+ !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
diff --git a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
index cb38347e..4d4bc047 100644
--- a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
+++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
@@ -2144,6 +2144,7 @@ subroutine impose_biorthog_degen_eigvec(n, deg_num, e0, L0, R0)
enddo
!print*,' accu_nd after = ', accu_nd
if(accu_nd .gt. 1d-12) then
+ print*, ' accu_nd =', accu_nd
print*, ' your strategy for degenerates orbitals failed !'
print*, m, 'deg on', i
stop
diff --git a/plugins/local/tc_scf/minimize_tc_angles.irp.f b/plugins/local/tc_scf/minimize_tc_angles.irp.f
index c7752930..e5f6cf87 100644
--- a/plugins/local/tc_scf/minimize_tc_angles.irp.f
+++ b/plugins/local/tc_scf/minimize_tc_angles.irp.f
@@ -20,7 +20,7 @@ program minimize_tc_angles
! TODO
! check if rotations of orbitals affect the TC energy
! and refuse the step
- call minimize_tc_orb_angles
+ call minimize_tc_orb_angles()
end
diff --git a/plugins/local/tc_scf/routines_rotates.irp.f b/plugins/local/tc_scf/routines_rotates.irp.f
index c42e846e..2c5510f2 100644
--- a/plugins/local/tc_scf/routines_rotates.irp.f
+++ b/plugins/local/tc_scf/routines_rotates.irp.f
@@ -40,9 +40,6 @@ subroutine LTxSxR(n, m, L, S, R, C)
end subroutine LTxR
-! ---
-
-
! ---
subroutine minimize_tc_orb_angles()
@@ -103,7 +100,10 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
double precision, allocatable :: stmp(:,:), T(:,:), Snew(:,:), smat2(:,:)
double precision, allocatable :: mo_l_coef_tmp(:,:), mo_r_coef_tmp(:,:), mo_l_coef_new(:,:)
- E_thr = 1d-04
+ PROVIDE TC_HF_energy
+ PROVIDE mo_r_coef mo_l_coef
+
+ E_thr = 1d-07
E_old = TC_HF_energy
allocate(mo_l_coef_old(ao_num,mo_num), mo_r_coef_old(ao_num,mo_num))
mo_r_coef_old = mo_r_coef
@@ -111,7 +111,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
good_angles = .False.
- allocate(mo_l_coef_good(ao_num, mo_num), mo_r_coef_good(ao_num,mo_num))
+ allocate(mo_l_coef_good(ao_num,mo_num), mo_r_coef_good(ao_num,mo_num))
print *, ' ***************************************'
print *, ' ***************************************'
@@ -123,7 +123,7 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
mo_r_coef_good = mo_r_coef
mo_l_coef_good = mo_l_coef
- allocate(mo_r_coef_new(ao_num, mo_num))
+ allocate(mo_r_coef_new(ao_num,mo_num))
mo_r_coef_new = mo_r_coef
do i = 1, mo_num
norm = 1.d0/dsqrt(overlap_mo_r(i,i))
@@ -141,10 +141,11 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
call build_s_matrix(ao_num, mo_num, mo_r_coef_new, mo_r_coef_new, ao_overlap, s_mat)
! call give_degen(fock_diag,mo_num,thr_deg,list_degen,n_degen_list)
if(n_core_orb.ne.0)then
- call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list)
+ call give_degen_full_listcore(fock_diag, mo_num, list_core, n_core_orb, thr_deg, list_degen, n_degen_list)
else
- call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list)
+ call give_degen_full_list(fock_diag, mo_num, thr_deg, list_degen, n_degen_list)
endif
+
print *, ' fock_matrix_mo'
do i = 1, mo_num
print *, i, fock_diag(i), angle_left_right(i)
@@ -156,50 +157,52 @@ subroutine routine_save_rotated_mos(thr_deg, good_angles)
! n_degen = ilast - ifirst +1
n_degen = list_degen(i,0)
- if(n_degen .ge. 1000)n_degen = 1 ! convention for core orbitals
+ if(n_degen .ge. 1000) n_degen = 1 ! convention for core orbitals
if(n_degen .eq. 1) cycle
+ print*, ' working on orbital', i
+ print*, ' multiplicity =', n_degen
allocate(stmp(n_degen,n_degen), smat2(n_degen,n_degen))
allocate(mo_r_coef_tmp(ao_num,n_degen), mo_l_coef_tmp(ao_num,n_degen), mo_l_coef_new(ao_num,n_degen))
allocate(T(n_degen,n_degen), Snew(n_degen,n_degen))
print*,'Right orbitals before'
- do j = 1, n_degen
- write(*,'(100(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_r_coef_new(1:ao_num,list_degen(i,j))
+ enddo
print*,'Left orbitals before'
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_l_coef(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
if(angle_left_right(list_degen(i,1)).gt.80.d0.and.n_degen==2)then
- integer :: i_list, j_list
- i_list = list_degen(i,1)
- j_list = list_degen(i,2)
- print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2))
- print*,'i_list = ',i_list
- print*,'i_list = ',j_list
- print*,'Swapping left/right orbitals'
- call print_strong_overlap(i_list, j_list)
- mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list)
- mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list)
- mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list)
- mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list)
+ integer :: i_list, j_list
+ i_list = list_degen(i,1)
+ j_list = list_degen(i,2)
+ print*,'Huge angle !!! == ',angle_left_right(list_degen(i,1)),angle_left_right(list_degen(i,2))
+ print*,'i_list = ',i_list
+ print*,'i_list = ',j_list
+ print*,'Swapping left/right orbitals'
+ call print_strong_overlap(i_list, j_list)
+ mo_r_coef_tmp(1:ao_num,1) = mo_r_coef_new(1:ao_num,i_list)
+ mo_r_coef_tmp(1:ao_num,2) = mo_l_coef(1:ao_num,i_list)
+ mo_l_coef_tmp(1:ao_num,1) = mo_l_coef(1:ao_num,j_list)
+ mo_l_coef_tmp(1:ao_num,2) = mo_r_coef_new(1:ao_num,j_list)
else
- do j = 1, n_degen
- print*,'i_list = ',list_degen(i,j)
- mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
- mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
- enddo
+ do j = 1, n_degen
+ print*,'i_list = ',list_degen(i,j)
+ mo_r_coef_tmp(1:ao_num,j) = mo_r_coef_new(1:ao_num,list_degen(i,j))
+ mo_l_coef_tmp(1:ao_num,j) = mo_l_coef(1:ao_num,list_degen(i,j))
+ enddo
endif
print*,'Right orbitals '
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_r_coef_tmp(1:ao_num,j)
- enddo
+ do j = 1, n_degen
+ write(*,'(1000(F16.10,X))') mo_r_coef_tmp(1:ao_num,j)
+ enddo
print*,'Left orbitals '
- do j = 1, n_degen
- write(*,'(100(F16.10,X))')mo_l_coef_tmp(1:ao_num,j)
- enddo
+ do j = 1, n_degen
+ write(*,'(100(F16.10,X))') mo_l_coef_tmp(1:ao_num,j)
+ enddo
! Orthogonalization of right functions
print *, ' Orthogonalization of RIGHT functions'
print *, ' ------------------------------------'
diff --git a/src/tools/print_detweights.irp.f b/src/tools/print_detweights.irp.f
index d5b0f2c9..5e5f2bb1 100644
--- a/src/tools/print_detweights.irp.f
+++ b/src/tools/print_detweights.irp.f
@@ -5,7 +5,8 @@ program print_detweights
read_wf = .True.
touch read_wf
- call main()
+ call print_exc()
+ !call main()
end
@@ -41,6 +42,7 @@ subroutine main()
do i = 1, N_det
deg_sorted(i) = deg(ii(i))
+ print *, deg_sorted(i), c(i)
enddo
print *, ' saving psi'
@@ -52,7 +54,7 @@ subroutine main()
print *, ' Error opening file!'
stop
endif
-
+
write(10) N_det
write(10) deg_sorted
write(10) c
@@ -63,4 +65,33 @@ subroutine main()
end
+! ---
+
+subroutine print_exc()
+
+ implicit none
+
+ integer :: i
+ integer, allocatable :: deg(:)
+
+ PROVIDE N_int
+ PROVIDE N_det
+ PROVIDE psi_det
+
+ allocate(deg(N_det))
+
+ do i = 1, N_det
+ call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i), deg(i), N_int)
+ enddo
+
+ open(unit=10, file="exc.dat", action="write")
+ write(10,*) N_det
+ write(10,*) deg
+ close(10)
+
+ deallocate(deg)
+
+end
+
+
diff --git a/src/utils/block_diag_degen.irp.f b/src/utils/block_diag_degen.irp.f
index 188bfa58..1a9ca8d6 100644
--- a/src/utils/block_diag_degen.irp.f
+++ b/src/utils/block_diag_degen.irp.f
@@ -191,7 +191,7 @@ subroutine give_degen_full_list(A, n, thr, list_degen, n_degen_list)
list_degen(n_degen_list,1) = i
icount = 1
do j = i+1, n
- if(dabs(A(i)-A(j)).lt.thr.and.is_ok(j)) then
+ if(dabs(A(i)-A(j)).lt.thr .and. is_ok(j)) then
is_ok(j) = .False.
icount += 1
list_degen(n_degen_list,icount) = j
From f8bff471222ac9cd2e6f23342f7d7a7aff5d62cd Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 28 Mar 2024 15:27:11 +0100
Subject: [PATCH 093/140] added loops
---
.../local/non_h_ints_mu/total_tc_int.irp.f | 165 +++++++++++++-----
1 file changed, 121 insertions(+), 44 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index c7230dc3..72fd0f53 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -65,27 +65,59 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_square_ao
- allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ if(tc_save_mem) then
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, k, ipoint) &
- !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
- !$OMP DO SCHEDULE (static)
- do i = 1, ao_num
- do k = 1, ao_num
- do ipoint = 1, n_points_final_grid
- c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+ print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
+ !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
+ !$OMP aos_in_r_array_transp, final_weight_at_r_vector, int2_grad1_u12_square_ao)
+ !$OMP DO COLLAPSE(4)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ do j = 1, ao_num
+ ao_two_e_tc_tot(j,l,k,i) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ weight1 = final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+ ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) + int2_grad1_u12_square_ao(j,l,ipoint) * weight1 * ao_i_r * ao_k_r
+ enddo
+ enddo
+ enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
- call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
- , 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ else
+ print*, ' DGEMM are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
+
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, k, ipoint) &
+ !$OMP SHARED (aos_in_r_array_transp, c_mat, ao_num, n_points_final_grid, final_weight_at_r_vector)
+ !$OMP DO SCHEDULE (static)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ c_mat(ipoint,k,i) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,k)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , int2_grad1_u12_square_ao(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
+ , 0.d0, ao_two_e_tc_tot, ao_num*ao_num)
+ deallocate(c_mat)
+ endif
+
FREE int2_grad1_u12_square_ao
if( (tc_integ_type .eq. "semi-analytic") .and. &
@@ -96,6 +128,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
! an additional term is added here directly instead of
! being added in int2_grad1_u12_square_ao for performance
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
PROVIDE int2_u2_env2
!$OMP PARALLEL &
@@ -127,10 +160,13 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
, int2_u2_env2(1,1,1), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
+ deallocate(c_mat)
FREE int2_u2_env2
endif ! use_ipp
- deallocate(c_mat)
+ call wall_time(time1)
+ print*, ' done with Hermitian part after (min) ', (time1 - time0) / 60.d0
+ call print_memory_usage()
! ---
@@ -138,38 +174,73 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_ao
- allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
+ if(tc_save_mem) then
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
- !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
- !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
- !$OMP DO SCHEDULE (static)
- do i = 1, ao_num
- do k = 1, ao_num
- do ipoint = 1, n_points_final_grid
+ print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
- weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
- ao_i_r = aos_in_r_array_transp(ipoint,i)
- ao_k_r = aos_in_r_array_transp(ipoint,k)
-
- b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
- b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
- b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, j, k, l, ipoint, ao_i_r, ao_k_r, weight1) &
+ !$OMP SHARED (ao_num, n_points_final_grid, ao_two_e_tc_tot, &
+ !$OMP aos_in_r_array_transp, final_weight_at_r_vector, &
+ !$OMP int2_grad1_u12_ao, aos_grad_in_r_array_transp_bis)
+ !$OMP DO COLLAPSE(4)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ do j = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+ weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+ ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) &
+ + weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) &
+ + weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) &
+ + weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ enddo
+ enddo
+ enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
- do m = 1, 3
- call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
- , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
- , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
- enddo
- deallocate(b_mat)
+ else
+ print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
+
+ allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
+ !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
+ !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
+ !$OMP DO SCHEDULE (static)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do ipoint = 1, n_points_final_grid
+
+ weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
+
+ b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
+ b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
+ b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ do m = 1, 3
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
+ , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
+ , 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
+ enddo
+ deallocate(b_mat)
+
+ end if
FREE int2_grad1_u12_ao
if(tc_integ_type .eq. "semi-analytic") then
@@ -178,16 +249,22 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
endif ! var_tc
+ call wall_time(time1)
+ print*, ' done with non-Hermitian part after (min) ', (time1 - time0) / 60.d0
+ call print_memory_usage()
+
! ---
call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
+ ! ---
+
PROVIDE ao_integrals_map
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
!$OMP PRIVATE(i, j, k, l)
- !$OMP DO
+ !$OMP DO COLLAPSE(4)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
From 002aff90f5e6ecd7a4929eb48e75608d94f9e3a8 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Thu, 28 Mar 2024 17:05:00 +0100
Subject: [PATCH 094/140] working on mem reduction
---
.../local/non_h_ints_mu/total_tc_int.irp.f | 98 ++++++++++++-------
plugins/local/tc_keywords/EZFIO.cfg | 6 ++
2 files changed, 67 insertions(+), 37 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index 72fd0f53..b8379006 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -33,8 +33,10 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
double precision :: weight1, ao_k_r, ao_i_r
double precision :: der_envsq_x, der_envsq_y, der_envsq_z, lap_envsq
double precision :: time0, time1
- double precision, allocatable :: b_mat(:,:,:,:), c_mat(:,:,:)
+ double precision, allocatable :: c_mat(:,:,:)
+ logical, external :: ao_two_e_integral_zero
double precision, external :: get_ao_two_e_integral
+ double precision, external :: ao_two_e_integral
PROVIDe tc_integ_type
PROVIDE env_type
@@ -194,9 +196,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
ao_i_r = aos_in_r_array_transp(ipoint,i)
ao_k_r = aos_in_r_array_transp(ipoint,k)
ao_two_e_tc_tot(j,l,k,i) = ao_two_e_tc_tot(j,l,k,i) &
- + weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) &
- + weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) &
- + weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,1) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1)) &
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,2) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2)) &
+ - weight1 * int2_grad1_u12_ao(j,l,ipoint,3) * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
enddo
enddo
enddo
@@ -209,39 +211,37 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' DGEMM are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
- allocate(b_mat(n_points_final_grid,ao_num,ao_num,3))
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
- !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, b_mat, &
- !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector)
- !$OMP DO SCHEDULE (static)
- do i = 1, ao_num
- do k = 1, ao_num
- do ipoint = 1, n_points_final_grid
+ allocate(c_mat(n_points_final_grid,ao_num,ao_num))
+ do m = 1, 3
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i, k, ipoint, weight1, ao_i_r, ao_k_r) &
+ !$OMP SHARED (aos_in_r_array_transp, aos_grad_in_r_array_transp_bis, c_mat, &
+ !$OMP ao_num, n_points_final_grid, final_weight_at_r_vector, m)
+ !$OMP DO SCHEDULE (static)
+ do i = 1, ao_num
+ do k = 1, ao_num
+ do ipoint = 1, n_points_final_grid
- weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
- ao_i_r = aos_in_r_array_transp(ipoint,i)
- ao_k_r = aos_in_r_array_transp(ipoint,k)
+ weight1 = 0.5d0 * final_weight_at_r_vector(ipoint)
+ ao_i_r = aos_in_r_array_transp(ipoint,i)
+ ao_k_r = aos_in_r_array_transp(ipoint,k)
- b_mat(ipoint,k,i,1) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,1) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,1))
- b_mat(ipoint,k,i,2) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,2) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,2))
- b_mat(ipoint,k,i,3) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,3) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,3))
+ c_mat(ipoint,k,i) = weight1 * (ao_k_r * aos_grad_in_r_array_transp_bis(ipoint,i,m) - ao_i_r * aos_grad_in_r_array_transp_bis(ipoint,k,m))
+ enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- do m = 1, 3
- call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
- , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, b_mat(1,1,1,m), n_points_final_grid &
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemm( "N", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, -1.d0 &
+ , int2_grad1_u12_ao(1,1,1,m), ao_num*ao_num, c_mat(1,1,1), n_points_final_grid &
, 1.d0, ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
enddo
- deallocate(b_mat)
+ deallocate(c_mat)
end if
- FREE int2_grad1_u12_ao
+ !FREE int2_grad1_u12_ao
if(tc_integ_type .eq. "semi-analytic") then
FREE int2_grad1_u2e_ao
@@ -258,19 +258,26 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
call sum_A_At(ao_two_e_tc_tot(1,1,1,1), ao_num*ao_num)
! ---
+
+ logical :: integ_zero
+ double precision :: integ_val
- PROVIDE ao_integrals_map
+ print*, ' adding ERI to ao_two_e_tc_tot ...'
- !$OMP PARALLEL DEFAULT(NONE) &
- !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
- !$OMP PRIVATE(i, j, k, l)
+ !$OMP PARALLEL DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) &
+ !$OMP SHARED(ao_num, ao_two_e_tc_tot)
!$OMP DO COLLAPSE(4)
do j = 1, ao_num
do l = 1, ao_num
do i = 1, ao_num
do k = 1, ao_num
- ! < 1:i, 2:j | 1:k, 2:l >
- ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ integ_zero = ao_two_e_integral_zero(i,j,k,l)
+ if(.not. integ_zero) then
+ ! i,k : r1 j,l : r2
+ integ_val = ao_two_e_integral(i,k,j,l)
+ ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val
+ endif
enddo
enddo
enddo
@@ -278,8 +285,25 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
!$OMP END DO
!$OMP END PARALLEL
- !call clear_ao_map()
- FREE ao_integrals_map
+ !PROVIDE ao_integrals_map
+ !!$OMP PARALLEL DEFAULT(NONE) &
+ !!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
+ !!$OMP PRIVATE(i, j, k, l)
+ !!$OMP DO COLLAPSE(4)
+ !do j = 1, ao_num
+ ! do l = 1, ao_num
+ ! do i = 1, ao_num
+ ! do k = 1, ao_num
+ ! ! < 1:i, 2:j | 1:k, 2:l >
+ ! ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ ! enddo
+ ! enddo
+ ! enddo
+ !enddo
+ !!$OMP END DO
+ !!$OMP END PARALLEL
+ !!call clear_ao_map()
+ !FREE ao_integrals_map
if(tc_integ_type .eq. "numeric") then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index a8491660..24362796 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -286,4 +286,10 @@ doc: If |true|, memory scale of TC ao -> mo: O(N3)
interface: ezfio,provider,ocaml
default: False
+[tc_save_mem]
+type: logical
+doc: If |true|, use loops to save memory TC
+interface: ezfio,provider,ocaml
+default: False
+
From 1a36d974b0bd5cd0c06453a15c96a8492c4baecc Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 7 Apr 2024 00:33:09 +0200
Subject: [PATCH 095/140] saving lcpq-ampere
---
.../local/bi_ort_ints/semi_num_ints_mo.irp.f | 68 ++++---
.../bi_ort_ints/three_body_ints_bi_ort.irp.f | 2 +-
.../local/bi_ort_ints/total_twoe_pot.irp.f | 87 ++++-----
plugins/local/non_h_ints_mu/tc_integ.irp.f | 175 ++++++++++++++++--
.../local/non_h_ints_mu/total_tc_int.irp.f | 93 +++++-----
plugins/local/tc_keywords/EZFIO.cfg | 8 +-
.../local/tc_scf/fock_3e_bi_ortho_cs.irp.f | 121 +++++++-----
.../local/tc_scf/fock_3e_bi_ortho_uhf.irp.f | 2 +-
plugins/local/tc_scf/fock_tc.irp.f | 2 +-
.../local/tc_scf/write_ao_2e_tc_integ.irp.f | 58 ++++++
.../multi_s_dipole_moment.irp.f | 22 ++-
11 files changed, 442 insertions(+), 196 deletions(-)
create mode 100644 plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
diff --git a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
index 51f0cba4..77e4cb9b 100644
--- a/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
+++ b/plugins/local/bi_ort_ints/semi_num_ints_mo.irp.f
@@ -107,8 +107,8 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
integer :: i, j, ipoint
double precision :: wall0, wall1
- print *, ' providing int2_grad1_u12_ao_transp ...'
- call wall_time(wall0)
+ !print *, ' providing int2_grad1_u12_ao_transp ...'
+ !call wall_time(wall0)
if(test_cycle_tc) then
@@ -142,15 +142,15 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_transp, (ao_num, ao_num, 3,
endif
- call wall_time(wall1)
- print *, ' wall time for int2_grad1_u12_ao_transp ', wall1 - wall0
- call print_memory_usage()
+ !call wall_time(wall1)
+ !print *, ' wall time for int2_grad1_u12_ao_transp (min) = ', (wall1 - wall0) / 60.d0
+ !call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num, 3, n_points_final_grid)]
implicit none
integer :: ipoint
@@ -159,7 +159,7 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_ao_transp
- !print *, ' providing int2_grad1_u12_bimo_transp'
+ !print *, ' providing int2_grad1_u12_bimo_transp ...'
!call wall_time(wall0)
!$OMP PARALLEL &
@@ -167,33 +167,35 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_transp, (mo_num, mo_num,
!$OMP PRIVATE (ipoint) &
!$OMP SHARED (n_points_final_grid,int2_grad1_u12_ao_transp,int2_grad1_u12_bimo_transp)
!$OMP DO SCHEDULE (dynamic)
- do ipoint = 1, n_points_final_grid
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
- , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
- enddo
+ do ipoint = 1, n_points_final_grid
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,1,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,1,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,2,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,2,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ call ao_to_mo_bi_ortho( int2_grad1_u12_ao_transp (1,1,3,ipoint), size(int2_grad1_u12_ao_transp , 1) &
+ , int2_grad1_u12_bimo_transp(1,1,3,ipoint), size(int2_grad1_u12_bimo_transp, 1) )
+ enddo
!$OMP END DO
!$OMP END PARALLEL
+ !FREE int2_grad1_u12_ao_transp
+
!call wall_time(wall1)
- !print *, ' Wall time for providing int2_grad1_u12_bimo_transp',wall1 - wall0
+ !print *, ' wall time for int2_grad1_u12_bimo_transp (min) =', (wall1 - wall0) / 60.d0
!call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_bimo_t, (n_points_final_grid, 3, mo_num, mo_num)]
implicit none
integer :: i, j, ipoint
double precision :: wall0, wall1
!call wall_time(wall0)
- !print *, ' Providing int2_grad1_u12_bimo_t ...'
+ !print *, ' providing int2_grad1_u12_bimo_t ...'
PROVIDE mo_l_coef mo_r_coef
PROVIDE int2_grad1_u12_bimo_transp
@@ -211,17 +213,21 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_bimo_t, (n_points_final_grid,
FREE int2_grad1_u12_bimo_transp
!call wall_time(wall1)
- !print *, ' wall time for int2_grad1_u12_bimo_t,', wall1 - wall0
+ !print *, ' wall time for int2_grad1_u12_bimo_t (min) =', (wall1 - wall0) / 60.d0
!call print_memory_usage()
END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
+BEGIN_PROVIDER [double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3, ao_num, ao_num)]
implicit none
- integer :: i, j, ipoint
+ integer :: i, j, ipoint
+ double precision :: wall0, wall1
+
+ !call wall_time(wall0)
+ !print *, ' providing int2_grad1_u12_ao_t ...'
PROVIDE int2_grad1_u12_ao
@@ -235,6 +241,10 @@ BEGIN_PROVIDER [ double precision, int2_grad1_u12_ao_t, (n_points_final_grid, 3,
enddo
enddo
+ !call wall_time(wall1)
+ !print *, ' wall time for int2_grad1_u12_ao_t (min) =', (wall1 - wall0) / 60.d0
+ !call print_memory_usage()
+
END_PROVIDER
! ---
@@ -275,8 +285,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
double precision :: xyz
double precision :: wall0, wall1
- print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
- call wall_time(wall0)
+ !print*, ' providing x_W_ki_bi_ortho_erf_rk ...'
+ !call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
@@ -300,8 +310,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk, (n_points_final_grid,
! 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
+ !call wall_time(wall1)
+ !print *, ' time to provide x_W_ki_bi_ortho_erf_rk = ', wall1 - wall0
END_PROVIDER
@@ -323,8 +333,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
double precision :: xyz
double precision :: wall0, wall1
- print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
- call wall_time(wall0)
+ !print*,'providing x_W_ki_bi_ortho_erf_rk_diag ...'
+ !call wall_time(wall0)
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
@@ -343,8 +353,8 @@ BEGIN_PROVIDER [ double precision, x_W_ki_bi_ortho_erf_rk_diag, (n_points_final_
!$OMP END DO
!$OMP END PARALLEL
- call wall_time(wall1)
- print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
+ !call wall_time(wall1)
+ !print*,'time to provide x_W_ki_bi_ortho_erf_rk_diag = ',wall1 - wall0
END_PROVIDER
diff --git a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
index 726e48ba..fd4a162f 100644
--- a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
+++ b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
@@ -168,7 +168,7 @@ subroutine give_integrals_3_body_bi_ort(n, l, k, m, j, i, integral)
integral = integral + tmp * final_weight_at_r_vector(ipoint)
enddo
-end subroutine give_integrals_3_body_bi_ort
+end
! ---
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 1e558038..e34a7b7b 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -16,10 +16,10 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
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
+ do p = 1, ao_num
+ do m = 1, ao_num
+ do q = 1, ao_num
+ do n = 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
@@ -27,7 +27,7 @@ double precision function bi_ortho_mo_ints(l, k, j, i)
enddo
enddo
-end function bi_ortho_mo_ints
+end
! ---
@@ -43,93 +43,68 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
integer :: i, j, k, l, m, n, p, q, s, r
double precision :: t1, t2, tt1, tt2
double precision, allocatable :: a1(:,:,:,:), a2(:,:,:,:)
- double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), a_pqr(:,:,:)
+ double precision, allocatable :: a_jkp(:,:,:), a_kpq(:,:,:), ao_two_e_tc_tot_tmp(:,:,:)
print *, ' PROVIDING mo_bi_ortho_tc_two_e_chemist ...'
call wall_time(t1)
call print_memory_usage()
PROVIDE mo_r_coef mo_l_coef
- PROVIDE ao_two_e_tc_tot
if(ao_to_mo_tc_n3) then
print*, ' memory scale of TC ao -> mo: O(N3) '
+ if(.not.read_tc_integ) then
+ stop 'read_tc_integ needs to be set to true'
+ endif
+
allocate(a_jkp(ao_num,ao_num,mo_num))
allocate(a_kpq(ao_num,mo_num,mo_num))
- allocate(a_pqr(mo_num,mo_num,mo_num))
+ allocate(ao_two_e_tc_tot_tmp(ao_num,ao_num,ao_num))
+
+ open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
call wall_time(tt1)
- do s = 1, mo_num
+ mo_bi_ortho_tc_two_e_chemist(:,:,:,:) = 0.d0
+ do l = 1, ao_num
+ read(11) ao_two_e_tc_tot_tmp(:,:,:)
- mo_bi_ortho_tc_two_e_chemist(:,:,:,s) = 0.d0
- do l = 1, ao_num
+ do s = 1, mo_num
- call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
- , ao_two_e_tc_tot(1,1,1,l), ao_num, mo_l_coef(1,1), ao_num &
+ call dgemm( 'T', 'N', ao_num*ao_num, mo_num, ao_num, 1.d0 &
+ , ao_two_e_tc_tot_tmp(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
, 0.d0, a_jkp(1,1,1), ao_num*ao_num)
-
+
call dgemm( 'T', 'N', ao_num*mo_num, mo_num, ao_num, 1.d0 &
, a_jkp(1,1,1), ao_num, mo_r_coef(1,1), ao_num &
, 0.d0, a_kpq(1,1,1), ao_num*mo_num)
-
- call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, 1.d0 &
- , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
- , 0.d0, a_pqr(1,1,1), mo_num*mo_num)
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(p, q, r) &
- !$OMP SHARED(s, l, mo_num, mo_bi_ortho_tc_two_e_chemist, mo_r_coef, a_pqr)
- !$OMP DO COLLAPSE(2)
- do p = 1, mo_num
- do q = 1, mo_num
- do r = 1, mo_num
- mo_bi_ortho_tc_two_e_chemist(p,q,r,s) = mo_bi_ortho_tc_two_e_chemist(p,q,r,s) + mo_r_coef(l,s) * a_pqr(p,q,r)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ call dgemm( 'T', 'N', mo_num*mo_num, mo_num, ao_num, mo_r_coef(l,s) &
+ , a_kpq(1,1,1), ao_num, mo_l_coef(1,1), ao_num &
+ , 1.d0, mo_bi_ortho_tc_two_e_chemist(1,1,1,s), mo_num*mo_num)
- enddo ! l
+ enddo ! s
- if(s == 2) then
+ if(l == 2) then
call wall_time(tt2)
print*, ' 1 / mo_num done in (min)', (tt2-tt1)/60.d0
print*, ' estimated time required (min)', dble(mo_num-1)*(tt2-tt1)/60.d0
- elseif(s == 11) then
+ elseif(l == 11) then
call wall_time(tt2)
print*, ' 10 / mo_num done in (min)', (tt2-tt1)/60.d0
print*, ' estimated time required (min)', dble(mo_num-10)*(tt2-tt1)/(60.d0*10.d0)
- elseif(s == 26) then
- call wall_time(tt2)
- print*, ' 25 / mo_num done in (min)', (tt2-tt1)/60.d0
- print*, ' estimated time required (min)', dble(mo_num-25)*(tt2-tt1)/(60.d0*25.d0)
- elseif(s == 51) then
- call wall_time(tt2)
- print*, ' 50 / mo_num done in (min)', (tt2-tt1)/60.d0
- print*, ' estimated time required (min)', dble(mo_num-50)*(tt2-tt1)/(60.d0*50.d0)
- elseif(s == 101) then
+ elseif(l == 101) then
call wall_time(tt2)
print*, ' 100 / mo_num done in (min)', (tt2-tt1)/60.d0
print*, ' estimated time required (min)', dble(mo_num-100)*(tt2-tt1)/(60.d0*100.d0)
- elseif(s == 201) then
- call wall_time(tt2)
- print*, ' 200 / mo_num done in (min)', (tt2-tt1)/60.d0
- print*, ' estimated time required (min)', dble(mo_num-200)*(tt2-tt1)/(60.d0*200.d0)
- elseif(s == 501) then
- call wall_time(tt2)
- print*, ' 500 / mo_num done in (min)', (tt2-tt1)/60.d0
- print*, ' estimated time required (min)', dble(mo_num-500)*(tt2-tt1)/(60.d0*500.d0)
endif
+ enddo ! l
+ close(11)
- enddo ! s
-
- deallocate(a_jkp, a_kpq, a_pqr)
+ deallocate(a_jkp, a_kpq, ao_two_e_tc_tot_tmp)
else
@@ -141,6 +116,8 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e_chemist, (mo_num, mo_num,
, ao_two_e_tc_tot(1,1,1,1), ao_num, mo_l_coef(1,1), ao_num &
, 0.d0, a2(1,1,1,1), ao_num*ao_num*ao_num)
+ FREE ao_two_e_tc_tot
+
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 &
diff --git a/plugins/local/non_h_ints_mu/tc_integ.irp.f b/plugins/local/non_h_ints_mu/tc_integ.irp.f
index 775a9e4c..58e3db48 100644
--- a/plugins/local/non_h_ints_mu/tc_integ.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ.irp.f
@@ -44,14 +44,92 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_ao, (ao_num, ao_num, n_points_f
elseif(tc_integ_type .eq. "numeric") then
print *, ' Numerical integration over r1 and r2 will be performed'
-
- ! TODO combine 1shot & int2_grad1_u12_ao_num
- PROVIDE int2_grad1_u12_ao_num
- int2_grad1_u12_ao = int2_grad1_u12_ao_num
+ if(tc_save_mem) then
- !PROVIDE int2_grad1_u12_ao_num_1shot
- !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision, allocatable :: tmp(:,:,:), xx(:)
+ double precision, allocatable :: tmp_grad1_u12(:,:,:)
+
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num), xx(n_points_extra_final_grid))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_blocks,3))
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_blocks,1), tmp_grad1_u12(1,i_blocks,2), tmp_grad1_u12(1,i_blocks,3), xx(1))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+ enddo
+ deallocate(tmp_grad1_u12)
+ if(n_rest .gt. 0) then
+ allocate(tmp_grad1_u12(n_points_extra_final_grid,n_rest,3))
+ ii = n_pass*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, xx, tmp_grad1_u12)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, tmp_grad1_u12(1,i_rest,1), tmp_grad1_u12(1,i_rest,2), tmp_grad1_u12(1,i_rest,3), xx(1))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ do m = 1, 3
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, 1.d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12(1,1,m), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_ao(1,1,ii,m), ao_num*ao_num)
+ enddo
+ deallocate(tmp_grad1_u12)
+ endif
+ deallocate(tmp,xx)
+
+ else
+ ! TODO combine 1shot & int2_grad1_u12_ao_num
+ PROVIDE int2_grad1_u12_ao_num
+ int2_grad1_u12_ao = int2_grad1_u12_ao_num
+ !PROVIDE int2_grad1_u12_ao_num_1shot
+ !int2_grad1_u12_ao = int2_grad1_u12_ao_num_1shot
+ endif
elseif(tc_integ_type .eq. "semi-analytic") then
@@ -177,13 +255,88 @@ BEGIN_PROVIDER [double precision, int2_grad1_u12_square_ao, (ao_num, ao_num, n_p
print *, ' Numerical integration over r1 and r2 will be performed'
- ! TODO combine 1shot & int2_grad1_u12_square_ao_num
+ if(tc_save_mem) then
- PROVIDE int2_grad1_u12_square_ao_num
- int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
+ integer :: n_blocks, n_rest, n_pass
+ integer :: i_blocks, i_rest, i_pass, ii
+ double precision :: mem, n_double
+ double precision, allocatable :: tmp(:,:,:), xx(:,:,:)
+ double precision, allocatable :: tmp_grad1_u12_squared(:,:)
- !PROVIDE int2_grad1_u12_square_ao_num_1shot
- !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
+ PROVIDE final_weight_at_r_vector_extra aos_in_r_array_extra
+
+ allocate(tmp(n_points_extra_final_grid,ao_num,ao_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (j, i, jpoint) &
+ !$OMP SHARED (tmp, ao_num, n_points_extra_final_grid, final_weight_at_r_vector_extra, aos_in_r_array_extra_transp)
+ !$OMP DO COLLAPSE(2)
+ do j = 1, ao_num
+ do i = 1, ao_num
+ do jpoint = 1, n_points_extra_final_grid
+ tmp(jpoint,i,j) = final_weight_at_r_vector_extra(jpoint) * aos_in_r_array_extra_transp(jpoint,i) * aos_in_r_array_extra_transp(jpoint,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call total_memory(mem)
+ mem = max(1.d0, qp_max_mem - mem)
+ n_double = mem * 1.d8
+ n_blocks = int(min(n_double / (n_points_extra_final_grid * 4.d0), 1.d0*n_points_final_grid))
+ n_rest = int(mod(n_points_final_grid, n_blocks))
+ n_pass = int((n_points_final_grid - n_rest) / n_blocks)
+ call write_int(6, n_pass, 'Number of passes')
+ call write_int(6, n_blocks, 'Size of the blocks')
+ call write_int(6, n_rest, 'Size of the last block')
+ allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_blocks), xx(n_points_extra_final_grid,n_blocks,3))
+ do i_pass = 1, n_pass
+ ii = (i_pass-1)*n_blocks + 1
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
+ !$OMP DO
+ do i_blocks = 1, n_blocks
+ ipoint = ii - 1 + i_blocks ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_blocks,1), xx(1,i_blocks,2), xx(1,i_blocks,3), tmp_grad1_u12_squared(1,i_blocks))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "T", "N", ao_num*ao_num, n_blocks, n_points_extra_final_grid, -0.5d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
+ enddo
+ deallocate(tmp_grad1_u12_squared, xx)
+ if(n_rest .gt. 0) then
+ ii = n_pass*n_blocks + 1
+ allocate(tmp_grad1_u12_squared(n_points_extra_final_grid,n_rest), xx(n_points_extra_final_grid,n_rest,3))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, xx, final_grid_points, tmp_grad1_u12_squared)
+ !$OMP DO
+ do i_rest = 1, n_rest
+ ipoint = ii - 1 + i_rest ! r1
+ call get_grad1_u12_withsq_r1_seq(ipoint, n_points_extra_final_grid, xx(1,i_rest,1), xx(1,i_rest,2), xx(1,i_rest,3), tmp_grad1_u12_squared(1,i_rest))
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemm( "T", "N", ao_num*ao_num, n_rest, n_points_extra_final_grid, -0.5d0 &
+ , tmp(1,1,1), n_points_extra_final_grid, tmp_grad1_u12_squared(1,1), n_points_extra_final_grid &
+ , 0.d0, int2_grad1_u12_square_ao(1,1,ii), ao_num*ao_num)
+ deallocate(tmp_grad1_u12_squared, xx)
+ endif
+ deallocate(tmp)
+
+ else
+
+ ! TODO combine 1shot & int2_grad1_u12_square_ao_num
+ PROVIDE int2_grad1_u12_square_ao_num
+ int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num
+ !PROVIDE int2_grad1_u12_square_ao_num_1shot
+ !int2_grad1_u12_square_ao = int2_grad1_u12_square_ao_num_1shot
+ endif
elseif(tc_integ_type .eq. "semi-analytic") then
diff --git a/plugins/local/non_h_ints_mu/total_tc_int.irp.f b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
index b8379006..a1bbd6e0 100644
--- a/plugins/local/non_h_ints_mu/total_tc_int.irp.f
+++ b/plugins/local/non_h_ints_mu/total_tc_int.irp.f
@@ -55,7 +55,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' Reading ao_two_e_tc_tot from ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="read")
- read(11) ao_two_e_tc_tot
+ do i = 1, ao_num
+ read(11) ao_two_e_tc_tot(:,:,:,i)
+ enddo
close(11)
else
@@ -67,7 +69,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_square_ao
- if(tc_save_mem) then
+ if(tc_save_mem_loops) then
print*, ' LOOPS are used to evaluate Hermitian part of ao_two_e_tc_tot ...'
@@ -176,7 +178,7 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
PROVIDE int2_grad1_u12_ao
- if(tc_save_mem) then
+ if(tc_save_mem_loops) then
print*, ' LOOPS are used to evaluate non-Hermitian part of ao_two_e_tc_tot ...'
@@ -241,7 +243,6 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
deallocate(c_mat)
end if
- !FREE int2_grad1_u12_ao
if(tc_integ_type .eq. "semi-analytic") then
FREE int2_grad1_u2e_ao
@@ -264,48 +265,52 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' adding ERI to ao_two_e_tc_tot ...'
- !$OMP PARALLEL DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) &
- !$OMP SHARED(ao_num, ao_two_e_tc_tot)
- !$OMP DO COLLAPSE(4)
- do j = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do k = 1, ao_num
- integ_zero = ao_two_e_integral_zero(i,j,k,l)
- if(.not. integ_zero) then
- ! i,k : r1 j,l : r2
- integ_val = ao_two_e_integral(i,k,j,l)
- ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val
- endif
+ if(tc_save_mem) then
+ print*, ' ao_integrals_map will not be used'
+ !$OMP PARALLEL DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, k, l, integ_zero, integ_val) &
+ !$OMP SHARED(ao_num, ao_two_e_tc_tot)
+ !$OMP DO COLLAPSE(4)
+ do j = 1, ao_num
+ do l = 1, ao_num
+ do i = 1, ao_num
+ do k = 1, ao_num
+ integ_zero = ao_two_e_integral_zero(i,j,k,l)
+ if(.not. integ_zero) then
+ ! i,k : r1 j,l : r2
+ integ_val = ao_two_e_integral(i,k,j,l)
+ ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + integ_val
+ endif
+ enddo
enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
+ else
+ print*, ' ao_integrals_map will be used'
+ PROVIDE ao_integrals_map
+ !$OMP PARALLEL DEFAULT(NONE) &
+ !$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
+ !$OMP PRIVATE(i, j, k, l)
+ !$OMP DO COLLAPSE(4)
+ do j = 1, ao_num
+ do l = 1, ao_num
+ do i = 1, ao_num
+ do k = 1, ao_num
+ ! < 1:i, 2:j | 1:k, 2:l >
+ ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ !call clear_ao_map()
+ FREE ao_integrals_map
+ endif
- !PROVIDE ao_integrals_map
- !!$OMP PARALLEL DEFAULT(NONE) &
- !!$OMP SHARED(ao_num, ao_two_e_tc_tot, ao_integrals_map) &
- !!$OMP PRIVATE(i, j, k, l)
- !!$OMP DO COLLAPSE(4)
- !do j = 1, ao_num
- ! do l = 1, ao_num
- ! do i = 1, ao_num
- ! do k = 1, ao_num
- ! ! < 1:i, 2:j | 1:k, 2:l >
- ! ao_two_e_tc_tot(k,i,l,j) = ao_two_e_tc_tot(k,i,l,j) + get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
- ! enddo
- ! enddo
- ! enddo
- !enddo
- !!$OMP END DO
- !!$OMP END PARALLEL
- !!call clear_ao_map()
- !FREE ao_integrals_map
-
- if(tc_integ_type .eq. "numeric") then
+ if((tc_integ_type .eq. "numeric") .and. (.not. tc_save_mem)) then
FREE int2_grad1_u12_ao_num int2_grad1_u12_square_ao_num
endif
@@ -315,7 +320,9 @@ BEGIN_PROVIDER [double precision, ao_two_e_tc_tot, (ao_num, ao_num, ao_num, ao_n
print*, ' Saving ao_two_e_tc_tot in ', trim(ezfio_filename) // '/work/ao_two_e_tc_tot'
open(unit=11, form="unformatted", file=trim(ezfio_filename)//'/work/ao_two_e_tc_tot', action="write")
call ezfio_set_work_empty(.False.)
- write(11) ao_two_e_tc_tot
+ do i = 1, ao_num
+ write(11) ao_two_e_tc_tot(:,:,:,i)
+ enddo
close(11)
call ezfio_set_tc_keywords_io_tc_integ('Read')
endif
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 24362796..70169189 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -286,10 +286,16 @@ doc: If |true|, memory scale of TC ao -> mo: O(N3)
interface: ezfio,provider,ocaml
default: False
-[tc_save_mem]
+[tc_save_mem_loops]
type: logical
doc: If |true|, use loops to save memory TC
interface: ezfio,provider,ocaml
default: False
+[tc_save_mem]
+type: logical
+doc: If |true|, more calc but less mem
+interface: ezfio,provider,ocaml
+default: False
+
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
index 0b883865..8fd5e5b6 100644
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
+++ b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
@@ -9,7 +9,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
double precision :: loc_1, loc_2, loc_3
double precision, allocatable :: Okappa(:), Jkappa(:,:)
double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
- double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
+ double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:), tmp_22(:,:,:)
double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
PROVIDE mo_l_coef mo_r_coef
@@ -63,17 +63,13 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
allocate(tmp_1(n_points_final_grid,4))
do ipoint = 1, n_points_final_grid
-
loc_1 = 2.d0 * Okappa(ipoint)
-
tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
-
tmp_1(ipoint,4) = Okappa(ipoint)
enddo
-
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
@@ -112,58 +108,81 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
! ---
- allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+ if(tc_save_mem) then
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- tmp_2(:,4,b,a) = 0.d0
- do i = 1, elec_beta_num
+ allocate(tmp_22(n_points_final_grid,4,mo_num))
+ do a = 1, mo_num
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, a, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_22)
+ !$OMP DO
+ do b = 1, mo_num
do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ tmp_22(ipoint,1,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_22(ipoint,2,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_22(ipoint,3,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_22(:,4,b) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_22(ipoint,4,b) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num, -2.d0 &
+ , tmp_22(1,1,1), size(tmp_22, 1) * size(tmp_22, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_uhf_mo_cs(1,a), 1)
+ enddo
+ deallocate(tmp_22)
+
+ else
+
+ allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_2(:,4,b,a) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
enddo
enddo
enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
+ deallocate(tmp_2)
- ! ---
+ endif
- call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
+ deallocate(tmp_1)
! ---
@@ -272,7 +291,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
! ---
!call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_cs =', tf - ti
+ !print *, ' total Wall time for fock_3e_uhf_mo_cs =', (tf - ti) / 60.d0
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
index 63a1e162..47ee5b48 100644
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
+++ b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
@@ -32,7 +32,7 @@ BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
endif
!call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a =', tf - ti
+ !print *, ' Wall time for fock_3e_uhf_mo_a (min) =', (tf - ti)/60.d0
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f
index 282f9873..d3ddb8ad 100644
--- a/plugins/local/tc_scf/fock_tc.irp.f
+++ b/plugins/local/tc_scf/fock_tc.irp.f
@@ -175,7 +175,7 @@ END_PROVIDER
! ---
-BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num) ]
+BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
BEGIN_DOC
! Total alpha TC Fock matrix : h_c + Two-e^TC terms on the MO basis
diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
new file mode 100644
index 00000000..7ce57578
--- /dev/null
+++ b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
@@ -0,0 +1,58 @@
+! ---
+
+program write_ao_2e_tc_integ
+
+ implicit none
+
+ PROVIDE j1e_type
+ PROVIDE j2e_type
+
+ print *, ' j1e_type = ', j1e_type
+ print *, ' j2e_type = ', j2e_type
+
+ my_grid_becke = .True.
+ PROVIDE tc_grid1_a tc_grid1_r
+ my_n_pt_r_grid = tc_grid1_r
+ my_n_pt_a_grid = tc_grid1_a
+ touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ call write_int(6, my_n_pt_r_grid, 'radial external grid over')
+ call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+ if(tc_integ_type .eq. "numeric") then
+ my_extra_grid_becke = .True.
+ PROVIDE tc_grid2_a tc_grid2_r
+ my_n_pt_r_extra_grid = tc_grid2_r
+ my_n_pt_a_extra_grid = tc_grid2_a
+ touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+ call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
+ call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+ endif
+
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+
+ PROVIDE io_tc_integ
+
+ print*, 'io_tc_integ = ', io_tc_integ
+
+ if(io_tc_integ .ne. "Write") then
+ print*, 'io_tc_integ != Write'
+ print*, io_tc_integ
+ stop
+ endif
+
+ PROVIDE ao_two_e_tc_tot
+
+end
+
+! ---
+
diff --git a/src/mol_properties/multi_s_dipole_moment.irp.f b/src/mol_properties/multi_s_dipole_moment.irp.f
index f21e08cd..c7216a61 100644
--- a/src/mol_properties/multi_s_dipole_moment.irp.f
+++ b/src/mol_properties/multi_s_dipole_moment.irp.f
@@ -102,12 +102,28 @@ END_PROVIDER
&BEGIN_PROVIDER [double precision, multi_s_z_dipole_moment_eigenval, (N_states)]
implicit none
+ double precision, allocatable :: eigval(:), eigvec(:,:), A(:,:)
PROVIDE multi_s_x_dipole_moment multi_s_y_dipole_moment multi_s_z_dipole_moment
- call lapack_diag(multi_s_x_dipole_moment_eigenval(1), multi_s_x_dipole_moment_eigenvec(1,1), multi_s_x_dipole_moment(1,1), N_states, N_states)
- call lapack_diag(multi_s_y_dipole_moment_eigenval(1), multi_s_y_dipole_moment_eigenvec(1,1), multi_s_y_dipole_moment(1,1), N_states, N_states)
- call lapack_diag(multi_s_z_dipole_moment_eigenval(1), multi_s_z_dipole_moment_eigenvec(1,1), multi_s_z_dipole_moment(1,1), N_states, N_states)
+ allocate(A(N_states,N_states), eigvec(N_states,N_states), eigval(N_states))
+
+ A = multi_s_x_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_x_dipole_moment_eigenval = eigval
+ multi_s_x_dipole_moment_eigenvec = eigvec
+
+ A = multi_s_y_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_y_dipole_moment_eigenval = eigval
+ multi_s_y_dipole_moment_eigenvec = eigvec
+
+ A = multi_s_z_dipole_moment
+ call lapack_diag(eigval(1), eigvec(1,1), A(1,1), N_states, N_states)
+ multi_s_z_dipole_moment_eigenval = eigval
+ multi_s_z_dipole_moment_eigenvec = eigvec
+
+ deallocate(A, eigvec, eigval)
END_PROVIDER
From e65d7913bfdf83159ffd50eb39c76e63dea221d5 Mon Sep 17 00:00:00 2001
From: AbdAmmar
Date: Sun, 7 Apr 2024 00:43:32 +0200
Subject: [PATCH 096/140] saving lcpq
---
bin/qp_convert_output_to_ezfio | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/bin/qp_convert_output_to_ezfio b/bin/qp_convert_output_to_ezfio
index 1b33f156..6f2d02d0 100755
--- a/bin/qp_convert_output_to_ezfio
+++ b/bin/qp_convert_output_to_ezfio
@@ -227,8 +227,8 @@ def write_ezfio(res, filename):
shell_index += [nshell_tot] * len(b.prim)
shell_num = len(ang_mom)
- assert(shell_index[0] = 1)
- assert(shell_index[-1] = shell_num)
+ assert(shell_index[0] == 1)
+ assert(shell_index[-1] == shell_num)
# ~#~#~#~#~ #
# W r i t e #
From 43b83ee8e9fc93de3675b36cc04592a81c9f33b4 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 9 Apr 2024 12:34:35 +0200
Subject: [PATCH 097/140] Better error message
---
scripts/compilation/qp_create_ninja | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/scripts/compilation/qp_create_ninja b/scripts/compilation/qp_create_ninja
index e67d896b..75b50c82 100755
--- a/scripts/compilation/qp_create_ninja
+++ b/scripts/compilation/qp_create_ninja
@@ -802,8 +802,12 @@ if __name__ == "__main__":
pickle_path = os.path.join(QP_ROOT, "config", "qp_create_ninja.pickle")
if arguments["update"]:
+ try:
with open(pickle_path, 'rb') as handle:
arguments = pickle.load(handle)
+ except FileNotFoundError:
+ print("\n-----\nError: Please run 'configure -c config/'\n-----\n")
+ raise
elif arguments["create"]:
From 4fe07d97b099d96c36192603f2af4f70938b7eb0 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Tue, 9 Apr 2024 12:41:53 +0200
Subject: [PATCH 098/140] Added MP2 program
---
src/mp2/H_apply.irp.f | 15 +++++++++++++++
src/mp2/NEED | 6 ++++++
src/mp2/README.rst | 4 ++++
src/mp2/mp2.irp.f | 21 +++++++++++++++++++++
4 files changed, 46 insertions(+)
create mode 100644 src/mp2/H_apply.irp.f
create mode 100644 src/mp2/NEED
create mode 100644 src/mp2/README.rst
create mode 100644 src/mp2/mp2.irp.f
diff --git a/src/mp2/H_apply.irp.f b/src/mp2/H_apply.irp.f
new file mode 100644
index 00000000..471dde50
--- /dev/null
+++ b/src/mp2/H_apply.irp.f
@@ -0,0 +1,15 @@
+use bitmasks
+BEGIN_SHELL [ /usr/bin/env python3 ]
+from generate_h_apply import *
+from perturbation import perturbations
+
+s = H_apply("mp2")
+s.set_perturbation("Moller_plesset")
+#s.set_perturbation("epstein_nesbet")
+print(s)
+
+s = H_apply("mp2_selection")
+s.set_selection_pt2("Moller_Plesset")
+print(s)
+END_SHELL
+
diff --git a/src/mp2/NEED b/src/mp2/NEED
new file mode 100644
index 00000000..6eaf5b93
--- /dev/null
+++ b/src/mp2/NEED
@@ -0,0 +1,6 @@
+generators_full
+selectors_full
+determinants
+davidson
+davidson_undressed
+perturbation
diff --git a/src/mp2/README.rst b/src/mp2/README.rst
new file mode 100644
index 00000000..192a75f1
--- /dev/null
+++ b/src/mp2/README.rst
@@ -0,0 +1,4 @@
+===
+mp2
+===
+
diff --git a/src/mp2/mp2.irp.f b/src/mp2/mp2.irp.f
new file mode 100644
index 00000000..b8e0cc4a
--- /dev/null
+++ b/src/mp2/mp2.irp.f
@@ -0,0 +1,21 @@
+program mp2
+ call run
+end
+
+subroutine run
+ implicit none
+ double precision, allocatable :: pt2(:), norm_pert(:)
+ double precision :: H_pert_diag, E_old
+ integer :: N_st, iter
+ PROVIDE Fock_matrix_diag_mo H_apply_buffer_allocated
+ N_st = N_states
+ allocate (pt2(N_st), norm_pert(N_st))
+ E_old = HF_energy
+ call H_apply_mp2(pt2, norm_pert, H_pert_diag, N_st)
+ print *, 'N_det = ', N_det
+ print *, 'N_states = ', N_states
+ print *, 'MP2 = ', pt2
+ print *, 'E = ', E_old
+ print *, 'E+MP2 = ', E_old+pt2
+ deallocate(pt2,norm_pert)
+end
From e35e65ea2ce077434068fdc0e7b04aac4add2536 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 17 Apr 2024 11:40:00 +0200
Subject: [PATCH 099/140] Abs in CCSD
---
Makefile | 2 +-
src/ccsd/ccsd_t_space_orb_stoch.irp.f | 7 ++++---
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/Makefile b/Makefile
index 0be38b3c..d9c9eb47 100644
--- a/Makefile
+++ b/Makefile
@@ -2,4 +2,4 @@ default: build.ninja
bash -c "source quantum_package.rc ; ninja"
build.ninja:
- @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "The QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
+ @bash -c ' echo '' ; echo xxxxxxxxxxxxxxxxxx ; echo "QP is not configured yet. Please run the ./configure command" ; echo xxxxxxxxxxxxxxxxxx ; echo '' ; ./configure --help' | more
diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
index 618d50e4..2aa134d1 100644
--- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f
+++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
@@ -125,7 +125,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do b = a+1, nV
do c = b+1, nV
Nabc = Nabc + 1_8
- Pabc(Nabc) = -1.d0/(f_v(a) + f_v(b) + f_v(c))
+ Pabc(Nabc) = 1.d0/(f_v(a) + f_v(b) + f_v(c))
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(c,2)
@@ -135,13 +135,13 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(a,2)
- Pabc(Nabc) = -1.d0/(2.d0*f_v(a) + f_v(b))
+ Pabc(Nabc) = 1.d0/(2.d0*f_v(a) + f_v(b))
Nabc = Nabc + 1_8
abc(1,Nabc) = int(b,2)
abc(2,Nabc) = int(a,2)
abc(3,Nabc) = int(b,2)
- Pabc(Nabc) = -1.d0/(f_v(a) + 2.d0*f_v(b))
+ Pabc(Nabc) = 1.d0/(f_v(a) + 2.d0*f_v(b))
enddo
enddo
@@ -150,6 +150,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
! Sort triplets in decreasing Pabc
+ Pabc(:) = -dabs(Pabc(:))
call dsort_big(Pabc, iorder, Nabc)
! Normalize
From cf479a80afc02dd1f9ff534937052afe5ae64cd9 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Wed, 17 Apr 2024 18:06:53 +0200
Subject: [PATCH 100/140] Avoid divergence in (T)
---
src/ccsd/ccsd_t_space_orb_stoch.irp.f | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/src/ccsd/ccsd_t_space_orb_stoch.irp.f b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
index 2aa134d1..1093c59d 100644
--- a/src/ccsd/ccsd_t_space_orb_stoch.irp.f
+++ b/src/ccsd/ccsd_t_space_orb_stoch.irp.f
@@ -125,7 +125,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
do b = a+1, nV
do c = b+1, nV
Nabc = Nabc + 1_8
- Pabc(Nabc) = 1.d0/(f_v(a) + f_v(b) + f_v(c))
+ Pabc(Nabc) = f_v(a) + f_v(b) + f_v(c)
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(c,2)
@@ -135,13 +135,13 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
abc(1,Nabc) = int(a,2)
abc(2,Nabc) = int(b,2)
abc(3,Nabc) = int(a,2)
- Pabc(Nabc) = 1.d0/(2.d0*f_v(a) + f_v(b))
+ Pabc(Nabc) = 2.d0*f_v(a) + f_v(b)
Nabc = Nabc + 1_8
abc(1,Nabc) = int(b,2)
abc(2,Nabc) = int(a,2)
abc(3,Nabc) = int(b,2)
- Pabc(Nabc) = 1.d0/(f_v(a) + 2.d0*f_v(b))
+ Pabc(Nabc) = f_v(a) + 2.d0*f_v(b)
enddo
enddo
@@ -150,7 +150,7 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
enddo
! Sort triplets in decreasing Pabc
- Pabc(:) = -dabs(Pabc(:))
+ Pabc(:) = -1.d0/max(0.2d0,Pabc(:))
call dsort_big(Pabc, iorder, Nabc)
! Normalize
@@ -165,7 +165,6 @@ subroutine ccsd_par_t_space_stoch(nO,nV,t1,t2,f_o,f_v,v_vvvo,v_vvoo,v_vooo,energ
call i8set_order_big(abc, iorder, Nabc)
-
! Cumulative distribution for sampling
waccu(Nabc) = 0.d0
do i8=Nabc-1,1,-1
From 2c899e6dd71247ae26cd337ede2bb13ce9419489 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Sat, 20 Apr 2024 12:39:39 +0200
Subject: [PATCH 101/140] few modif in grids
---
.../extra_grid_vector.irp.f | 23 +++++++++++++++++--
.../grid_becke_vector.irp.f | 6 ++++-
2 files changed, 26 insertions(+), 3 deletions(-)
diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f
index ae167282..16a52dc6 100644
--- a/src/becke_numerical_grid/extra_grid_vector.irp.f
+++ b/src/becke_numerical_grid/extra_grid_vector.irp.f
@@ -47,8 +47,12 @@ END_PROVIDER
END_DOC
implicit none
- integer :: i,j,k,l,i_count
- double precision :: r(3)
+ integer :: i, j, k, l, i_count
+ double precision :: r(3)
+ double precision :: wall0, wall1
+
+ call wall_time(wall0)
+ print *, ' Providing extra_final_grid_points ...'
i_count = 0
do j = 1, nucl_num
@@ -66,10 +70,25 @@ END_PROVIDER
index_final_points_extra(2,i_count) = i
index_final_points_extra(3,i_count) = j
index_final_points_extra_reverse(k,i,j) = i_count
+
+ if(final_weight_at_r_vector_extra(i_count) .lt. 0.d0) then
+ print *, ' !!! WARNING !!!'
+ print *, ' negative weight !!!!'
+ print *, i_count, final_weight_at_r_vector_extra(i_count)
+ if(dabs(final_weight_at_r_vector_extra(i_count)) .lt. 1d-10) then
+ final_weight_at_r_vector_extra(i_count) = 0.d0
+ else
+ stop
+ endif
+ endif
enddo
enddo
enddo
+ call wall_time(wall1)
+ print *, ' wall time for extra_final_grid_points,', wall1 - wall0
+ call print_memory_usage()
+
END_PROVIDER
diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f
index 473096d0..c35918c3 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -72,7 +72,11 @@ END_PROVIDER
print *, ' !!! WARNING !!!'
print *, ' negative weight !!!!'
print *, i_count, final_weight_at_r_vector(i_count)
- stop
+ if(dabs(final_weight_at_r_vector(i_count)) .lt. 1d-10) then
+ final_weight_at_r_vector(i_count) = 0.d0
+ else
+ stop
+ endif
endif
enddo
enddo
From 4f293298c345c30470cab0c79b4de4b38f4fb851 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 22 Apr 2024 10:45:31 +0200
Subject: [PATCH 102/140] Updated irpf90
---
external/irpf90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/external/irpf90 b/external/irpf90
index 4ab1b175..76946321 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
+Subproject commit 76946321d64b0be58933a6f37d6a0781b96dff86
From c8b91f980eb54b78fe127d87727abe493065b08b Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 22 Apr 2024 10:58:42 +0200
Subject: [PATCH 103/140] Updated irpf90
---
external/irpf90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/external/irpf90 b/external/irpf90
index 76946321..451c93a5 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 76946321d64b0be58933a6f37d6a0781b96dff86
+Subproject commit 451c93a52c1ca3f78ce2f0e4add773d6e44e561a
From ecfdaf9eea971db1f0ce8df598670a67a45dc86b Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 22 Apr 2024 11:03:26 +0200
Subject: [PATCH 104/140] Updated irpf90
---
external/irpf90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/external/irpf90 b/external/irpf90
index 451c93a5..beac6153 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit 451c93a52c1ca3f78ce2f0e4add773d6e44e561a
+Subproject commit beac615343f421bd6c0571a408ba389a6d5a32ac
From de288449f58a54893cf1647faa8b00116303e7bc Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 22 Apr 2024 13:45:51 +0200
Subject: [PATCH 105/140] Fix dos files in qp_create
---
ocaml/Atom.ml | 13 +++++++++----
ocaml/Molecule.ml | 12 +++++++++++-
ocaml/Point3d.ml | 4 +++-
3 files changed, 23 insertions(+), 6 deletions(-)
diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml
index d02b20d8..49e788e8 100644
--- a/ocaml/Atom.ml
+++ b/ocaml/Atom.ml
@@ -22,10 +22,15 @@ let of_string ~units s =
}
| [ name; x; y; z ] ->
let e = Element.of_string name in
- { element = e ;
- charge = Element.to_charge e;
- coord = Point3d.of_string ~units (String.concat " " [x; y; z])
- }
+ begin
+ try
+ { element = e ;
+ charge = Element.to_charge e;
+ coord = Point3d.of_string ~units (String.concat " " [x; y; z])
+ }
+ with
+ | err -> (Printf.eprintf "name = \"%s\"\nxyz = (%s,%s,%s)\n%!" name x y z ; raise err)
+ end
| _ -> raise (AtomError s)
diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml
index 603244c8..3771b6f9 100644
--- a/ocaml/Molecule.ml
+++ b/ocaml/Molecule.ml
@@ -142,13 +142,21 @@ let of_xyz_string
result
+let regexp_r = Str.regexp {|
|}
+let regexp_t = Str.regexp {| |}
+
let of_xyz_file
?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1))
?(units=Units.Angstrom)
filename =
let lines =
- match Io_ext.input_lines filename with
+ Io_ext.input_lines filename
+ |> List.map (fun s -> Str.global_replace regexp_r "" s)
+ |> List.map (fun s -> Str.global_replace regexp_t " " s)
+ in
+ let lines =
+ match lines with
| natoms :: title :: rest ->
let natoms =
try
@@ -173,6 +181,8 @@ let of_zmt_file
?(units=Units.Angstrom)
filename =
Io_ext.read_all filename
+ |> Str.global_replace regexp_r ""
+ |> Str.global_replace regexp_t " "
|> Zmatrix.of_string
|> Zmatrix.to_xyz_string
|> of_xyz_string ~charge ~multiplicity ~units
diff --git a/ocaml/Point3d.ml b/ocaml/Point3d.ml
index 57b02bfe..4df375e4 100644
--- a/ocaml/Point3d.ml
+++ b/ocaml/Point3d.ml
@@ -24,7 +24,9 @@ let of_string ~units s =
let l = s
|> String_ext.split ~on:' '
|> List.filter (fun x -> x <> "")
- |> list_map float_of_string
+ |> list_map (fun x ->
+ try float_of_string x with
+ | Failure msg -> (Printf.eprintf "Bad string: \"%s\"\n%!" x ; failwith msg) )
|> Array.of_list
in
{ x = l.(0) *. f ;
From e9dccd2364f282397df9f3b5bc4e3373fe3bd7e6 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 25 Apr 2024 19:46:26 +0200
Subject: [PATCH 106/140] added spherical harmonics
---
plugins/local/spher_harm/.gitignore | 59 +++++
plugins/local/spher_harm/NEED | 1 +
plugins/local/spher_harm/README.rst | 4 +
plugins/local/spher_harm/assoc_gaus_pol.irp.f | 50 ++++
plugins/local/spher_harm/spher_harm.irp.f | 217 ++++++++++++++++++
.../local/spher_harm/spher_harm_func.irp.f | 151 ++++++++++++
6 files changed, 482 insertions(+)
create mode 100644 plugins/local/spher_harm/.gitignore
create mode 100644 plugins/local/spher_harm/NEED
create mode 100644 plugins/local/spher_harm/README.rst
create mode 100644 plugins/local/spher_harm/assoc_gaus_pol.irp.f
create mode 100644 plugins/local/spher_harm/spher_harm.irp.f
create mode 100644 plugins/local/spher_harm/spher_harm_func.irp.f
diff --git a/plugins/local/spher_harm/.gitignore b/plugins/local/spher_harm/.gitignore
new file mode 100644
index 00000000..1561915b
--- /dev/null
+++ b/plugins/local/spher_harm/.gitignore
@@ -0,0 +1,59 @@
+IRPF90_temp/
+IRPF90_man/
+build.ninja
+irpf90.make
+ezfio_interface.irp.f
+irpf90_entities
+tags
+Makefile
+ao_basis
+ao_one_e_ints
+ao_two_e_erf_ints
+ao_two_e_ints
+aux_quantities
+becke_numerical_grid
+bitmask
+cis
+cisd
+cipsi
+davidson
+davidson_dressed
+davidson_undressed
+density_for_dft
+determinants
+dft_keywords
+dft_utils_in_r
+dft_utils_one_e
+dft_utils_two_body
+dressing
+dummy
+electrons
+ezfio_files
+fci
+generators_cas
+generators_full
+hartree_fock
+iterations
+kohn_sham
+kohn_sham_rs
+mo_basis
+mo_guess
+mo_one_e_ints
+mo_two_e_erf_ints
+mo_two_e_ints
+mpi
+mrpt_utils
+nuclei
+perturbation
+pseudo
+psiref_cas
+psiref_utils
+scf_utils
+selectors_cassd
+selectors_full
+selectors_utils
+single_ref_method
+slave
+tools
+utils
+zmq
diff --git a/plugins/local/spher_harm/NEED b/plugins/local/spher_harm/NEED
new file mode 100644
index 00000000..92df7f12
--- /dev/null
+++ b/plugins/local/spher_harm/NEED
@@ -0,0 +1 @@
+dft_utils_in_r
diff --git a/plugins/local/spher_harm/README.rst b/plugins/local/spher_harm/README.rst
new file mode 100644
index 00000000..bf897f73
--- /dev/null
+++ b/plugins/local/spher_harm/README.rst
@@ -0,0 +1,4 @@
+==========
+spher_harm
+==========
+
diff --git a/plugins/local/spher_harm/assoc_gaus_pol.irp.f b/plugins/local/spher_harm/assoc_gaus_pol.irp.f
new file mode 100644
index 00000000..fa790307
--- /dev/null
+++ b/plugins/local/spher_harm/assoc_gaus_pol.irp.f
@@ -0,0 +1,50 @@
+double precision function plgndr(l,m,x)
+ integer, intent(in) :: l,m
+ double precision, intent(in) :: x
+ BEGIN_DOC
+ ! associated Legenre polynom P_l,m(x). Used for the Y_lm(theta,phi)
+ ! Taken from https://iate.oac.uncor.edu/~mario/materia/nr/numrec/f6-8.pdf
+ END_DOC
+ integer :: i,ll
+ double precision :: fact,pll,pmm,pmmp1,somx2
+ if(m.lt.0.or.m.gt.l.or.dabs(x).gt.1.d0)then
+ print*,'bad arguments in plgndr'
+ pause
+ endif
+ pmm=1.d0
+ if(m.gt.0) then
+ somx2=dsqrt((1.d0-x)*(1.d0+x))
+ fact=1.d0
+ do i=1,m
+ pmm=-pmm*fact*somx2
+ fact=fact+2.d0
+ enddo
+ endif ! m > 0
+ if(l.eq.m) then
+ plgndr=pmm
+ else
+ pmmp1=x*(2*m+1)*pmm ! Compute P_m+1^m
+ if(l.eq.m+1) then
+ plgndr=pmmp1
+ else ! Compute P_l^m, l> m+1
+ do ll=m+2,l
+ pll=(x*dble(2*ll-1)*pmmp1-dble(ll+m-1)*pmm)/(ll-m)
+ pmm=pmmp1
+ pmmp1=pll
+ enddo
+ plgndr=pll
+ endif ! l.eq.m+1
+ endif ! l.eq.m
+ return
+end
+
+double precision function ortho_assoc_gaus_pol(l1,m1,l2)
+ implicit none
+ integer, intent(in) :: l1,m1,l2
+ double precision :: fact
+ if(l1.ne.l2)then
+ ortho_assoc_gaus_pol= 0.d0
+ else
+ ortho_assoc_gaus_pol = 2.d0*fact(l1+m1) / (dble(2*l1+1)*fact(l1-m1))
+ endif
+end
diff --git a/plugins/local/spher_harm/spher_harm.irp.f b/plugins/local/spher_harm/spher_harm.irp.f
new file mode 100644
index 00000000..40661db1
--- /dev/null
+++ b/plugins/local/spher_harm/spher_harm.irp.f
@@ -0,0 +1,217 @@
+program spher_harm
+ implicit none
+ call test_spher_harm
+! call test_cart
+! call test_brutal_spheric
+end
+
+subroutine test_cart
+ implicit none
+ include 'constants.include.F'
+ double precision :: r(3),theta,phi,r_abs
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+end
+
+subroutine test_spher_harm
+ implicit none
+ include 'constants.include.F'
+ integer :: l1,m1,i,l2,m2,lmax
+ double precision :: r(3),weight,accu_re, accu_im,accu
+ double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
+ l1 = 0
+ m1 = 0
+ l2 = 0
+ m2 = 0
+ lmax = 5
+ do l1 = 0,lmax
+ do m1 = -l1 ,l1
+ do l2 = 0,lmax
+ do m2 = -l2 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ ! = \int dOmega Y_l1,m1^* Y_l2,m2
+ ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
+ ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu = 0.d0
+ do i = 1, n_points_integration_angular
+ double precision :: theta,phi,r_abs
+ r(1:3) = angular_quadrature_points(i,1:3)
+ weight = weights_angular_points(i)
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ if(theta.gt.pi.or.theta.lt.0.d0)then
+ print*,'pb with theta',theta
+ print*,r
+ endif
+ if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
+ print*,'pb with phi',phi/pi
+ print*,r
+ endif
+ call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
+ call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
+! call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ write(33,'(10(F16.10,X))')phi/pi
+ enddo
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ double precision :: x,dx,xmax,xmin
+ integer:: nx
+ nx = 10000
+ xmin = -5.d0
+ xmax = 5.d0
+ dx = (xmax - xmin)/dble(nx)
+ x = xmin
+ do i = 1, nx
+ write(34,*)x,datan(x),dacos(x)
+ x += dx
+ enddo
+end
+
+subroutine test_brutal_spheric
+ implicit none
+ include 'constants.include.F'
+ integer :: itheta, iphi,ntheta,nphi
+ double precision :: theta_min, theta_max, dtheta,theta
+ double precision :: phi_min, phi_max, dphi,phi
+ double precision :: accu_re, accu_im,weight
+ double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
+ integer :: l1,m1,i,l2,m2,lmax
+ phi_min = 0.d0
+ phi_max = 2.D0 * pi
+ theta_min = 0.d0
+ theta_max = 1.D0 * pi
+ ntheta = 1000
+ nphi = 1000
+ dphi = (phi_max - phi_min)/dble(nphi)
+ dtheta = (theta_max - theta_min)/dble(ntheta)
+
+ lmax = 3
+ do l1 = 0,lmax
+ do m1 = 0 ,l1
+ do l2 = 0,lmax
+ do m2 = 0 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ accu = 0.d0
+ theta = theta_min
+ do itheta = 1, ntheta
+ phi = phi_min
+ do iphi = 1, nphi
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+ call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ weight = dtheta * dphi * dsin(theta)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ phi += dphi
+ enddo
+ theta += dtheta
+ enddo
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ print*,'accu = ',accu
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+end
+
+subroutine test_assoc_leg_pol
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+ integer :: l1,m1,ngrid,i,l2,m2
+ l1 = 0
+ m1 = 0
+ l2 = 2
+ m2 = 0
+ double precision :: x, dx,xmax,accu,xmin
+ double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
+ ngrid = 100000
+ xmax = 1.d0
+ xmin = -1.d0
+ dx = (xmax-xmin)/dble(ngrid)
+ do l2 = 0,10
+ x = xmin
+ accu = 0.d0
+ do i = 1, ngrid
+ func_1 = plgndr(l1,m1,x)
+ func_2 = plgndr(l2,m2,x)
+ write(33,*)x, func_1,func_2
+ accu += func_1 * func_2 * dx
+ x += dx
+ enddo
+ print*,'l2 = ',l2
+ print*,'accu = ',accu
+ print*,ortho_assoc_gaus_pol(l1,m1,l2)
+ enddo
+end
diff --git a/plugins/local/spher_harm/spher_harm_func.irp.f b/plugins/local/spher_harm/spher_harm_func.irp.f
new file mode 100644
index 00000000..825bd8ac
--- /dev/null
+++ b/plugins/local/spher_harm/spher_harm_func.irp.f
@@ -0,0 +1,151 @@
+subroutine spher_harm_func_r3(r,l,m,re_ylm, im_ylm)
+ implicit none
+ integer, intent(in) :: l,m
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: re_ylm, im_ylm
+
+ double precision :: theta, phi,r_abs
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ call spher_harm_func(l,m,theta,phi,re_ylm, im_ylm)
+end
+
+
+subroutine spher_harm_func_m_pos(l,m,theta,phi,re_ylm, im_ylm)
+ include 'constants.include.F'
+ implicit none
+ BEGIN_DOC
+! Y_lm(theta,phi) with m >0
+!
+ END_DOC
+ double precision, intent(in) :: theta, phi
+ integer, intent(in) :: l,m
+ double precision, intent(out):: re_ylm,im_ylm
+ double precision :: prefact,fact,cos_theta,plgndr,p_lm
+ double precision :: tmp
+ prefact = dble(2*l+1)*fact(l-m)/(dfour_pi * fact(l+m))
+ prefact = dsqrt(prefact)
+ cos_theta = dcos(theta)
+ p_lm = plgndr(l,m,cos_theta)
+ tmp = prefact * p_lm
+ re_ylm = dcos(dble(m)*phi) * tmp
+ im_ylm = dsin(dble(m)*phi) * tmp
+end
+
+subroutine spher_harm_func(l,m,theta,phi,re_ylm, im_ylm)
+ implicit none
+ BEGIN_DOC
+ ! Y_lm(theta,phi) with -l l in spher_harm_func !! stopping ...'
+ stop
+ endif
+ if(m.ge.0)then
+ call spher_harm_func_m_pos(l,m,theta,phi,re_ylm_pos, im_ylm_pos)
+ re_ylm = re_ylm_pos
+ im_ylm = im_ylm_pos
+ else
+ minus_m = -m !> 0
+ call spher_harm_func_m_pos(l,minus_m,theta,phi,re_ylm_pos, im_ylm_pos)
+ tmp = (-1)**minus_m
+ re_ylm = tmp * re_ylm_pos
+ im_ylm = -tmp * im_ylm_pos ! complex conjugate
+ endif
+end
+
+subroutine cartesian_to_spherical(r,theta,phi,r_abs)
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out):: theta, phi,r_abs
+ double precision :: r_2,x_2_y_2,tmp
+ include 'constants.include.F'
+ x_2_y_2 = r(1)*r(1) + r(2)*r(2)
+ r_2 = x_2_y_2 + r(3)*r(3)
+ r_abs = dsqrt(r_2)
+
+ if(r_abs.gt.1.d-20)then
+ theta = dacos(r(3)/r_abs)
+ else
+ theta = 0.d0
+ endif
+
+ if(.true.)then
+ if(dabs(r(1)).gt.0.d0)then
+ tmp = datan(r(2)/r(1))
+! phi = datan2(r(2),r(1))
+ endif
+ ! From Wikipedia on Spherical Harmonics
+ if(r(1).gt.0.d0)then
+ phi = tmp
+ else if(r(1).lt.0.d0.and.r(2).ge.0.d0)then
+ phi = tmp + pi
+ else if(r(1).lt.0.d0.and.r(2).lt.0.d0)then
+ phi = tmp - pi
+ else if(r(1)==0.d0.and.r(2).gt.0.d0)then
+ phi = 0.5d0*pi
+ else if(r(1)==0.d0.and.r(2).lt.0.d0)then
+ phi =-0.5d0*pi
+ else if(r(1)==0.d0.and.r(2)==0.d0)then
+ phi = 0.d0
+ endif
+ if(r(2).lt.0.d0.and.r(1).le.0.d0)then
+ tmp = pi - dabs(phi)
+ phi = pi + tmp
+ else if(r(2).lt.0.d0.and.r(1).gt.0.d0)then
+ phi = dtwo_pi + phi
+ endif
+ endif
+
+ if(.false.)then
+ x_2_y_2 = dsqrt(x_2_y_2)
+ if(dabs(x_2_y_2).gt.1.d-20.and.dabs(r(2)).gt.1.d-20)then
+ phi = dabs(r(2))/r(2) * dacos(r(1)/x_2_y_2)
+ else
+ phi = 0.d0
+ endif
+ endif
+end
+
+
+subroutine spher_harm_func_expl(l,m,theta,phi,re_ylm, im_ylm)
+ implicit none
+ BEGIN_DOC
+ ! Y_lm(theta,phi) with -l
Date: Wed, 24 Apr 2024 14:48:23 +0200
Subject: [PATCH 107/140] Begining to make some cleaning in TC
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 22 +++++++++++++++++++
plugins/local/mo_localization/README.md | 2 +-
.../normal_ordered.irp.f | 0
.../normal_ordered_contractions.irp.f | 0
.../normal_ordered_old.irp.f | 0
.../normal_ordered_v0.irp.f | 0
.../h_biortho.irp.f | 0
.../h_mat_triple.irp.f | 0
.../h_tc_bi_ortho_psi.irp.f | 0
.../h_tc_s2_u0.irp.f | 0
.../slater_tc_3e_slow.irp.f | 0
.../slater_tc_opt.irp.f | 0
.../slater_tc_opt_diag.irp.f | 0
.../slater_tc_opt_double.irp.f | 0
.../slater_tc_opt_single.irp.f | 0
.../slater_tc_slow.irp.f | 0
.../{tc_bi_ortho => slater_tc}/tc_hmat.irp.f | 0
plugins/local/tc_bi_ortho/NEED | 6 +----
18 files changed, 24 insertions(+), 6 deletions(-)
rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered.irp.f (100%)
rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_contractions.irp.f (100%)
rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_old.irp.f (100%)
rename plugins/local/{tc_bi_ortho => normal_order_old}/normal_ordered_v0.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/h_biortho.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/h_mat_triple.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/h_tc_bi_ortho_psi.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/h_tc_s2_u0.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_3e_slow.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_diag.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_double.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_opt_single.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/slater_tc_slow.irp.f (100%)
rename plugins/local/{tc_bi_ortho => slater_tc}/tc_hmat.irp.f (100%)
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 5e6a24e9..42a7ba62 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -176,6 +176,28 @@ BEGIN_PROVIDER [double precision, mo_bi_ortho_tc_two_e, (mo_num, mo_num, mo_num,
END_PROVIDER
+BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num, mo_num, mo_num)]
+ implicit none
+ BEGIN_DOC
+ !
+ ! mo_bi_ortho_tc_two_e_transp(i,j,k,l) = = transpose of mo_bi_ortho_tc_two_e
+ !
+ ! the potential V(r_12) contains ALL TWO-E CONTRIBUTION OF THE TC-HAMILTONIAN
+ !
+ END_DOC
+
+ integer :: i,j,k,l
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e_transp(k,l,i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+
+END_PROVIDER
! ---
BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_jj, (mo_num,mo_num)]
diff --git a/plugins/local/mo_localization/README.md b/plugins/local/mo_localization/README.md
index c28a5ee1..512e36af 100644
--- a/plugins/local/mo_localization/README.md
+++ b/plugins/local/mo_localization/README.md
@@ -3,7 +3,7 @@ To localize the MOs:
```
qp run localization
```
-By default, the different otbital classes are automatically set by splitting
+By default, the different orbital classes are automatically set by splitting
the orbitales in the following classes:
- Core -> Core
- Active, doubly occupied -> Inactive
diff --git a/plugins/local/tc_bi_ortho/normal_ordered.irp.f b/plugins/local/normal_order_old/normal_ordered.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered.irp.f
rename to plugins/local/normal_order_old/normal_ordered.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f b/plugins/local/normal_order_old/normal_ordered_contractions.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_contractions.irp.f
rename to plugins/local/normal_order_old/normal_ordered_contractions.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_old.irp.f b/plugins/local/normal_order_old/normal_ordered_old.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_old.irp.f
rename to plugins/local/normal_order_old/normal_ordered_old.irp.f
diff --git a/plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f b/plugins/local/normal_order_old/normal_ordered_v0.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/normal_ordered_v0.irp.f
rename to plugins/local/normal_order_old/normal_ordered_v0.irp.f
diff --git a/plugins/local/tc_bi_ortho/h_biortho.irp.f b/plugins/local/slater_tc/h_biortho.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_biortho.irp.f
rename to plugins/local/slater_tc/h_biortho.irp.f
diff --git a/plugins/local/tc_bi_ortho/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_mat_triple.irp.f
rename to plugins/local/slater_tc/h_mat_triple.irp.f
diff --git a/plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f b/plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_tc_bi_ortho_psi.irp.f
rename to plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f
diff --git a/plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f b/plugins/local/slater_tc/h_tc_s2_u0.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/h_tc_s2_u0.irp.f
rename to plugins/local/slater_tc/h_tc_s2_u0.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f b/plugins/local/slater_tc/slater_tc_3e_slow.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_3e_slow.irp.f
rename to plugins/local/slater_tc/slater_tc_3e_slow.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_opt.irp.f
rename to plugins/local/slater_tc/slater_tc_opt.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_diag.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_diag.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f b/plugins/local/slater_tc/slater_tc_opt_double.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_double.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_double.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_opt_single.irp.f
rename to plugins/local/slater_tc/slater_tc_opt_single.irp.f
diff --git a/plugins/local/tc_bi_ortho/slater_tc_slow.irp.f b/plugins/local/slater_tc/slater_tc_slow.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/slater_tc_slow.irp.f
rename to plugins/local/slater_tc/slater_tc_slow.irp.f
diff --git a/plugins/local/tc_bi_ortho/tc_hmat.irp.f b/plugins/local/slater_tc/tc_hmat.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/tc_hmat.irp.f
rename to plugins/local/slater_tc/tc_hmat.irp.f
diff --git a/plugins/local/tc_bi_ortho/NEED b/plugins/local/tc_bi_ortho/NEED
index 9a0c20ef..01841e02 100644
--- a/plugins/local/tc_bi_ortho/NEED
+++ b/plugins/local/tc_bi_ortho/NEED
@@ -1,6 +1,2 @@
-bi_ort_ints
-bi_ortho_mos
-tc_keywords
-non_hermit_dav
-dav_general_mat
tc_scf
+slater_tc
From 05f35ab601a1f8ee17a3b55136bec92aefc96176 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 25 Apr 2024 20:00:42 +0200
Subject: [PATCH 108/140] Added properly the routines for the test of the
Spherical Harmonics
---
plugins/local/spher_harm/routines_test.irp.f | 227 +++++++++++++++++++
plugins/local/spher_harm/spher_harm.irp.f | 210 -----------------
2 files changed, 227 insertions(+), 210 deletions(-)
create mode 100644 plugins/local/spher_harm/routines_test.irp.f
diff --git a/plugins/local/spher_harm/routines_test.irp.f b/plugins/local/spher_harm/routines_test.irp.f
new file mode 100644
index 00000000..6f7cbc1c
--- /dev/null
+++ b/plugins/local/spher_harm/routines_test.irp.f
@@ -0,0 +1,227 @@
+
+subroutine test_cart
+ implicit none
+ BEGIN_DOC
+ ! test for the cartesian --> spherical change of coordinates
+ !
+ ! simple test such that the polar angle theta ranges in [0,pi]
+ !
+ ! and the asymuthal angle phi ranges in [0,2pi]
+ END_DOC
+ include 'constants.include.F'
+ double precision :: r(3),theta,phi,r_abs
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+end
+
+subroutine test_spher_harm
+ implicit none
+ BEGIN_DOC
+ ! routine to test the spherical harmonics integration on a sphere with the grid.
+ !
+ ! We test = delta_m1,m2 delta_l1,l2
+ END_DOC
+ include 'constants.include.F'
+ integer :: l1,m1,i,l2,m2,lmax
+ double precision :: r(3),weight,accu_re, accu_im,accu
+ double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
+ l1 = 0
+ m1 = 0
+ l2 = 0
+ m2 = 0
+ lmax = 5
+ do l1 = 0,lmax
+ do m1 = -l1 ,l1
+ do l2 = 0,lmax
+ do m2 = -l2 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ ! = \int dOmega Y_l1,m1^* Y_l2,m2
+ ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
+ ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu = 0.d0
+ do i = 1, n_points_integration_angular
+ double precision :: theta,phi,r_abs
+ r(1:3) = angular_quadrature_points(i,1:3)
+ weight = weights_angular_points(i)
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ if(theta.gt.pi.or.theta.lt.0.d0)then
+ print*,'pb with theta',theta
+ print*,r
+ endif
+ if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
+ print*,'pb with phi',phi/pi
+ print*,r
+ endif
+ call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
+ call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ write(33,'(10(F16.10,X))')phi/pi
+ enddo
+ ! Test for the delta l1,l2 and delta m1,m2
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ double precision :: x,dx,xmax,xmin
+ integer:: nx
+ nx = 10000
+ xmin = -5.d0
+ xmax = 5.d0
+ dx = (xmax - xmin)/dble(nx)
+ x = xmin
+ do i = 1, nx
+ write(34,*)x,datan(x),dacos(x)
+ x += dx
+ enddo
+end
+
+subroutine test_brutal_spheric
+ implicit none
+ include 'constants.include.F'
+ BEGIN_DOC
+ ! test for the = delta_m1,m2 delta_l1,l2 using a two dimentional integration
+ !
+ ! \int_0^2pi d Phi \int_-1^+1 d(cos(Theta)) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ != \int_0^2pi d Phi \int_0^pi dTheta sin(Theta) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ ! Allows to test for the general functions spher_harm_func_m_pos with spher_harm_func_expl
+ END_DOC
+ integer :: itheta, iphi,ntheta,nphi
+ double precision :: theta_min, theta_max, dtheta,theta
+ double precision :: phi_min, phi_max, dphi,phi
+ double precision :: accu_re, accu_im,weight
+ double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
+ integer :: l1,m1,i,l2,m2,lmax
+ phi_min = 0.d0
+ phi_max = 2.D0 * pi
+ theta_min = 0.d0
+ theta_max = 1.D0 * pi
+ ntheta = 1000
+ nphi = 1000
+ dphi = (phi_max - phi_min)/dble(nphi)
+ dtheta = (theta_max - theta_min)/dble(ntheta)
+
+ lmax = 3
+ do l1 = 0,lmax
+ do m1 = 0 ,l1
+ do l2 = 0,lmax
+ do m2 = 0 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ accu = 0.d0
+ theta = theta_min
+ do itheta = 1, ntheta
+ phi = phi_min
+ do iphi = 1, nphi
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+ call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ weight = dtheta * dphi * dsin(theta)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ phi += dphi
+ enddo
+ theta += dtheta
+ enddo
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ print*,'accu = ',accu
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+end
+
+subroutine test_assoc_leg_pol
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+ integer :: l1,m1,ngrid,i,l2,m2
+ l1 = 0
+ m1 = 0
+ l2 = 2
+ m2 = 0
+ double precision :: x, dx,xmax,accu,xmin
+ double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
+ ngrid = 100000
+ xmax = 1.d0
+ xmin = -1.d0
+ dx = (xmax-xmin)/dble(ngrid)
+ do l2 = 0,10
+ x = xmin
+ accu = 0.d0
+ do i = 1, ngrid
+ func_1 = plgndr(l1,m1,x)
+ func_2 = plgndr(l2,m2,x)
+ write(33,*)x, func_1,func_2
+ accu += func_1 * func_2 * dx
+ x += dx
+ enddo
+ print*,'l2 = ',l2
+ print*,'accu = ',accu
+ print*,ortho_assoc_gaus_pol(l1,m1,l2)
+ enddo
+end
diff --git a/plugins/local/spher_harm/spher_harm.irp.f b/plugins/local/spher_harm/spher_harm.irp.f
index 40661db1..e8deafb9 100644
--- a/plugins/local/spher_harm/spher_harm.irp.f
+++ b/plugins/local/spher_harm/spher_harm.irp.f
@@ -5,213 +5,3 @@ program spher_harm
! call test_brutal_spheric
end
-subroutine test_cart
- implicit none
- include 'constants.include.F'
- double precision :: r(3),theta,phi,r_abs
- print*,''
- r = 0.d0
- r(1) = 1.d0
- r(2) = 1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) =-1.d0
- r(2) = 1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) =-1.d0
- r(2) =-1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) = 1.d0
- r(2) =-1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
-end
-
-subroutine test_spher_harm
- implicit none
- include 'constants.include.F'
- integer :: l1,m1,i,l2,m2,lmax
- double precision :: r(3),weight,accu_re, accu_im,accu
- double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
- l1 = 0
- m1 = 0
- l2 = 0
- m2 = 0
- lmax = 5
- do l1 = 0,lmax
- do m1 = -l1 ,l1
- do l2 = 0,lmax
- do m2 = -l2 ,l2
- accu_re = 0.d0
- accu_im = 0.d0
- ! = \int dOmega Y_l1,m1^* Y_l2,m2
- ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
- ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu = 0.d0
- do i = 1, n_points_integration_angular
- double precision :: theta,phi,r_abs
- r(1:3) = angular_quadrature_points(i,1:3)
- weight = weights_angular_points(i)
- call cartesian_to_spherical(r,theta,phi,r_abs)
- if(theta.gt.pi.or.theta.lt.0.d0)then
- print*,'pb with theta',theta
- print*,r
- endif
- if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
- print*,'pb with phi',phi/pi
- print*,r
- endif
- call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
- call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
-! call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
- accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu += weight
- write(33,'(10(F16.10,X))')phi/pi
- enddo
- if(l1.ne.l2.or.m1.ne.m2)then
- if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb OFF DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- if(l1==l2.and.m1==m2)then
- if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- enddo
- enddo
- enddo
- enddo
- double precision :: x,dx,xmax,xmin
- integer:: nx
- nx = 10000
- xmin = -5.d0
- xmax = 5.d0
- dx = (xmax - xmin)/dble(nx)
- x = xmin
- do i = 1, nx
- write(34,*)x,datan(x),dacos(x)
- x += dx
- enddo
-end
-
-subroutine test_brutal_spheric
- implicit none
- include 'constants.include.F'
- integer :: itheta, iphi,ntheta,nphi
- double precision :: theta_min, theta_max, dtheta,theta
- double precision :: phi_min, phi_max, dphi,phi
- double precision :: accu_re, accu_im,weight
- double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
- integer :: l1,m1,i,l2,m2,lmax
- phi_min = 0.d0
- phi_max = 2.D0 * pi
- theta_min = 0.d0
- theta_max = 1.D0 * pi
- ntheta = 1000
- nphi = 1000
- dphi = (phi_max - phi_min)/dble(nphi)
- dtheta = (theta_max - theta_min)/dble(ntheta)
-
- lmax = 3
- do l1 = 0,lmax
- do m1 = 0 ,l1
- do l2 = 0,lmax
- do m2 = 0 ,l2
- accu_re = 0.d0
- accu_im = 0.d0
- accu = 0.d0
- theta = theta_min
- do itheta = 1, ntheta
- phi = phi_min
- do iphi = 1, nphi
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
- call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- weight = dtheta * dphi * dsin(theta)
- accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
- accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu += weight
- phi += dphi
- enddo
- theta += dtheta
- enddo
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- print*,'accu = ',accu
- if(l1.ne.l2.or.m1.ne.m2)then
- if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb OFF DIAG !!!!! '
- endif
- endif
- if(l1==l2.and.m1==m2)then
- if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb DIAG !!!!! '
- endif
- endif
- enddo
- enddo
- enddo
- enddo
-
-
-end
-
-subroutine test_assoc_leg_pol
- implicit none
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
- print *, 'Hello world'
- integer :: l1,m1,ngrid,i,l2,m2
- l1 = 0
- m1 = 0
- l2 = 2
- m2 = 0
- double precision :: x, dx,xmax,accu,xmin
- double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
- ngrid = 100000
- xmax = 1.d0
- xmin = -1.d0
- dx = (xmax-xmin)/dble(ngrid)
- do l2 = 0,10
- x = xmin
- accu = 0.d0
- do i = 1, ngrid
- func_1 = plgndr(l1,m1,x)
- func_2 = plgndr(l2,m2,x)
- write(33,*)x, func_1,func_2
- accu += func_1 * func_2 * dx
- x += dx
- enddo
- print*,'l2 = ',l2
- print*,'accu = ',accu
- print*,ortho_assoc_gaus_pol(l1,m1,l2)
- enddo
-end
From c3483df9a16003065a41bfa92d37274a3eb466ee Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 25 Apr 2024 20:00:42 +0200
Subject: [PATCH 109/140] Added properly the routines for the test of the
Spherical Harmonics
---
plugins/local/spher_harm/routines_test.irp.f | 227 +++++++++++++++++++
plugins/local/spher_harm/spher_harm.irp.f | 210 -----------------
2 files changed, 227 insertions(+), 210 deletions(-)
create mode 100644 plugins/local/spher_harm/routines_test.irp.f
diff --git a/plugins/local/spher_harm/routines_test.irp.f b/plugins/local/spher_harm/routines_test.irp.f
new file mode 100644
index 00000000..6f7cbc1c
--- /dev/null
+++ b/plugins/local/spher_harm/routines_test.irp.f
@@ -0,0 +1,227 @@
+
+subroutine test_cart
+ implicit none
+ BEGIN_DOC
+ ! test for the cartesian --> spherical change of coordinates
+ !
+ ! simple test such that the polar angle theta ranges in [0,pi]
+ !
+ ! and the asymuthal angle phi ranges in [0,2pi]
+ END_DOC
+ include 'constants.include.F'
+ double precision :: r(3),theta,phi,r_abs
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) = 1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) =-1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+ print*,''
+ r = 0.d0
+ r(1) = 1.d0
+ r(2) =-1.d0
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ print*,r
+ print*,phi/pi
+end
+
+subroutine test_spher_harm
+ implicit none
+ BEGIN_DOC
+ ! routine to test the spherical harmonics integration on a sphere with the grid.
+ !
+ ! We test = delta_m1,m2 delta_l1,l2
+ END_DOC
+ include 'constants.include.F'
+ integer :: l1,m1,i,l2,m2,lmax
+ double precision :: r(3),weight,accu_re, accu_im,accu
+ double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
+ l1 = 0
+ m1 = 0
+ l2 = 0
+ m2 = 0
+ lmax = 5
+ do l1 = 0,lmax
+ do m1 = -l1 ,l1
+ do l2 = 0,lmax
+ do m2 = -l2 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ ! = \int dOmega Y_l1,m1^* Y_l2,m2
+ ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
+ ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu = 0.d0
+ do i = 1, n_points_integration_angular
+ double precision :: theta,phi,r_abs
+ r(1:3) = angular_quadrature_points(i,1:3)
+ weight = weights_angular_points(i)
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ if(theta.gt.pi.or.theta.lt.0.d0)then
+ print*,'pb with theta',theta
+ print*,r
+ endif
+ if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
+ print*,'pb with phi',phi/pi
+ print*,r
+ endif
+ call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
+ call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ write(33,'(10(F16.10,X))')phi/pi
+ enddo
+ ! Test for the delta l1,l2 and delta m1,m2
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ double precision :: x,dx,xmax,xmin
+ integer:: nx
+ nx = 10000
+ xmin = -5.d0
+ xmax = 5.d0
+ dx = (xmax - xmin)/dble(nx)
+ x = xmin
+ do i = 1, nx
+ write(34,*)x,datan(x),dacos(x)
+ x += dx
+ enddo
+end
+
+subroutine test_brutal_spheric
+ implicit none
+ include 'constants.include.F'
+ BEGIN_DOC
+ ! test for the = delta_m1,m2 delta_l1,l2 using a two dimentional integration
+ !
+ ! \int_0^2pi d Phi \int_-1^+1 d(cos(Theta)) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ != \int_0^2pi d Phi \int_0^pi dTheta sin(Theta) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
+ !
+ ! Allows to test for the general functions spher_harm_func_m_pos with spher_harm_func_expl
+ END_DOC
+ integer :: itheta, iphi,ntheta,nphi
+ double precision :: theta_min, theta_max, dtheta,theta
+ double precision :: phi_min, phi_max, dphi,phi
+ double precision :: accu_re, accu_im,weight
+ double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
+ integer :: l1,m1,i,l2,m2,lmax
+ phi_min = 0.d0
+ phi_max = 2.D0 * pi
+ theta_min = 0.d0
+ theta_max = 1.D0 * pi
+ ntheta = 1000
+ nphi = 1000
+ dphi = (phi_max - phi_min)/dble(nphi)
+ dtheta = (theta_max - theta_min)/dble(ntheta)
+
+ lmax = 3
+ do l1 = 0,lmax
+ do m1 = 0 ,l1
+ do l2 = 0,lmax
+ do m2 = 0 ,l2
+ accu_re = 0.d0
+ accu_im = 0.d0
+ accu = 0.d0
+ theta = theta_min
+ do itheta = 1, ntheta
+ phi = phi_min
+ do iphi = 1, nphi
+! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
+ call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
+ weight = dtheta * dphi * dsin(theta)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ phi += dphi
+ enddo
+ theta += dtheta
+ enddo
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ print*,'accu = ',accu
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ endif
+ endif
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+
+end
+
+subroutine test_assoc_leg_pol
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+ integer :: l1,m1,ngrid,i,l2,m2
+ l1 = 0
+ m1 = 0
+ l2 = 2
+ m2 = 0
+ double precision :: x, dx,xmax,accu,xmin
+ double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
+ ngrid = 100000
+ xmax = 1.d0
+ xmin = -1.d0
+ dx = (xmax-xmin)/dble(ngrid)
+ do l2 = 0,10
+ x = xmin
+ accu = 0.d0
+ do i = 1, ngrid
+ func_1 = plgndr(l1,m1,x)
+ func_2 = plgndr(l2,m2,x)
+ write(33,*)x, func_1,func_2
+ accu += func_1 * func_2 * dx
+ x += dx
+ enddo
+ print*,'l2 = ',l2
+ print*,'accu = ',accu
+ print*,ortho_assoc_gaus_pol(l1,m1,l2)
+ enddo
+end
diff --git a/plugins/local/spher_harm/spher_harm.irp.f b/plugins/local/spher_harm/spher_harm.irp.f
index 40661db1..e8deafb9 100644
--- a/plugins/local/spher_harm/spher_harm.irp.f
+++ b/plugins/local/spher_harm/spher_harm.irp.f
@@ -5,213 +5,3 @@ program spher_harm
! call test_brutal_spheric
end
-subroutine test_cart
- implicit none
- include 'constants.include.F'
- double precision :: r(3),theta,phi,r_abs
- print*,''
- r = 0.d0
- r(1) = 1.d0
- r(2) = 1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) =-1.d0
- r(2) = 1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) =-1.d0
- r(2) =-1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
- print*,''
- r = 0.d0
- r(1) = 1.d0
- r(2) =-1.d0
- call cartesian_to_spherical(r,theta,phi,r_abs)
- print*,r
- print*,phi/pi
-end
-
-subroutine test_spher_harm
- implicit none
- include 'constants.include.F'
- integer :: l1,m1,i,l2,m2,lmax
- double precision :: r(3),weight,accu_re, accu_im,accu
- double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
- l1 = 0
- m1 = 0
- l2 = 0
- m2 = 0
- lmax = 5
- do l1 = 0,lmax
- do m1 = -l1 ,l1
- do l2 = 0,lmax
- do m2 = -l2 ,l2
- accu_re = 0.d0
- accu_im = 0.d0
- ! = \int dOmega Y_l1,m1^* Y_l2,m2
- ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
- ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu = 0.d0
- do i = 1, n_points_integration_angular
- double precision :: theta,phi,r_abs
- r(1:3) = angular_quadrature_points(i,1:3)
- weight = weights_angular_points(i)
- call cartesian_to_spherical(r,theta,phi,r_abs)
- if(theta.gt.pi.or.theta.lt.0.d0)then
- print*,'pb with theta',theta
- print*,r
- endif
- if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
- print*,'pb with phi',phi/pi
- print*,r
- endif
- call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
- call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
-! call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
- accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu += weight
- write(33,'(10(F16.10,X))')phi/pi
- enddo
- if(l1.ne.l2.or.m1.ne.m2)then
- if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb OFF DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- if(l1==l2.and.m1==m2)then
- if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- enddo
- enddo
- enddo
- enddo
- double precision :: x,dx,xmax,xmin
- integer:: nx
- nx = 10000
- xmin = -5.d0
- xmax = 5.d0
- dx = (xmax - xmin)/dble(nx)
- x = xmin
- do i = 1, nx
- write(34,*)x,datan(x),dacos(x)
- x += dx
- enddo
-end
-
-subroutine test_brutal_spheric
- implicit none
- include 'constants.include.F'
- integer :: itheta, iphi,ntheta,nphi
- double precision :: theta_min, theta_max, dtheta,theta
- double precision :: phi_min, phi_max, dphi,phi
- double precision :: accu_re, accu_im,weight
- double precision :: re_ylm_1, im_ylm_1 ,re_ylm_2, im_ylm_2,accu
- integer :: l1,m1,i,l2,m2,lmax
- phi_min = 0.d0
- phi_max = 2.D0 * pi
- theta_min = 0.d0
- theta_max = 1.D0 * pi
- ntheta = 1000
- nphi = 1000
- dphi = (phi_max - phi_min)/dble(nphi)
- dtheta = (theta_max - theta_min)/dble(ntheta)
-
- lmax = 3
- do l1 = 0,lmax
- do m1 = 0 ,l1
- do l2 = 0,lmax
- do m2 = 0 ,l2
- accu_re = 0.d0
- accu_im = 0.d0
- accu = 0.d0
- theta = theta_min
- do itheta = 1, ntheta
- phi = phi_min
- do iphi = 1, nphi
-! call spher_harm_func_expl(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
-! call spher_harm_func_expl(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- call spher_harm_func_m_pos(l1,m1,theta,phi,re_ylm_1, im_ylm_1)
- call spher_harm_func_m_pos(l2,m2,theta,phi,re_ylm_2, im_ylm_2)
- weight = dtheta * dphi * dsin(theta)
- accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
- accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu += weight
- phi += dphi
- enddo
- theta += dtheta
- enddo
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- print*,'accu = ',accu
- if(l1.ne.l2.or.m1.ne.m2)then
- if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb OFF DIAG !!!!! '
- endif
- endif
- if(l1==l2.and.m1==m2)then
- if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb DIAG !!!!! '
- endif
- endif
- enddo
- enddo
- enddo
- enddo
-
-
-end
-
-subroutine test_assoc_leg_pol
- implicit none
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
- print *, 'Hello world'
- integer :: l1,m1,ngrid,i,l2,m2
- l1 = 0
- m1 = 0
- l2 = 2
- m2 = 0
- double precision :: x, dx,xmax,accu,xmin
- double precision :: plgndr,func_1,func_2,ortho_assoc_gaus_pol
- ngrid = 100000
- xmax = 1.d0
- xmin = -1.d0
- dx = (xmax-xmin)/dble(ngrid)
- do l2 = 0,10
- x = xmin
- accu = 0.d0
- do i = 1, ngrid
- func_1 = plgndr(l1,m1,x)
- func_2 = plgndr(l2,m2,x)
- write(33,*)x, func_1,func_2
- accu += func_1 * func_2 * dx
- x += dx
- enddo
- print*,'l2 = ',l2
- print*,'accu = ',accu
- print*,ortho_assoc_gaus_pol(l1,m1,l2)
- enddo
-end
From 5c69a7c005ecabe8428c386bf17bad3327891578 Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 26 Apr 2024 10:57:57 +0200
Subject: [PATCH 110/140] removed stupid stuffs in spher_harm
---
plugins/local/spher_harm/README.rst | 3 +
plugins/local/spher_harm/routines_test.irp.f | 172 ++++++++++---------
plugins/local/spher_harm/spher_harm.irp.f | 4 +-
3 files changed, 93 insertions(+), 86 deletions(-)
diff --git a/plugins/local/spher_harm/README.rst b/plugins/local/spher_harm/README.rst
index bf897f73..9c9b12a6 100644
--- a/plugins/local/spher_harm/README.rst
+++ b/plugins/local/spher_harm/README.rst
@@ -2,3 +2,6 @@
spher_harm
==========
+Routines for spherical Harmonics evaluation in real space.
+The main routine is "spher_harm_func_r3(r,l,m,re_ylm, im_ylm)".
+The test routine is "test_spher_harm" where everything is explained in details.
diff --git a/plugins/local/spher_harm/routines_test.irp.f b/plugins/local/spher_harm/routines_test.irp.f
index 6f7cbc1c..fe8fc422 100644
--- a/plugins/local/spher_harm/routines_test.irp.f
+++ b/plugins/local/spher_harm/routines_test.irp.f
@@ -1,10 +1,93 @@
+subroutine test_spher_harm
+ implicit none
+ BEGIN_DOC
+ ! routine to test the generic spherical harmonics routine "spher_harm_func_r3" from R^3 --> C
+ !
+ ! We test = delta_m1,m2 delta_l1,l2
+ !
+ ! The test is done through the integration on a sphere with the Lebedev grid.
+ END_DOC
+ include 'constants.include.F'
+ integer :: l1,m1,i,l2,m2,lmax
+ double precision :: r(3),weight,accu_re, accu_im,accu
+ double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
+ double precision :: theta,phi,r_abs
+ lmax = 5 ! Maximum angular momentum until which we are going to test orthogonality conditions
+ do l1 = 0,lmax
+ do m1 = -l1 ,l1
+ do l2 = 0,lmax
+ do m2 = -l2 ,l2
+ accu_re = 0.d0 ! accumulator for the REAL part of
+ accu_im = 0.d0 ! accumulator for the IMAGINARY part of
+ accu = 0.d0 ! accumulator for the weights ==> should be \int dOmega == 4 pi
+ ! = \int dOmega Y_l1,m1^* Y_l2,m2
+ ! \approx \sum_i W_i Y_l1,m1^*(r_i) Y_l2,m2(r_i) WITH r_i being on the spher of radius 1
+ do i = 1, n_points_integration_angular
+ r(1:3) = angular_quadrature_points(i,1:3) ! ith Lebedev point (x,y,z) on the sphere of radius 1
+ weight = weights_angular_points(i) ! associated Lebdev weight not necessarily positive
+
+!!!!!!!!!!! Test of the Cartesian --> Spherical coordinates
+ ! theta MUST belong to [0,pi] and phi to [0,2pi]
+ ! gets the cartesian to spherical change of coordinates
+ call cartesian_to_spherical(r,theta,phi,r_abs)
+ if(theta.gt.pi.or.theta.lt.0.d0)then
+ print*,'pb with theta, it should be in [0,pi]',theta
+ print*,r
+ endif
+ if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
+ print*,'pb with phi, it should be in [0,2 pi]',phi/pi
+ print*,r
+ endif
+
+!!!!!!!!!!! Routines returning the Spherical harmonics on the grid point
+ call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
+ call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
+
+!!!!!!!!!!! Integration of Y_l1,m1^*(r) Y_l2,m2(r)
+ ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
+ ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
+ accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
+ accu += weight
+ enddo
+ ! Test that the sum of the weights is 4 pi
+ if(dabs(accu - dfour_pi).gt.1.d-6)then
+ print*,'Problem !! The sum of the Lebedev weight is not 4 pi ..'
+ print*,accu
+ stop
+ endif
+ ! Test for the delta l1,l2 and delta m1,m2
+ !
+ ! Test for the off-diagonal part of the Kronecker delta
+ if(l1.ne.l2.or.m1.ne.m2)then
+ if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb OFF DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ ! Test for the diagonal part of the Kronecker delta
+ if(l1==l2.and.m1==m2)then
+ if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
+ print*,'pb DIAG !!!!! '
+ print*,'l1,m1,l2,m2',l1,m1,l2,m2
+ print*,'accu_re = ',accu_re
+ print*,'accu_im = ',accu_im
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+end
subroutine test_cart
implicit none
BEGIN_DOC
! test for the cartesian --> spherical change of coordinates
!
- ! simple test such that the polar angle theta ranges in [0,pi]
+ ! test the routine "cartesian_to_spherical" such that the polar angle theta ranges in [0,pi]
!
! and the asymuthal angle phi ranges in [0,2pi]
END_DOC
@@ -40,97 +123,18 @@ subroutine test_cart
print*,phi/pi
end
-subroutine test_spher_harm
- implicit none
- BEGIN_DOC
- ! routine to test the spherical harmonics integration on a sphere with the grid.
- !
- ! We test = delta_m1,m2 delta_l1,l2
- END_DOC
- include 'constants.include.F'
- integer :: l1,m1,i,l2,m2,lmax
- double precision :: r(3),weight,accu_re, accu_im,accu
- double precision :: re_ylm_1, im_ylm_1,re_ylm_2, im_ylm_2
- l1 = 0
- m1 = 0
- l2 = 0
- m2 = 0
- lmax = 5
- do l1 = 0,lmax
- do m1 = -l1 ,l1
- do l2 = 0,lmax
- do m2 = -l2 ,l2
- accu_re = 0.d0
- accu_im = 0.d0
- ! = \int dOmega Y_l1,m1^* Y_l2,m2
- ! = \int dOmega (re_ylm_1 -i im_ylm_1) * (re_ylm_2 +i im_ylm_2)
- ! = \int dOmega (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2) +i (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu = 0.d0
- do i = 1, n_points_integration_angular
- double precision :: theta,phi,r_abs
- r(1:3) = angular_quadrature_points(i,1:3)
- weight = weights_angular_points(i)
- call cartesian_to_spherical(r,theta,phi,r_abs)
- if(theta.gt.pi.or.theta.lt.0.d0)then
- print*,'pb with theta',theta
- print*,r
- endif
- if(phi.gt.2.d0*pi.or.phi.lt.0.d0)then
- print*,'pb with phi',phi/pi
- print*,r
- endif
- call spher_harm_func_r3(r,l1,m1,re_ylm_1, im_ylm_1)
- call spher_harm_func_r3(r,l2,m2,re_ylm_2, im_ylm_2)
- accu_re += weight * (re_ylm_1*re_ylm_2 + im_ylm_1*im_ylm_2)
- accu_im += weight * (im_ylm_2*re_ylm_1 - im_ylm_1*re_ylm_2)
- accu += weight
- write(33,'(10(F16.10,X))')phi/pi
- enddo
- ! Test for the delta l1,l2 and delta m1,m2
- if(l1.ne.l2.or.m1.ne.m2)then
- if(dabs(accu_re).gt.1.d-6.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb OFF DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- if(l1==l2.and.m1==m2)then
- if(dabs(accu_re-1.d0).gt.1.d-5.or.dabs(accu_im).gt.1.d-6)then
- print*,'pb DIAG !!!!! '
- print*,'l1,m1,l2,m2',l1,m1,l2,m2
- print*,'accu_re = ',accu_re
- print*,'accu_im = ',accu_im
- endif
- endif
- enddo
- enddo
- enddo
- enddo
- double precision :: x,dx,xmax,xmin
- integer:: nx
- nx = 10000
- xmin = -5.d0
- xmax = 5.d0
- dx = (xmax - xmin)/dble(nx)
- x = xmin
- do i = 1, nx
- write(34,*)x,datan(x),dacos(x)
- x += dx
- enddo
-end
subroutine test_brutal_spheric
implicit none
include 'constants.include.F'
BEGIN_DOC
- ! test for the = delta_m1,m2 delta_l1,l2 using a two dimentional integration
+ ! Test for the = delta_m1,m2 delta_l1,l2 using the following two dimentional integration
!
! \int_0^2pi d Phi \int_-1^+1 d(cos(Theta)) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
!
!= \int_0^2pi d Phi \int_0^pi dTheta sin(Theta) Y_l1,m1^*(Theta,Phi) Y_l2,m2(Theta,Phi)
!
- ! Allows to test for the general functions spher_harm_func_m_pos with spher_harm_func_expl
+ ! Allows to test for the general functions "spher_harm_func_m_pos" with "spher_harm_func_expl"
END_DOC
integer :: itheta, iphi,ntheta,nphi
double precision :: theta_min, theta_max, dtheta,theta
@@ -147,7 +151,7 @@ subroutine test_brutal_spheric
dphi = (phi_max - phi_min)/dble(nphi)
dtheta = (theta_max - theta_min)/dble(ntheta)
- lmax = 3
+ lmax = 2
do l1 = 0,lmax
do m1 = 0 ,l1
do l2 = 0,lmax
@@ -196,7 +200,7 @@ end
subroutine test_assoc_leg_pol
implicit none
BEGIN_DOC
-! TODO : Put the documentation of the program here
+! Test for the associated Legendre Polynoms. The test is done through the orthogonality condition.
END_DOC
print *, 'Hello world'
integer :: l1,m1,ngrid,i,l2,m2
diff --git a/plugins/local/spher_harm/spher_harm.irp.f b/plugins/local/spher_harm/spher_harm.irp.f
index e8deafb9..7a2eea06 100644
--- a/plugins/local/spher_harm/spher_harm.irp.f
+++ b/plugins/local/spher_harm/spher_harm.irp.f
@@ -1,7 +1,7 @@
program spher_harm
implicit none
- call test_spher_harm
+! call test_spher_harm
! call test_cart
-! call test_brutal_spheric
+ call test_brutal_spheric
end
From 40ea886cf1f6fe18d2501f1964e4f69deb66d947 Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 1 May 2024 19:00:02 +0200
Subject: [PATCH 111/140] added NEED in local/slater_tc
---
external/irpf90 | 2 +-
plugins/local/slater_tc/NEED | 7 +++++++
plugins/local/slater_tc/slater_tc.irp.f | 7 +++++++
3 files changed, 15 insertions(+), 1 deletion(-)
create mode 100644 plugins/local/slater_tc/NEED
create mode 100644 plugins/local/slater_tc/slater_tc.irp.f
diff --git a/external/irpf90 b/external/irpf90
index beac6153..4ab1b175 160000
--- a/external/irpf90
+++ b/external/irpf90
@@ -1 +1 @@
-Subproject commit beac615343f421bd6c0571a408ba389a6d5a32ac
+Subproject commit 4ab1b175fc7ed0d96c1912f13dc53579b24157a6
diff --git a/plugins/local/slater_tc/NEED b/plugins/local/slater_tc/NEED
new file mode 100644
index 00000000..ef0aa3f7
--- /dev/null
+++ b/plugins/local/slater_tc/NEED
@@ -0,0 +1,7 @@
+determinants
+normal_order_old
+bi_ort_ints
+bi_ortho_mos
+tc_keywords
+non_hermit_dav
+dav_general_mat
diff --git a/plugins/local/slater_tc/slater_tc.irp.f b/plugins/local/slater_tc/slater_tc.irp.f
new file mode 100644
index 00000000..27ab47c5
--- /dev/null
+++ b/plugins/local/slater_tc/slater_tc.irp.f
@@ -0,0 +1,7 @@
+program slater_tc
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+end
From 0465a0f4397a53daa5a3a1c8374a5e34f5b61c67 Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 1 May 2024 19:03:21 +0200
Subject: [PATCH 112/140] added local/normal_order_old/NEED
---
plugins/local/normal_order_old/NEED | 1 +
plugins/local/normal_order_old/README.rst | 4 ++++
2 files changed, 5 insertions(+)
create mode 100644 plugins/local/normal_order_old/NEED
create mode 100644 plugins/local/normal_order_old/README.rst
diff --git a/plugins/local/normal_order_old/NEED b/plugins/local/normal_order_old/NEED
new file mode 100644
index 00000000..8b137891
--- /dev/null
+++ b/plugins/local/normal_order_old/NEED
@@ -0,0 +1 @@
+
diff --git a/plugins/local/normal_order_old/README.rst b/plugins/local/normal_order_old/README.rst
new file mode 100644
index 00000000..a284fcfd
--- /dev/null
+++ b/plugins/local/normal_order_old/README.rst
@@ -0,0 +1,4 @@
+================
+normal_order_old
+================
+
From c50018e8bdbd0e11da5af2ddfe4032c7d6e86df2 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Wed, 1 May 2024 20:25:01 +0200
Subject: [PATCH 113/140] TC SPRING CLEANING: BEGINNING
---
.../bi_ort_ints/three_body_ints_bi_ort.irp.f | 2 +-
.../local/non_h_ints_mu/jast_1e_utils.irp.f | 18 +-
.../local/non_h_ints_mu/numerical_integ.irp.f | 6 +-
.../local/non_h_ints_mu/tc_integ_num.irp.f | 20 +-
.../local/non_h_ints_mu/test_non_h_ints.irp.f | 26 +-
plugins/local/non_hermit_dav/biorthog.irp.f | 1069 +----------------
.../lapack_diag_non_hermit.irp.f | 118 --
.../local/non_hermit_dav/new_routines.irp.f | 670 -----------
.../mu_j_ints_usual_mos.irp.f | 8 -
plugins/local/tc_bi_ortho/EZFIO.cfg | 11 +
.../local/tc_bi_ortho/print_tc_energy.irp.f | 30 +-
plugins/local/tc_bi_ortho/print_tc_var.irp.f | 5 +-
.../save_bitcpsileft_for_qmcchem.irp.f | 8 +-
plugins/local/tc_bi_ortho/tc_utils.irp.f | 89 +-
plugins/local/tc_scf/EZFIO.cfg | 4 +-
plugins/local/tc_scf/combine_lr_tcscf.irp.f | 75 --
plugins/local/tc_scf/diago_vartcfock.irp.f | 96 --
plugins/local/tc_scf/diis_tcscf.irp.f | 75 +-
.../local/tc_scf/fock_3e_bi_ortho_cs.irp.f | 299 -----
.../local/tc_scf/fock_3e_bi_ortho_os.irp.f | 536 ---------
.../local/tc_scf/fock_3e_bi_ortho_uhf.irp.f | 77 --
.../tc_scf/fock_3e_bi_ortho_uhf_old.irp.f | 490 --------
plugins/local/tc_scf/fock_tc.irp.f | 1000 +++++++++++++--
plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 11 +-
plugins/local/tc_scf/fock_vartc.irp.f | 287 -----
plugins/local/tc_scf/rh_tcscf_diis.irp.f | 4 +-
plugins/local/tc_scf/rh_tcscf_simple.irp.f | 2 +-
plugins/local/tc_scf/rh_vartcscf_simple.irp.f | 89 --
plugins/local/tc_scf/tc_scf.irp.f | 58 +-
plugins/local/tc_scf/tc_scf_energy.irp.f | 41 +-
plugins/local/tc_scf/test_int.irp.f | 970 ---------------
.../extra_grid_vector.irp.f | 11 -
.../grid_becke_vector.irp.f | 11 -
src/utils/util.irp.f | 80 +-
34 files changed, 1188 insertions(+), 5108 deletions(-)
delete mode 100644 plugins/local/non_hermit_dav/new_routines.irp.f
delete mode 100644 plugins/local/tc_scf/combine_lr_tcscf.irp.f
delete mode 100644 plugins/local/tc_scf/diago_vartcfock.irp.f
delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f
delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
delete mode 100644 plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f
delete mode 100644 plugins/local/tc_scf/fock_vartc.irp.f
delete mode 100644 plugins/local/tc_scf/rh_vartcscf_simple.irp.f
delete mode 100644 plugins/local/tc_scf/test_int.irp.f
diff --git a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
index fd4a162f..73e5a611 100644
--- a/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
+++ b/plugins/local/bi_ort_ints/three_body_ints_bi_ort.irp.f
@@ -123,7 +123,7 @@ subroutine give_integrals_3_body_bi_ort_spin( n, sigma_n, l, sigma_l, k, sigma_k
endif
return
-end subroutine give_integrals_3_body_bi_ort_spin
+end
! ---
diff --git a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
index 9cfabf58..c6b2b0a0 100644
--- a/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_1e_utils.irp.f
@@ -132,6 +132,7 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
double precision, allocatable :: A(:,:,:,:), b(:), A_tmp(:,:,:,:)
double precision, allocatable :: Pa(:,:), Pb(:,:), Pt(:,:)
double precision, allocatable :: u1e_tmp(:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:)
@@ -176,26 +177,27 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
! --- --- ---
! get A
- allocate(tmp(n_points_final_grid,ao_num,ao_num))
+ allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
allocate(A(ao_num,ao_num,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
- call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
, 0.d0, A(1,1,1,1), ao_num*ao_num)
allocate(A_tmp(ao_num,ao_num,ao_num,ao_num))
@@ -207,13 +209,13 @@ subroutine get_j1e_coef_fit_ao2(dim_fit, coef_fit)
allocate(b(ao_num*ao_num))
do ipoint = 1, n_points_final_grid
- u1e_tmp(ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * u1e_tmp(ipoint)
+ u1e_tmp(ipoint) = u1e_tmp(ipoint)
enddo
- call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
+ call dgemv("T", n_points_final_grid, ao_num*ao_num, 1.d0, tmp1(1,1,1), n_points_final_grid, u1e_tmp(1), 1, 0.d0, b(1), 1)
deallocate(u1e_tmp)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
! --- --- ---
! solve Ax = b
diff --git a/plugins/local/non_h_ints_mu/numerical_integ.irp.f b/plugins/local/non_h_ints_mu/numerical_integ.irp.f
index 5436b857..2737774a 100644
--- a/plugins/local/non_h_ints_mu/numerical_integ.irp.f
+++ b/plugins/local/non_h_ints_mu/numerical_integ.irp.f
@@ -179,7 +179,7 @@ double precision function num_v_ij_erf_rk_cst_mu_env(i, j, ipoint)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
@@ -228,7 +228,7 @@ subroutine num_x_v_ij_erf_rk_cst_mu_env(i, j, ipoint, integ)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp1 = (derf(mu_erf * r12) - 1.d0) / r12
@@ -530,7 +530,7 @@ subroutine num_int2_u_grad1u_total_env2(i, j, ipoint, integ)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dsqrt( dx * dx + dy * dy + dz * dz )
+ r12 = dsqrt(dx*dx + dy*dy + dz*dz)
if(r12 .lt. 1d-10) cycle
tmp0 = env_nucl(r2)
diff --git a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
index 6d446037..9d9601c0 100644
--- a/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
+++ b/plugins/local/non_h_ints_mu/tc_integ_num.irp.f
@@ -63,12 +63,10 @@
do i_pass = 1, n_pass
ii = (i_pass-1)*n_blocks + 1
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i_blocks, ipoint) &
- !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, &
- !$OMP final_grid_points, tmp_grad1_u12, &
- !$OMP tmp_grad1_u12_squared)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_blocks, ipoint) &
+ !$OMP SHARED (n_blocks, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
!$OMP DO
do i_blocks = 1, n_blocks
ipoint = ii - 1 + i_blocks ! r1
@@ -99,12 +97,10 @@
ii = n_pass*n_blocks + 1
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i_rest, ipoint) &
- !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, &
- !$OMP final_grid_points, tmp_grad1_u12, &
- !$OMP tmp_grad1_u12_squared)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i_rest, ipoint) &
+ !$OMP SHARED (n_rest, n_points_extra_final_grid, ii, final_grid_points, tmp_grad1_u12, tmp_grad1_u12_squared)
!$OMP DO
do i_rest = 1, n_rest
ipoint = ii - 1 + i_rest ! r1
diff --git a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
index 464a1c1f..4c63dec4 100644
--- a/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
+++ b/plugins/local/non_h_ints_mu/test_non_h_ints.irp.f
@@ -1125,6 +1125,7 @@ subroutine test_fit_coef_A1()
double precision :: accu, norm, diff
double precision, allocatable :: A1(:,:)
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
! ---
@@ -1165,16 +1166,17 @@ subroutine test_fit_coef_A1()
call wall_time(t1)
- allocate(tmp(ao_num,ao_num,n_points_final_grid))
+ allocate(tmp1(ao_num,ao_num,n_points_final_grid), tmp2(ao_num,ao_num,n_points_final_grid))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(i,j,ipoint) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(i,j,ipoint) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(i,j,ipoint) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
@@ -1184,9 +1186,9 @@ subroutine test_fit_coef_A1()
allocate(A2(ao_num,ao_num,ao_num,ao_num))
call dgemm( "N", "T", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), ao_num*ao_num, tmp(1,1,1), ao_num*ao_num &
+ , tmp1(1,1,1), ao_num*ao_num, tmp2(1,1,1), ao_num*ao_num &
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
call wall_time(t2)
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
@@ -1238,6 +1240,7 @@ subroutine test_fit_coef_inv()
double precision, allocatable :: A1(:,:), A1_inv(:,:), A1_tmp(:,:)
double precision, allocatable :: A2(:,:,:,:), tmp(:,:,:), A2_inv(:,:,:,:)
double precision, allocatable :: U(:,:), D(:), Vt(:,:), work(:), A2_tmp(:,:,:,:)
+ double precision, allocatable :: tmp1(:,:,:), tmp2(:,:,:)
cutoff_svd = 5d-8
@@ -1286,16 +1289,17 @@ subroutine test_fit_coef_inv()
call wall_time(t1)
- allocate(tmp(n_points_final_grid,ao_num,ao_num))
+ allocate(tmp1(n_points_final_grid,ao_num,ao_num), tmp2(n_points_final_grid,ao_num,ao_num))
!$OMP PARALLEL &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (i, j, ipoint) &
- !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp)
+ !$OMP SHARED (n_points_final_grid, ao_num, final_weight_at_r_vector, aos_in_r_array_transp, tmp1, tmp2)
!$OMP DO COLLAPSE(2)
do j = 1, ao_num
do i = 1, ao_num
do ipoint = 1, n_points_final_grid
- tmp(ipoint,i,j) = dsqrt(final_weight_at_r_vector(ipoint)) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp1(ipoint,i,j) = final_weight_at_r_vector(ipoint) * aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
+ tmp2(ipoint,i,j) = aos_in_r_array_transp(ipoint,i) * aos_in_r_array_transp(ipoint,j)
enddo
enddo
enddo
@@ -1304,11 +1308,11 @@ subroutine test_fit_coef_inv()
allocate(A2(ao_num,ao_num,ao_num,ao_num))
- call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
- , tmp(1,1,1), n_points_final_grid, tmp(1,1,1), n_points_final_grid &
+ call dgemm( "T", "N", ao_num*ao_num, ao_num*ao_num, n_points_final_grid, 1.d0 &
+ , tmp1(1,1,1), n_points_final_grid, tmp2(1,1,1), n_points_final_grid &
, 0.d0, A2(1,1,1,1), ao_num*ao_num)
- deallocate(tmp)
+ deallocate(tmp1, tmp2)
call wall_time(t2)
print*, ' WALL TIME FOR A2 (min) =', (t2-t1)/60.d0
diff --git a/plugins/local/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f
index 2229e17d..b36b0130 100644
--- a/plugins/local/non_hermit_dav/biorthog.irp.f
+++ b/plugins/local/non_hermit_dav/biorthog.irp.f
@@ -1,254 +1,3 @@
-subroutine non_hrmt_diag_split_degen(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- integer :: n_good
- double precision :: shift,shift_current
- double precision :: r,thr
- integer, allocatable :: list_good(:), iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
-
-
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- shift = 1.d-15
- shift_current = shift
- iteration = 1
- logical :: good_ortho
- good_ortho = .False.
- do while(n_real_eigv.ne.n.or. .not.good_ortho)
- if(shift.gt.1.d-3)then
- print*,'shift > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- print*,'***** iteration = ',iteration
- print*,'shift = ',shift
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- Aw = A_save
- do i = 1, n
- do j = 1, n
- if(dabs(Aw(j,i)).lt.shift)then
- Aw(j,i) = 0.d0
- endif
- enddo
- enddo
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- allocate(im_part(n),iorder(n))
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
-
- shift_current = max(10.d0 * dabs(im_part(1)),shift)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- Aw = A_save
- call split_matrix_degen(Aw,n,shift_current)
- deallocate( im_part, iorder )
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- ! You track the real eigenvalues
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_good += 1
- else
- print*,'Found an imaginary component to eigenvalue'
- print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- allocate( list_good(n_good), iorder(n_good) )
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
-
- ! You sort the real eigenvalues
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec_tmp(j,i) = VR(j,list_good(iorder(i)))
- leigvec_tmp(j,i) = Vl(j,list_good(iorder(i)))
- enddo
- enddo
-
- if(n_real_eigv == n)then
- allocate(S(n,n))
- call check_bi_ortho(reigvec_tmp,leigvec_tmp,n,S,accu_nd)
- print*,'accu_nd = ',accu_nd
- double precision :: accu_nd
- good_ortho = accu_nd .lt. 1.d-10
- deallocate(S)
- endif
-
- deallocate( list_good, iorder )
- deallocate( VL, VR, Aw)
- shift *= 10.d0
- iteration += 1
- enddo
- do i = 1, n
- do j = 1, n
- reigvec(iorder_origin(j),i) = reigvec_tmp(j,i)
- leigvec(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine non_hrmt_real_diag_new(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_good
- double precision :: shift,shift_current
- double precision :: r,thr
- integer, allocatable :: list_good(:), iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: im_part(:)
-
-
- print*,'Computing the left/right eigenvectors ...'
-
- ! Eigvalue(n) = WR(n) + i * WI(n)
- shift = 1.d-10
- do while(n_real_eigv.ne.n.or.shift.gt.1.d-3)
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- Aw = A
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- allocate(im_part(n), iorder(n))
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- shift_current = max(10.d0 * dabs(im_part(1)),shift)
- print*,'adding random number of magnitude ',shift_current
- Aw = A
- do i = 1, n
- call RANDOM_NUMBER(r)
- Aw(i,i) += shift_current * r
- enddo
- deallocate( im_part, iorder )
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
-
- ! You track the real eigenvalues
- thr = 1.d-10
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.thr)then
- n_good += 1
- else
- print*,'Found an imaginary component to eigenvalue'
- print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
-
- allocate( list_good(n_good), iorder(n_good) )
- n_good = 0
- do i = 1, n
- if(dabs(WI(i)).lt.thr)then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
-
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
-
- ! You sort the real eigenvalues
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec(j,i) = VR(j,list_good(iorder(i)))
- leigvec(j,i) = Vl(j,list_good(iorder(i)))
- enddo
- enddo
-
- deallocate( list_good, iorder )
- deallocate( VL, VR, Aw)
- shift *= 10.d0
- enddo
- if(shift.gt.1.d-3)then
- print*,'shift > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- endif
-
-end
! ---
@@ -282,126 +31,20 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
allocate(phi_1_tilde(n),phi_2_tilde(n),chi_1_tilde(n),chi_2_tilde(n))
-
- ! -------------------------------------------------------------------------------------
- !
-
- !print *, ' '
- !print *, ' Computing the left/right eigenvectors ...'
- !print *, ' '
-
allocate(WR(n), WI(n), VL(n,n), VR(n,n))
-
- !print *, ' fock matrix'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') A(i,:)
- !enddo
- !thr_cut = 1.d-15
- !call cancel_small_elmts(A, n, thr_cut)
-
- !call lapack_diag_non_sym_right(n, A, WR, WI, VR)
call lapack_diag_non_sym(n, A, WR, WI, VL, VR)
- !call lapack_diag_non_sym_new(n, A, WR, WI, VL, VR)
-
-
-
- !print *, ' '
- !print *, ' eigenvalues'
- i = 1
- do while(i .le. n)
- !write(*, '(I3,X,1000(F16.10,X))')i, WR(i), WI(i)
- if(.false.)then
- if(WI(i).ne.0.d0)then
- print*,'*****************'
- print*,'WARNING ! IMAGINARY EIGENVALUES !!!'
- write(*, '(1000(F16.10,X))') WR(i), WI(i+1)
- ! phi = VR(:,i), psi = VR(:,i+1), |Phi_i> = phi + j psi , |Phi_i+1> = phi - j psi
- ! chi = VL(:,i), xhi = VL(:,i+1), |Chi_i> = chi + j xhi , |Chi_i+1> = chi - j xhi
- !
- accu_chi_phi = 0.d0
- accu_xhi_psi = 0.d0
- accu_chi_psi = 0.d0
- accu_xhi_phi = 0.d0
- double precision :: accu_chi_phi, accu_xhi_psi, accu_chi_psi, accu_xhi_phi
- double precision :: mat_ovlp(2,2),eigval_tmp(2),eigvec(2,2),mat_ovlp_orig(2,2)
- do j = 1, n
- accu_chi_phi += VL(j,i) * VR(j,i)
- accu_xhi_psi += VL(j,i+1) * VR(j,i+1)
- accu_chi_psi += VL(j,i) * VR(j,i+1)
- accu_xhi_phi += VL(j,i+1) * VR(j,i)
- enddo
- mat_ovlp_orig(1,1) = accu_chi_phi
- mat_ovlp_orig(2,1) = accu_xhi_phi
- mat_ovlp_orig(1,2) = accu_chi_psi
- mat_ovlp_orig(2,2) = accu_xhi_psi
- print*,'old overlap matrix '
- write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,1)
- write(*,'(100(F16.10,X))')mat_ovlp_orig(1:2,2)
-
-
- mat_ovlp(1,1) = accu_xhi_phi
- mat_ovlp(2,1) = accu_chi_phi
- mat_ovlp(1,2) = accu_xhi_psi
- mat_ovlp(2,2) = accu_chi_psi
- !print*,'accu_chi_phi = ',accu_chi_phi
- !print*,'accu_xhi_psi = ',accu_xhi_psi
- !print*,'accu_chi_psi = ',accu_chi_psi
- !print*,'accu_xhi_phi = ',accu_xhi_phi
- print*,'new overlap matrix '
- write(*,'(100(F16.10,X))')mat_ovlp(1:2,1)
- write(*,'(100(F16.10,X))')mat_ovlp(1:2,2)
- call lapack_diag(eigval_tmp,eigvec,mat_ovlp,2,2)
- print*,'eigval_tmp(1) = ',eigval_tmp(1)
- print*,'eigvec(1) = ',eigvec(1:2,1)
- print*,'eigval_tmp(2) = ',eigval_tmp(2)
- print*,'eigvec(2) = ',eigvec(1:2,2)
- print*,'*****************'
- phi_1_tilde = 0.d0
- phi_2_tilde = 0.d0
- chi_1_tilde = 0.d0
- chi_2_tilde = 0.d0
- do j = 1, n
- phi_1_tilde(j) += VR(j,i) * eigvec(1,1) + VR(j,i+1) * eigvec(2,1)
- phi_2_tilde(j) += VR(j,i) * eigvec(1,2) + VR(j,i+1) * eigvec(2,2)
- chi_1_tilde(j) += VL(j,i+1) * eigvec(1,1) + VL(j,i) * eigvec(2,1)
- chi_2_tilde(j) += VL(j,i+1) * eigvec(1,2) + VL(j,i) * eigvec(2,2)
- enddo
- VR(1:n,i) = phi_1_tilde(1:n)
- VR(1:n,i+1) = phi_2_tilde(1:n)
-! Vl(1:n,i) = -chi_1_tilde(1:n)
-! Vl(1:n,i+1) = chi_2_tilde(1:n)
- i+=1
- endif
- endif
- i+=1
- enddo
- !print *, ' right eigenvect bef'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') VR(:,i)
- !enddo
- !print *, ' left eigenvect bef'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') VL(:,i)
- !enddo
thr_diag = 1d-06
thr_norm = 1d+10
- !call check_EIGVEC(n, n, A, WR, VL, VR, thr_diag, thr_norm, .false.)
-
- !
- ! -------------------------------------------------------------------------------------
! ---
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
+ ! track & sort the real eigenvalues
n_good = 0
- !thr = 100d0
thr = Im_thresh_tcscf
do i = 1, n
- !print*, 'Re(i) + Im(i)', WR(i), WI(i)
if(dabs(WI(i)) .lt. thr) then
n_good += 1
else
@@ -410,11 +53,12 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
endif
enddo
- if(n_good.ne.n)then
- print*,'there are some imaginary eigenvalues '
- thr_diag = 1d-03
- n_good = n
+ if(n_good.ne.n) then
+ print*,'there are some imaginary eigenvalues '
+ thr_diag = 1d-03
+ n_good = n
endif
+
allocate(list_good(n_good), iorder(n_good))
n_good = 0
@@ -446,26 +90,9 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
ASSERT(n==n_real_eigv)
- !print *, ' eigenvalues'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') eigval(i)
- !enddo
- !print *, ' right eigenvect aft ord'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') reigvec(:,i)
- !enddo
- !print *, ' left eigenvect aft ord'
- !do i = 1, n
- ! write(*, '(1000(F16.10,X))') leigvec(:,i)
- !enddo
-
- !
- ! -------------------------------------------------------------------------------------
-
! ---
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
+ ! check bi-orthogonality
thr_diag = 10.d0
thr_norm = 1d+10
@@ -495,8 +122,6 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
print *, ' lapack vectors are not normalized neither bi-orthogonalized'
- ! ---
-
allocate(deg_num(n))
call reorder_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
call impose_biorthog_degen_eigvec(n, deg_num, eigval, leigvec, reigvec)
@@ -508,700 +133,36 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
endif
call check_biorthog(n, n_real_eigv, leigvec, reigvec, accu_d, accu_nd, S, thr_d, thr_nd, .true.)
- !call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, thr_diag, thr_norm, .true.)
-
deallocate(S)
endif
- !
- ! -------------------------------------------------------------------------------------
-
return
end
! ---
-subroutine non_hrmt_bieig_random_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
+subroutine check_bi_ortho(reigvec, leigvec, n, S, accu_nd)
BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
+ ! retunrs the overlap matrix S = Leigvec^T Reigvec
!
+ ! and the square root of the sum of the squared off-diagonal elements of S
END_DOC
implicit none
integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
+ double precision, intent(in) :: reigvec(n,n), leigvec(n,n)
+ double precision, intent(out) :: S(n,n), accu_nd
- integer :: i, j
- integer :: n_good
- double precision :: thr
- double precision :: accu_nd
+ integer :: i,j
- integer, allocatable :: list_good(:), iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) )
-
- Aw(:,:) = A(:,:)
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
-
- thr = 1.d-12
- double precision, allocatable :: im_part(:)
- n_good = 0
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- else
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) + Im(i)', WR(i), WI(i)
- endif
- enddo
- print*,'n_good = ',n_good
- if(n_good .lt. n)then
- print*,'Removing degeneracies to remove imaginary parts'
- allocate(im_part(n),iorder(n))
- r = 0.d0
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part,iorder,n)
- thr = 10.d0 * dabs(im_part(1))
- print*,'adding random numbers on the diagonal of magnitude ',thr
- Aw(:,:) = A(:,:)
- do i = 1, n
- call RANDOM_NUMBER(r)
- print*,'r = ',r*thr
- Aw(i,i) += thr * r
- enddo
- print*,'Rediagonalizing the matrix with random numbers'
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
- deallocate(im_part,iorder)
- endif
- deallocate( Aw )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- n_good = 0
- thr = 1.d-5
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- else
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) + Im(i)', WR(i), WI(i)
- endif
- enddo
- print*,'n_good = ',n_good
- allocate( list_good(n_good), iorder(n_good) )
-
- n_good = 0
- do i = 1, n
- if( dabs(WI(i)).lt.thr ) then
- n_good += 1
- list_good(n_good) = i
- eigval(n_good) = WR(i)
- endif
- enddo
-
- deallocate( WR, WI )
-
- n_real_eigv = n_good
- do i = 1, n_good
- iorder(i) = i
- enddo
- call dsort(eigval, iorder, n_good)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n
- reigvec(j,i) = VR(j,list_good(iorder(i)))
- leigvec(j,i) = VL(j,list_good(iorder(i)))
- enddo
- enddo
-
- deallocate( list_good, iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n_real_eigv,n_real_eigv) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n_real_eigv, n_real_eigv, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n_real_eigv
- do j = 1, n_real_eigv
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- ! L x R is already bi-orthogonal
-
- print *, ' L & T bi-orthogonality: ok'
- deallocate( S )
- return
-
- else
- ! impose bi-orthogonality
-
- print *, ' L & T bi-orthogonality: not imposed yet'
- print *, ' accu_nd = ', accu_nd
- call impose_biorthog_qr(n, n_real_eigv, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
- deallocate( S )
-
- endif
-
- !
- ! -------------------------------------------------------------------------------------
-
- return
-
-end
-
-! ---
-
-subroutine non_hrmt_real_im(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the EIGENVALUES sorted the REAL part and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_bad
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), iorder(n))
-
- Aw(:,:) = A(:,:)
- do i = 1, n
- call RANDOM_NUMBER(r)
- Aw(i,i) += 10.d-10* r
- enddo
- call lapack_diag_non_sym(n, Aw, WR, WI, VL, VR)
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- i = 1
- thr = 1.d-15
- n_real_eigv = 0
- do while (i.le.n)
-! print*,i,dabs(WI(i))
- if( dabs(WI(i)).gt.thr ) then
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) , Im(i) ', WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- print*, 'Re(i+1),Im(i+1)',WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- else
- n_real_eigv += 1
- iorder(i) = i
- eigval(i) = WR(i)
- i+=1
- endif
- enddo
- call dsort(eigval, iorder, n)
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- deallocate( S )
-
-end
-
-! ---
-
-subroutine non_hrmt_generalized_real_im(n, A, B, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the EIGENVALUES sorted the REAL part and corresponding LEFT/RIGHT eigenvetors
- ! for A R = lambda B R and A^\dagger L = lambda B^\dagger L
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n),B(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_bad
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:),Bw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:), beta(:)
- double precision, allocatable :: S(:,:)
- double precision :: r
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n), Bw(n,n),iorder(n),beta(n))
-
- Aw(:,:) = A(:,:)
- Bw(:,:) = B(:,:)
- call lapack_diag_general_non_sym(n,Aw,Bw,WR,beta,WI,VL,VR)
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- i = 1
- thr = 1.d-10
- n_real_eigv = 0
- do while (i.le.n)
- if( dabs(WI(i)).gt.thr ) then
- print*, 'Found an imaginary component to eigenvalue on i = ', i
- print*, 'Re(i) , Im(i) ', WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- print*, 'Re(i+1),Im(i+1)',WR(i), WI(i)
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- else
- n_real_eigv += 1
- iorder(i) = i
- eigval(i) = WR(i)/(beta(i) + 1.d-10)
- i+=1
- endif
- enddo
- call dsort(eigval, iorder, n)
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( iorder )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- deallocate( S )
-
-end
-
-! ---
-
-subroutine non_hrmt_bieig_fullvect(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
-
- integer :: i, j
- integer :: n_good
- double precision :: thr
- double precision :: accu_nd
-
- integer, allocatable :: iorder(:)
- double precision, allocatable :: Aw(:,:)
- double precision, allocatable :: WR(:), WI(:), VL(:,:), VR(:,:)
- double precision, allocatable :: S(:,:)
- double precision, allocatable :: eigval_sorted(:)
-
-
- ! -------------------------------------------------------------------------------------
- !
-
- print *, 'Computing the left/right eigenvectors ...'
-
- allocate( WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n) )
- Aw(:,:) = A(:,:)
-
- call lapack_diag_non_sym_new(n, Aw, WR, WI, VL, VR)
-
- deallocate( Aw )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! track & sort the real eigenvalues
-
- allocate( eigval_sorted(n), iorder(n) )
-
- n_good = 0
- thr = 1.d-10
-
- do i = 1, n
-
- iorder(i) = i
- eigval_sorted(i) = WR(i)
-
- if(dabs(WI(i)) .gt. thr) then
- print*, ' Found an imaginary component to eigenvalue on i = ', i
- print*, ' Re(i) + Im(i)', WR(i), WI(i)
- else
- n_good += 1
- endif
-
- enddo
-
- n_real_eigv = n_good
-
- call dsort(eigval_sorted, iorder, n)
-
- reigvec(:,:) = 0.d0
- leigvec(:,:) = 0.d0
- do i = 1, n
- eigval(i) = WR(i)
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
-
- deallocate( eigval_sorted, iorder )
- deallocate( WR, WI )
- deallocate( VL, VR )
-
- !
- ! -------------------------------------------------------------------------------------
-
- ! ---
-
- ! -------------------------------------------------------------------------------------
- ! check bi-orthogonality
-
- allocate( S(n,n) )
-
- ! S = VL x VR
- call dgemm( 'T', 'N', n, n, n, 1.d0 &
- , leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
- , 0.d0, S, size(S, 1) )
-
- accu_nd = 0.d0
- do i = 1, n
- do j = 1, n
- if(i==j) cycle
- accu_nd = accu_nd + S(j,i) * S(j,i)
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- ! L x R is already bi-orthogonal
-
- !print *, ' L & T bi-orthogonality: ok'
- deallocate( S )
- return
-
- else
- ! impose bi-orthogonality
-
- !print *, ' L & T bi-orthogonality: not imposed yet'
- !print *, ' accu_nd = ', accu_nd
- call impose_biorthog_qr(n, n, thresh_biorthog_diag, thresh_biorthog_nondiag, leigvec, reigvec)
- deallocate( S )
-
- endif
-
- !
- ! -------------------------------------------------------------------------------------
-
- return
-
-end
-
-! ---
-
-
-subroutine split_matrix_degen(aw,n,shift)
- implicit none
- BEGIN_DOC
- ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2
- !
- ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS
- END_DOC
- double precision,intent(inout) :: Aw(n,n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer :: i,j,n_degen
- logical :: keep_on
- i=1
- do while(i.lt.n)
- if(dabs(Aw(i,i)-Aw(i+1,i+1)).lt.shift)then
- j=1
- keep_on = .True.
- do while(keep_on)
- if(i+j.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i,i)-Aw(i+j,i+j)).lt.shift)then
- j+=1
- else
- keep_on=.False.
- exit
- endif
- enddo
- n_degen = j
- j=0
- keep_on = .True.
- do while(keep_on)
- if(i+j+1.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i+j,i+j)-Aw(i+j+1,i+j+1)).lt.shift)then
- Aw(i+j,i+j) += (j-n_degen/2) * shift
- j+=1
- else
- keep_on = .False.
- exit
- endif
- enddo
- Aw(i+n_degen-1,i+n_degen-1) += (n_degen-1-n_degen/2) * shift
- i+=n_degen
- else
- i+=1
- endif
- enddo
-
-end
-
-subroutine give_degen(a,n,shift,list_degen,n_degen_list)
- implicit none
- BEGIN_DOC
- ! returns n_degen_list :: the number of degenerated SET of elements (i.e. with |A(i)-A(i+1)| below shift)
- !
- ! for each of these sets, list_degen(1,i) = first degenerate element of the set i,
- !
- ! list_degen(2,i) = last degenerate element of the set i.
- END_DOC
- double precision,intent(in) :: A(n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer, intent(out) :: list_degen(2,n),n_degen_list
- integer :: i,j,n_degen,k
- logical :: keep_on
- double precision,allocatable :: Aw(:)
- list_degen = -1
- allocate(Aw(n))
- Aw = A
- i=1
- k = 0
- do while(i.lt.n)
- if(dabs(Aw(i)-Aw(i+1)).lt.shift)then
- k+=1
- j=1
- list_degen(1,k) = i
- keep_on = .True.
- do while(keep_on)
- if(i+j.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i)-Aw(i+j)).lt.shift)then
- j+=1
- else
- keep_on=.False.
- exit
- endif
- enddo
- n_degen = j
- list_degen(2,k) = list_degen(1,k)-1 + n_degen
- j=0
- keep_on = .True.
- do while(keep_on)
- if(i+j+1.gt.n)then
- keep_on = .False.
- exit
- endif
- if(dabs(Aw(i+j)-Aw(i+j+1)).lt.shift)then
- Aw(i+j) += (j-n_degen/2) * shift
- j+=1
- else
- keep_on = .False.
- exit
- endif
- enddo
- Aw(i+n_degen-1) += (n_degen-1-n_degen/2) * shift
- i+=n_degen
- else
- i+=1
- endif
- enddo
- n_degen_list = k
-
-end
-
-subroutine cancel_small_elmts(aw,n,shift)
- implicit none
- BEGIN_DOC
- ! subroutines that splits the degeneracies of a matrix by adding a splitting of magnitude thr * n_degen/2
- !
- ! WARNING !! THE MATRIX IS ASSUMED TO BE PASSED WITH INCREASING DIAGONAL ELEMENTS
- END_DOC
- double precision,intent(inout) :: Aw(n,n)
- double precision,intent(in) :: shift
- integer, intent(in) :: n
- integer :: i,j
- do i = 1, n
- do j = 1, n
- if(dabs(Aw(j,i)).lt.shift)then
- Aw(j,i) = 0.d0
- endif
- enddo
- enddo
-end
-
-subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd)
- implicit none
- integer, intent(in) :: n
- double precision,intent(in) :: reigvec(n,n),leigvec(n,n)
- double precision, intent(out) :: S(n,n),accu_nd
- BEGIN_DOC
-! retunrs the overlap matrix S = Leigvec^T Reigvec
-!
-! and the square root of the sum of the squared off-diagonal elements of S
- END_DOC
- integer :: i,j
! S = VL x VR
call dgemm( 'T', 'N', n, n, n, 1.d0 &
, leigvec, size(leigvec, 1), reigvec, size(reigvec, 1) &
, 0.d0, S, size(S, 1) )
+
accu_nd = 0.d0
do i = 1, n
do j = 1, n
@@ -1213,3 +174,5 @@ subroutine check_bi_ortho(reigvec,leigvec,n,S,accu_nd)
accu_nd = dsqrt(accu_nd)
end
+
+
diff --git a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
index 4d4bc047..2c053ac8 100644
--- a/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
+++ b/plugins/local/non_hermit_dav/lapack_diag_non_hermit.irp.f
@@ -273,60 +273,6 @@ end
! ---
-subroutine lapack_diag_non_sym_right(n, A, WR, WI, VR)
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- double precision, intent(out) :: WR(n), WI(n), VR(n,n)
-
- integer :: i, lda, ldvl, ldvr, LWORK, INFO
- double precision, allocatable :: Atmp(:,:), WORK(:), VL(:,:)
-
- lda = n
- ldvl = 1
- ldvr = n
-
- allocate( Atmp(n,n), VL(1,1) )
- Atmp(1:n,1:n) = A(1:n,1:n)
-
- allocate(WORK(1))
- LWORK = -1
- call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
- if(INFO.gt.0)then
- print*,'dgeev failed !!',INFO
- stop
- endif
-
- LWORK = max(int(WORK(1)), 1) ! this is the optimal size of WORK
- deallocate(WORK)
-
- allocate(WORK(LWORK))
-
- ! Actual diagonalization
- call dgeev('N', 'V', n, Atmp, lda, WR, WI, VL, ldvl, VR, ldvr, WORK, LWORK, INFO)
- if(INFO.ne.0) then
- print*,'dgeev failed !!', INFO
- stop
- endif
-
- deallocate(Atmp, WORK, VL)
-
-! print *, ' JOBL = F'
-! print *, ' eigenvalues'
-! do i = 1, n
-! write(*, '(1000(F16.10,X))') WR(i), WI(i)
-! enddo
-! print *, ' right eigenvect'
-! do i = 1, n
-! write(*, '(1000(F16.10,X))') VR(:,i)
-! enddo
-
-end
-
-! ---
-
subroutine non_hrmt_real_diag(n, A, leigvec, reigvec, n_real_eigv, eigval)
BEGIN_DOC
@@ -1780,70 +1726,6 @@ end
! ---
-subroutine check_weighted_biorthog(n, m, W, Vl, Vr, thr_d, thr_nd, accu_d, accu_nd, S, stop_ifnot)
-
- implicit none
-
- integer, intent(in) :: n, m
- double precision, intent(in) :: Vl(n,m), Vr(n,m), W(n,n)
- double precision, intent(in) :: thr_d, thr_nd
- logical, intent(in) :: stop_ifnot
- double precision, intent(out) :: accu_d, accu_nd, S(m,m)
-
- integer :: i, j
- double precision, allocatable :: SS(:,:), tmp(:,:)
-
- print *, ' check weighted bi-orthogonality'
-
- ! ---
-
- allocate(tmp(m,n))
- call dgemm( 'T', 'N', m, n, n, 1.d0 &
- , Vl, size(Vl, 1), W, size(W, 1) &
- , 0.d0, tmp, size(tmp, 1) )
- call dgemm( 'N', 'N', m, m, n, 1.d0 &
- , tmp, size(tmp, 1), Vr, size(Vr, 1) &
- , 0.d0, S, size(S, 1) )
- deallocate(tmp)
-
- !print *, ' overlap matrix:'
- !do i = 1, m
- ! write(*,'(1000(F16.10,X))') S(i,:)
- !enddo
-
- accu_d = 0.d0
- accu_nd = 0.d0
- do i = 1, m
- do j = 1, m
- if(i==j) then
- accu_d = accu_d + dabs(S(i,i))
- else
- accu_nd = accu_nd + S(j,i) * S(j,i)
- endif
- enddo
- enddo
- accu_nd = dsqrt(accu_nd)
-
- print *, ' accu_nd = ', accu_nd
- print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
-
- ! ---
-
- if( stop_ifnot .and. ((accu_nd .gt. thr_nd) .or. dabs(accu_d-dble(m))/dble(m) .gt. thr_d) ) then
- print *, ' non bi-orthogonal vectors !'
- print *, ' accu_nd = ', accu_nd
- print *, ' accu_d = ', dabs(accu_d-dble(m))/dble(m)
- !print *, ' overlap matrix:'
- !do i = 1, m
- ! write(*,'(1000(F16.10,X))') S(i,:)
- !enddo
- stop
- endif
-
-end
-
-! ---
-
subroutine check_biorthog(n, m, Vl, Vr, accu_d, accu_nd, S, thr_d, thr_nd, stop_ifnot)
implicit none
diff --git a/plugins/local/non_hermit_dav/new_routines.irp.f b/plugins/local/non_hermit_dav/new_routines.irp.f
deleted file mode 100644
index 8db044d3..00000000
--- a/plugins/local/non_hermit_dav/new_routines.irp.f
+++ /dev/null
@@ -1,670 +0,0 @@
-subroutine non_hrmt_diag_split_degen_bi_orthog(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut, thr_norm=1d0
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- print *, ' '
- print *, ' '
- print *, ' orthog between degen eigenvect'
- print *, ' '
- double precision, allocatable :: S_nh_inv_half(:,:)
- allocate(S_nh_inv_half(n,n))
- logical :: complex_root
- deallocate(S_nh_inv_half)
- call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp)
- call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
-
-subroutine non_hrmt_diag_split_degen_s_inv_half(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine which returns the sorted REAL EIGENVALUES ONLY and corresponding LEFT/RIGHT eigenvetors
- !
- ! of a non hermitian matrix A(n,n)
- !
- ! n_real_eigv is the number of real eigenvalues, which might be smaller than the dimension "n"
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut, thr_norm=1.d0
- double precision, allocatable :: S_nh_inv_half(:,:)
- logical :: complex_root
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
- allocate(S_nh_inv_half(n,n))
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
-! thr_cut = shift_current
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- if(complex_root) then
- print *, ' '
- print *, ' '
- print *, ' orthog between degen eigenvect'
- print *, ' '
- ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
- call impose_orthog_degen_eigvec(n, eigval, reigvec_tmp) ! orthogonalization of reigvec
- call impose_orthog_degen_eigvec(n, eigval, leigvec_tmp) ! orthogonalization of leigvec
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ', accu_nd
- call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half, complex_root)
- if(complex_root)then
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
- else
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- endif
- else ! the matrix S^{-1/2} exists
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
-subroutine non_hrmt_fock_mat(n, A, leigvec, reigvec, n_real_eigv, eigval)
-
- BEGIN_DOC
- !
- ! routine returning the eigenvalues and left/right eigenvectors of the TC fock matrix
- !
- END_DOC
-
- implicit none
-
- integer, intent(in) :: n
- double precision, intent(in) :: A(n,n)
- integer, intent(out) :: n_real_eigv
- double precision, intent(out) :: reigvec(n,n), leigvec(n,n), eigval(n)
- double precision, allocatable :: reigvec_tmp(:,:), leigvec_tmp(:,:)
-
- integer :: i, j, n_degen,k , iteration
- double precision :: shift_current
- double precision :: r,thr,accu_d, accu_nd
- integer, allocatable :: iorder_origin(:),iorder(:)
- double precision, allocatable :: WR(:), WI(:), Vl(:,:), VR(:,:),S(:,:)
- double precision, allocatable :: Aw(:,:),diag_elem(:),A_save(:,:)
- double precision, allocatable :: im_part(:),re_part(:)
- double precision :: accu,thr_cut
- double precision, allocatable :: S_nh_inv_half(:,:)
- logical :: complex_root
- double precision :: thr_norm=1d0
-
-
- thr_cut = 1.d-15
- print*,'Computing the left/right eigenvectors ...'
- print*,'Using the degeneracy splitting algorithm'
- ! initialization
- shift_current = 1.d-15
- iteration = 0
- print*,'***** iteration = ',iteration
-
-
- ! pre-processing the matrix :: sorting by diagonal elements
- allocate(reigvec_tmp(n,n), leigvec_tmp(n,n))
- allocate(diag_elem(n),iorder_origin(n),A_save(n,n))
-! print*,'Aw'
- do i = 1, n
- iorder_origin(i) = i
- diag_elem(i) = A(i,i)
-! write(*,'(100(F16.10,X))')A(:,i)
- enddo
- call dsort(diag_elem, iorder_origin, n)
- do i = 1, n
- do j = 1, n
- A_save(j,i) = A(iorder_origin(j),iorder_origin(i))
- enddo
- enddo
-
- allocate(WR(n), WI(n), VL(n,n), VR(n,n), Aw(n,n))
- allocate(im_part(n),iorder(n))
- allocate( S(n,n) )
- allocate(S_nh_inv_half(n,n))
-
-
- Aw = A_save
- call cancel_small_elmts(aw,n,thr_cut)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv += 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
-
-
- do while(n_real_eigv.ne.n)
- iteration += 1
- print*,'***** iteration = ',iteration
- if(shift_current.gt.1.d-3)then
- print*,'shift_current > 1.d-3 !!'
- print*,'Your matrix intrinsically contains complex eigenvalues'
- stop
- endif
- Aw = A_save
-! thr_cut = shift_current
- call cancel_small_elmts(Aw,n,thr_cut)
- call split_matrix_degen(Aw,n,shift_current)
- call lapack_diag_non_sym(n,Aw,WR,WI,VL,VR)
- n_real_eigv = 0
- do i = 1, n
- if(dabs(WI(i)).lt.1.d-20)then
- n_real_eigv+= 1
- else
-! print*,'Found an imaginary component to eigenvalue'
-! print*,'Re(i) + Im(i)',WR(i),WI(i)
- endif
- enddo
- if(n_real_eigv.ne.n)then
- do i = 1, n
- im_part(i) = -dabs(WI(i))
- iorder(i) = i
- enddo
- call dsort(im_part, iorder, n)
- shift_current = max(10.d0 * dabs(im_part(1)),shift_current*10.d0)
- print*,'Largest imaginary part found in eigenvalues = ',im_part(1)
- print*,'Splitting the degeneracies by ',shift_current
- else
- print*,'All eigenvalues are real !'
- endif
- enddo
- !!!!!!!!!!!!!!!! SORTING THE EIGENVALUES
- do i = 1, n
- eigval(i) = WR(i)
- iorder(i) = i
- enddo
- call dsort(eigval,iorder,n)
- do i = 1, n
-! print*,'eigval(i) = ',eigval(i)
- reigvec_tmp(:,i) = VR(:,iorder(i))
- leigvec_tmp(:,i) = Vl(:,iorder(i))
- enddo
-
-!!! ONCE ALL EIGENVALUES ARE REAL ::: CHECK BI-ORTHONORMALITY
- ! check bi-orthogonality
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print *, ' '
- print *, ' bi-orthogonality: not imposed yet'
- print *, ' '
- print *, ' '
- print *, ' Using impose_unique_biorthog_degen_eigvec'
- print *, ' '
- ! bi-orthonormalization using orthogonalization of left, right and then QR between left and right
- call impose_unique_biorthog_degen_eigvec(n, eigval, mo_coef, leigvec_tmp, reigvec_tmp)
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print*,'accu_nd = ',accu_nd
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- call get_inv_half_nonsymmat_diago(S, n, S_nh_inv_half,complex_root)
- if(complex_root)then
- print*,'S^{-1/2} does not exits, using QR bi-orthogonalization'
- call impose_biorthog_qr(n, n, leigvec_tmp, reigvec_tmp, S) ! bi-orthonormalization using QR
- else
- print*,'S^{-1/2} exists !!'
- call bi_ortho_s_inv_half(n,leigvec_tmp,reigvec_tmp,S_nh_inv_half) ! use of S^{-1/2} bi-orthonormalization
- endif
- endif
- call check_biorthog(n, n, leigvec_tmp, reigvec_tmp, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'New vectors not bi-orthonormals at ',accu_nd
- print*,'Must be a deep problem ...'
- stop
- endif
- endif
-
- !! EIGENVECTORS SORTED AND BI-ORTHONORMAL
- do i = 1, n
- do j = 1, n
- VR(iorder_origin(j),i) = reigvec_tmp(j,i)
- VL(iorder_origin(j),i) = leigvec_tmp(j,i)
- enddo
- enddo
-
- !! RECOMPUTING THE EIGENVALUES
- eigval = 0.d0
- do i = 1, n
- iorder(i) = i
- accu = 0.d0
- do j = 1, n
- accu += VL(j,i) * VR(j,i)
- do k = 1, n
- eigval(i) += VL(j,i) * A(j,k) * VR(k,i)
- enddo
- enddo
- eigval(i) *= 1.d0/accu
-! print*,'eigval(i) = ',eigval(i)
- enddo
- !! RESORT JUST TO BE SURE
- call dsort(eigval, iorder, n)
- do i = 1, n
- do j = 1, n
- reigvec(j,i) = VR(j,iorder(i))
- leigvec(j,i) = VL(j,iorder(i))
- enddo
- enddo
- print*,'Checking for final reigvec/leigvec'
- shift_current = max(1.d-10,shift_current)
- print*,'Thr for eigenvectors = ',shift_current
- call check_EIGVEC(n, n, A, eigval, leigvec, reigvec, shift_current, thr_norm, .false.)
- call check_biorthog(n, n, leigvec, reigvec, accu_d, accu_nd, S, thresh_biorthog_diag, thresh_biorthog_nondiag, .false.)
- print *, ' accu_nd bi-orthog = ', accu_nd
-
- if(accu_nd .lt. thresh_biorthog_nondiag) then
- print *, ' bi-orthogonality: ok'
- else
- print*,'Something went wrong in non_hrmt_diag_split_degen_bi_orthog'
- print*,'Eigenvectors are not bi orthonormal ..'
- print*,'accu_nd = ',accu_nd
- stop
- endif
-
-end
-
-
diff --git a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
index a3f1b6ef..cb7cdb22 100644
--- a/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
+++ b/plugins/local/ortho_three_e_ints/mu_j_ints_usual_mos.irp.f
@@ -183,11 +183,3 @@ BEGIN_PROVIDER [ double precision, x_W_ij_erf_rk, ( n_points_final_grid,3,mo_num
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
-
diff --git a/plugins/local/tc_bi_ortho/EZFIO.cfg b/plugins/local/tc_bi_ortho/EZFIO.cfg
index a34d2134..67c780d7 100644
--- a/plugins/local/tc_bi_ortho/EZFIO.cfg
+++ b/plugins/local/tc_bi_ortho/EZFIO.cfg
@@ -9,3 +9,14 @@ interface: ezfio
doc: Coefficients for the right wave function
type: double precision
size: (determinants.n_det,determinants.n_states)
+
+[tc_gs_energy]
+type: Threshold
+doc: TC GS Energy
+interface: ezfio
+
+[tc_gs_var]
+type: Threshold
+doc: TC GS VAR
+interface: ezfio
+
diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
index ef38cbcc..1fa0c6d9 100644
--- a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
@@ -6,18 +6,9 @@ program print_tc_energy
implicit none
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
read_wf = .True.
touch read_wf
-
PROVIDE j2e_type
PROVIDE j1e_type
PROVIDE env_type
@@ -26,6 +17,27 @@ program print_tc_energy
print *, ' j1e_type = ', j1e_type
print *, ' env_type = ', env_type
+
+ my_grid_becke = .True.
+ PROVIDE tc_grid1_a tc_grid1_r
+ my_n_pt_r_grid = tc_grid1_r
+ my_n_pt_a_grid = tc_grid1_a
+ touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
+
+ call write_int(6, my_n_pt_r_grid, 'radial external grid over')
+ call write_int(6, my_n_pt_a_grid, 'angular external grid over')
+
+ if(tc_integ_type .eq. "numeric") then
+ my_extra_grid_becke = .True.
+ PROVIDE tc_grid2_a tc_grid2_r
+ my_n_pt_r_extra_grid = tc_grid2_r
+ my_n_pt_a_extra_grid = tc_grid2_a
+ touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
+
+ call write_int(6, my_n_pt_r_extra_grid, 'radial internal grid over')
+ call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
+ endif
+
call write_tc_energy()
end
diff --git a/plugins/local/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_bi_ortho/print_tc_var.irp.f
index bec34f18..6743cd11 100644
--- a/plugins/local/tc_bi_ortho/print_tc_var.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_var.irp.f
@@ -6,7 +6,8 @@ program print_tc_var
implicit none
- print *, 'Hello world'
+ print *, ' TC VAR is available only for HF REF WF'
+ print *, ' DO NOT FORGET TO RUN A CISD CALCULATION BEF'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
@@ -17,7 +18,7 @@ program print_tc_var
read_wf = .True.
touch read_wf
- call write_tc_var()
+ call write_tc_gs_var_HF()
end
diff --git a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
index efa4aa2c..ac90f737 100644
--- a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
+++ b/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
@@ -38,9 +38,9 @@ subroutine main()
call ezfio_has_cisd_energy(exists)
if(.not.exists) then
- call ezfio_has_tc_scf_bitc_energy(exists)
+ call ezfio_has_tc_scf_tcscf_energy(exists)
if(exists) then
- call ezfio_get_tc_scf_bitc_energy(e_ref)
+ call ezfio_get_tc_scf_tcscf_energy(e_ref)
endif
else
@@ -59,7 +59,7 @@ subroutine main()
close(iunit)
-end subroutine main
+end
! --
@@ -89,7 +89,7 @@ subroutine write_lr_spindeterminants()
call ezfio_set_spindeterminants_psi_left_coef_matrix_values(buffer)
deallocate(buffer)
-end subroutine write_lr_spindeterminants
+end
! ---
diff --git a/plugins/local/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f
index 53fe5884..43a6865e 100644
--- a/plugins/local/tc_bi_ortho/tc_utils.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_utils.irp.f
@@ -2,12 +2,67 @@
subroutine write_tc_energy()
implicit none
- integer :: i, j, k
- double precision :: hmono, htwoe, hthree, htot
- double precision :: E_TC, O_TC
- double precision :: E_1e, E_2e, E_3e
+ integer :: i, j, k
+ double precision :: hmono, htwoe, hthree, htot
+ double precision :: E_TC, O_TC
+ double precision :: E_1e, E_2e, E_3e
+ double precision, allocatable :: E_TC_tmp(:), E_1e_tmp(:), E_2e_tmp(:), E_3e_tmp(:)
- do k = 1, n_states
+ ! GS
+ ! ---
+
+ allocate(E_TC_tmp(N_det), E_1e_tmp(N_det), E_2e_tmp(N_det), E_3e_tmp(N_det))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE(i, j, hmono, htwoe, hthree, htot) &
+ !$OMP SHARED(N_det, psi_det, N_int, psi_l_coef_bi_ortho, psi_r_coef_bi_ortho, &
+ !$OMP E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+ !$OMP DO
+ do i = 1, N_det
+ E_TC_tmp(i) = 0.d0
+ E_1e_tmp(i) = 0.d0
+ E_2e_tmp(i) = 0.d0
+ E_3e_tmp(i) = 0.d0
+ do j = 1, N_det
+ call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+ E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
+ E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
+ E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
+ E_3e_tmp(i) = E_3e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hthree
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ E_1e = 0.d0
+ E_2e = 0.d0
+ E_3e = 0.d0
+ E_TC = 0.d0
+ O_TC = 0.d0
+ do i = 1, N_det
+ E_1e = E_1e + E_1e_tmp(i)
+ E_2e = E_2e + E_2e_tmp(i)
+ E_3e = E_3e + E_3e_tmp(i)
+ E_TC = E_TC + E_TC_tmp(i)
+ O_TC = O_TC + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(i,1)
+ enddo
+
+ print *, ' state :', 1
+ print *, " E_TC = ", E_TC / O_TC
+ print *, " E_1e = ", E_1e / O_TC
+ print *, " E_2e = ", E_2e / O_TC
+ print *, " E_3e = ", E_3e / O_TC
+ print *, " O_TC = ", O_TC
+
+ call ezfio_set_tc_bi_ortho_tc_gs_energy(E_TC/O_TC)
+
+ ! ---
+
+ ! ES
+ ! ---
+
+ do k = 2, n_states
E_TC = 0.d0
E_1e = 0.d0
@@ -37,6 +92,8 @@ subroutine write_tc_energy()
enddo
+ deallocate(E_TC_tmp, E_1e_tmp, E_2e_tmp, E_3e_tmp)
+
end
! ---
@@ -66,3 +123,25 @@ end
! ---
+subroutine write_tc_gs_var_HF()
+
+ implicit none
+ integer :: i, j, k
+ double precision :: hmono, htwoe, hthree, htot
+ double precision :: SIGMA_TC
+
+ SIGMA_TC = 0.d0
+ do j = 2, N_det
+ call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ SIGMA_TC = SIGMA_TC + htot * htot
+ enddo
+
+ print *, " SIGMA_TC = ", SIGMA_TC
+
+ call ezfio_set_tc_bi_ortho_tc_gs_var(SIGMA_TC)
+
+end
+
+! ---
+
+
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 3dfa9a71..510c777c 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -1,6 +1,6 @@
-[bitc_energy]
+[tcscf_energy]
type: Threshold
-doc: Energy bi-tc HF
+doc: TC-SCF ENERGY
interface: ezfio
[converged_tcscf]
diff --git a/plugins/local/tc_scf/combine_lr_tcscf.irp.f b/plugins/local/tc_scf/combine_lr_tcscf.irp.f
deleted file mode 100644
index a22614ba..00000000
--- a/plugins/local/tc_scf/combine_lr_tcscf.irp.f
+++ /dev/null
@@ -1,75 +0,0 @@
-
-! ---
-
-program combine_lr_tcscf
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- 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/plugins/local/tc_scf/diago_vartcfock.irp.f b/plugins/local/tc_scf/diago_vartcfock.irp.f
deleted file mode 100644
index 0c881dcb..00000000
--- a/plugins/local/tc_scf/diago_vartcfock.irp.f
+++ /dev/null
@@ -1,96 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_mo, (mo_num, mo_num)]
-
- implicit none
-
- integer :: i, j
- integer :: liwork, lwork, n, info
- integer, allocatable :: iwork(:)
- double precision, allocatable :: work(:), F(:,:), F_save(:,:)
- double precision, allocatable :: diag(:)
-
- PROVIDE mo_r_coef
- PROVIDE Fock_matrix_vartc_mo_tot
-
- allocate( F(mo_num,mo_num), F_save(mo_num,mo_num) )
- allocate (diag(mo_num) )
-
- do j = 1, mo_num
- do i = 1, mo_num
- F(i,j) = Fock_matrix_vartc_mo_tot(i,j)
- enddo
- enddo
-
- ! Insert level shift here
- do i = elec_beta_num+1, elec_alpha_num
- F(i,i) += 0.5d0 * level_shift_tcscf
- enddo
- do i = elec_alpha_num+1, mo_num
- F(i,i) += level_shift_tcscf
- enddo
-
- n = mo_num
- lwork = 1+6*n + 2*n*n
- liwork = 3 + 5*n
-
- allocate(work(lwork))
- allocate(iwork(liwork) )
-
- lwork = -1
- liwork = -1
-
- F_save = F
- call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
-
- if (info /= 0) then
- print *, irp_here//' DSYEVD failed : ', info
- stop 1
- endif
- lwork = int(work(1))
- liwork = iwork(1)
- deallocate(iwork)
- deallocate(work)
-
- allocate(work(lwork))
- allocate(iwork(liwork) )
- call dsyevd('V', 'U', mo_num, F, size(F, 1), diag, work, lwork, iwork, liwork, info)
- deallocate(iwork)
-
- if (info /= 0) then
- F = F_save
- call dsyev('V', 'L', mo_num, F, size(F, 1), diag, work, lwork, info)
-
- if (info /= 0) then
- print *, irp_here//' DSYEV failed : ', info
- stop 1
- endif
- endif
-
- do i = 1, mo_num
- do j = 1, mo_num
- fock_vartc_eigvec_mo(j,i) = F(j,i)
- enddo
- enddo
-
- deallocate(work, F, F_save, diag)
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, fock_vartc_eigvec_ao, (ao_num, mo_num)]
-
- implicit none
-
- PROVIDE mo_r_coef
-
- call dgemm( 'N', 'N', ao_num, mo_num, mo_num, 1.d0 &
- , mo_r_coef, size(mo_r_coef, 1), fock_vartc_eigvec_mo, size(fock_vartc_eigvec_mo, 1) &
- , 0.d0, fock_vartc_eigvec_ao, size(fock_vartc_eigvec_ao, 1))
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/diis_tcscf.irp.f b/plugins/local/tc_scf/diis_tcscf.irp.f
index 5d7d6b2e..ccc8eb15 100644
--- a/plugins/local/tc_scf/diis_tcscf.irp.f
+++ b/plugins/local/tc_scf/diis_tcscf.irp.f
@@ -91,28 +91,14 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
double precision, allocatable :: tmp(:,:)
double precision, allocatable :: F(:,:)
- !print *, ' Providing FQS_SQF_ao ...'
- !call wall_time(t0)
+ PROVIDE Fock_matrix_tc_ao_tot
allocate(F(ao_num,ao_num))
- if(var_tc) then
-
- do i = 1, ao_num
- do j = 1, ao_num
- F(j,i) = Fock_matrix_vartc_ao_tot(j,i)
- enddo
+ do i = 1, ao_num
+ do j = 1, ao_num
+ F(j,i) = Fock_matrix_tc_ao_tot(j,i)
enddo
-
- else
-
- PROVIDE Fock_matrix_tc_ao_tot
- do i = 1, ao_num
- do j = 1, ao_num
- F(j,i) = Fock_matrix_tc_ao_tot(j,i)
- enddo
- enddo
-
- endif
+ enddo
allocate(tmp(ao_num,ao_num))
@@ -140,9 +126,6 @@ BEGIN_PROVIDER [double precision, FQS_SQF_ao, (ao_num, ao_num)]
deallocate(tmp)
deallocate(F)
- !call wall_time(t1)
- !print *, ' Wall time for FQS_SQF_ao =', t1-t0
-
END_PROVIDER
! ---
@@ -152,61 +135,13 @@ BEGIN_PROVIDER [double precision, FQS_SQF_mo, (mo_num, mo_num)]
implicit none
double precision :: t0, t1
- !print*, ' Providing FQS_SQF_mo ...'
- !call wall_time(t0)
-
PROVIDE mo_r_coef mo_l_coef
PROVIDE FQS_SQF_ao
call ao_to_mo_bi_ortho( FQS_SQF_ao, size(FQS_SQF_ao, 1) &
, FQS_SQF_mo, size(FQS_SQF_mo, 1) )
- !call wall_time(t1)
- !print*, ' Wall time for FQS_SQF_mo =', t1-t0
-
END_PROVIDER
! ---
-! BEGIN_PROVIDER [ double precision, eigenval_Fock_tc_ao, (ao_num) ]
-!&BEGIN_PROVIDER [ double precision, eigenvec_Fock_tc_ao, (ao_num,ao_num) ]
-!
-! BEGIN_DOC
-! !
-! ! Eigenvalues and eigenvectors of the Fock matrix over the ao basis
-! !
-! ! F' = X.T x F x X where X = ao_overlap^(-1/2)
-! !
-! ! F' x Cr' = Cr' x E ==> F Cr = Cr x E with Cr = X x Cr'
-! ! F'.T x Cl' = Cl' x E ==> F.T Cl = Cl x E with Cl = X x Cl'
-! !
-! END_DOC
-!
-! implicit none
-! double precision, allocatable :: tmp1(:,:), tmp2(:,:)
-!
-! ! ---
-! ! Fock matrix in orthogonal basis: F' = X.T x F x X
-!
-! allocate(tmp1(ao_num,ao_num))
-! call dgemm( 'N', 'N', ao_num, ao_num, ao_num, 1.d0 &
-! , Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1), S_half_inv, size(S_half_inv, 1) &
-! , 0.d0, tmp1, size(tmp1, 1) )
-!
-! allocate(tmp2(ao_num,ao_num))
-! call dgemm( 'T', 'N', ao_num, ao_num, ao_num, 1.d0 &
-! , S_half_inv, size(S_half_inv, 1), tmp1, size(tmp1, 1) &
-! , 0.d0, tmp2, size(tmp2, 1) )
-!
-! ! ---
-!
-! ! Diagonalize F' to obtain eigenvectors in orthogonal basis C' and eigenvalues
-! ! TODO
-!
-! ! Back-transform eigenvectors: C =X.C'
-!
-!END_PROVIDER
-
-! ---
-
-~
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
deleted file mode 100644
index 8fd5e5b6..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_cs.irp.f
+++ /dev/null
@@ -1,299 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs, (mo_num, mo_num)]
-
- implicit none
- integer :: a, b, i, j, ipoint
- double precision :: ti, tf
- double precision :: loc_1, loc_2, loc_3
- double precision, allocatable :: Okappa(:), Jkappa(:,:)
- double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
- double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:), tmp_22(:,:,:)
- double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' PROVIDING fock_3e_uhf_mo_cs ...'
- !call wall_time(ti)
-
- ! ---
-
- allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
- Jkappa = 0.d0
- Okappa = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
-
- allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Okappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2, tmp_omp_d1)
-
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_1(n_points_final_grid,4))
-
- do ipoint = 1, n_points_final_grid
- loc_1 = 2.d0 * Okappa(ipoint)
- tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
- tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
- tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
- tmp_1(ipoint,4) = Okappa(ipoint)
- enddo
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_1)
-
- allocate(tmp_omp_d2(n_points_final_grid,3))
- tmp_omp_d2 = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
- tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
- tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2)
- !$OMP END PARALLEL
-
- ! ---
-
- if(tc_save_mem) then
-
- allocate(tmp_22(n_points_final_grid,4,mo_num))
- do a = 1, mo_num
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, a, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_22)
- !$OMP DO
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_22(ipoint,1,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_22(ipoint,2,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_22(ipoint,3,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- tmp_22(:,4,b) = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_22(ipoint,4,b) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
- call dgemv( 'T', 4*n_points_final_grid, mo_num, -2.d0 &
- , tmp_22(1,1,1), size(tmp_22, 1) * size(tmp_22, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_cs(1,a), 1)
- enddo
- deallocate(tmp_22)
-
- else
-
- allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- tmp_2(:,4,b,a) = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
- call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_cs(1,1), 1)
- deallocate(tmp_2)
-
- endif
-
- deallocate(tmp_1)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
- + Jkappa(ipoint,2) * Jkappa(ipoint,2) &
- + Jkappa(ipoint,3) * Jkappa(ipoint,3) )
- tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
- tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
- - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 5*n_points_final_grid &
- , tmp_4(1,1,1), 5*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_cs(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
- deallocate(Jkappa, Okappa)
-
- ! ---
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_cs =', (tf - ti) / 60.d0
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f
deleted file mode 100644
index 4bbce720..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_os.irp.f
+++ /dev/null
@@ -1,536 +0,0 @@
-
-! ---
-
- BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_os, (mo_num, mo_num)]
-&BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_os, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Open Shell part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, ipoint
- double precision :: loc_1, loc_2, loc_3, loc_4
- double precision :: ti, tf
- double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
- double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
- double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
- double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os ...'
- !call wall_time(ti)
-
- ! ---
-
- allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
- allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
- Jkappa = 0.d0
- Okappa = 0.d0
- Jbarkappa = 0.d0
- Obarkappa = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
-
- allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
-
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Okappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- tmp_omp_d2 = 0.d0
- tmp_omp_d1 = 0.d0
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
- tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
- Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
- Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
- Obarkappa(ipoint) += tmp_omp_d1(ipoint)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2, tmp_omp_d1)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_1(n_points_final_grid,4))
-
- do ipoint = 1, n_points_final_grid
-
- loc_1 = -2.d0 * Okappa (ipoint)
- loc_2 = -2.d0 * Obarkappa(ipoint)
- loc_3 = Obarkappa(ipoint)
-
- tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
- tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
- tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
-
- tmp_1(ipoint,4) = Obarkappa(ipoint)
- enddo
-
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
- !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_1)
-
- allocate(tmp_omp_d2(n_points_final_grid,3))
-
- tmp_omp_d2 = 0.d0
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
- tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
- tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- tmp_omp_d2 = 0.d0
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
- tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
- tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
- !$OMP CRITICAL
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
- tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
- tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_omp_d2)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
- tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
- tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
-
- tmp_2(:,4,b,a) = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 0.d0, fock_3e_uhf_mo_b_os(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
-
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
- + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
- + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
-
- tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
- enddo
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 2*n_points_final_grid &
- , tmp_4(1,1,1), 2*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_b_os(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
-
-
-
-
- ! ---
-
- fock_3e_uhf_mo_a_os = fock_3e_uhf_mo_b_os
-
- allocate(tmp_1(n_points_final_grid,1))
-
- do ipoint = 1, n_points_final_grid
- tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
- enddo
-
- allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, a, b, i) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP tmp_2)
- !$OMP DO COLLAPSE(2)
- do a = 1, mo_num
- do b = 1, mo_num
-
- tmp_2(:,1,b,a) = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
- , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
- , tmp_1(1,1), 1 &
- , 1.d0, fock_3e_uhf_mo_a_os(1,1), 1)
-
- deallocate(tmp_1, tmp_2)
-
- ! ---
-
- allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b) &
- !$OMP SHARED (n_points_final_grid, mo_num, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- tmp_3(:,:,b) = 0.d0
- tmp_4(:,:,b) = 0.d0
- do ipoint = 1, n_points_final_grid
-
- tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
-
- tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
-
- tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_3 = 2.d0 * loc_1
- loc_2 = mos_r_in_r_array_transp(ipoint,i)
- loc_4 = 2.d0 * loc_2
-
- tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
- tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
- tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
-
- tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
- + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
- + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
-
- tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
-
- tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
-
- tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
- tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
- tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
- !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
- !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP tmp_3, tmp_4)
- !$OMP DO
- do b = 1, mo_num
-
- do i = 1, elec_beta_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
- loc_3 = mos_r_in_r_array_transp(ipoint,j)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
- enddo
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
- loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
- loc_3 = mos_r_in_r_array_transp(ipoint,i)
-
- tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
- + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
-
- tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
- , tmp_3(1,1,1), 8*n_points_final_grid &
- , tmp_4(1,1,1), 8*n_points_final_grid &
- , 1.d0, fock_3e_uhf_mo_a_os(1,1), mo_num)
-
- deallocate(tmp_3, tmp_4)
- deallocate(Jkappa, Okappa)
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a_os and fock_3e_uhf_mo_b_os =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
deleted file mode 100644
index 47ee5b48..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf.irp.f
+++ /dev/null
@@ -1,77 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Fock matrix alpha from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- double precision :: ti, tf
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing fock_3e_uhf_mo_a ...'
- !call wall_time(ti)
-
- ! CLOSED-SHELL PART
- PROVIDE fock_3e_uhf_mo_cs
- fock_3e_uhf_mo_a = fock_3e_uhf_mo_cs
-
- if(elec_alpha_num .ne. elec_beta_num) then
-
- ! OPEN-SHELL PART
- PROVIDE fock_3e_uhf_mo_a_os
-
- fock_3e_uhf_mo_a += fock_3e_uhf_mo_a_os
- endif
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a (min) =', (tf - ti)/60.d0
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! Fock matrix beta from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- double precision :: ti, tf
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' Providing and fock_3e_uhf_mo_b ...'
- !call wall_time(ti)
-
- ! CLOSED-SHELL PART
- PROVIDE fock_3e_uhf_mo_cs
- fock_3e_uhf_mo_b = fock_3e_uhf_mo_cs
-
- if(elec_alpha_num .ne. elec_beta_num) then
-
- ! OPEN-SHELL PART
- PROVIDE fock_3e_uhf_mo_b_os
-
- fock_3e_uhf_mo_b += fock_3e_uhf_mo_b_os
- endif
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_b =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f b/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f
deleted file mode 100644
index 3bf6bd85..00000000
--- a/plugins/local/tc_scf/fock_3e_bi_ortho_uhf_old.irp.f
+++ /dev/null
@@ -1,490 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_cs_old, (mo_num, mo_num)]
-
- implicit none
- integer :: a, b, i, j
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- !print *, ' PROVIDING fock_3e_uhf_mo_cs_old ...'
- !call wall_time(ti)
-
- fock_3e_uhf_mo_cs_old = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, elec_beta_num, fock_3e_uhf_mo_cs_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- do j = 1, elec_beta_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 4.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - 2.d0 * I_bij_aji &
- - 2.d0 * I_bij_iaj &
- - 2.d0 * I_bij_jia )
-
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_cs_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_cs_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_a_old, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! ALPHA part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, o
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
- PROVIDE fock_3e_uhf_mo_cs
-
- !print *, ' Providing fock_3e_uhf_mo_a_old ...'
- !call wall_time(ti)
-
- o = elec_beta_num + 1
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- PROVIDE fock_3e_uhf_mo_cs_old
- fock_3e_uhf_mo_a_old = fock_3e_uhf_mo_cs_old
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_a_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - I_bij_iaj &
- - 2.d0 * I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = 1, elec_beta_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - 2.d0 * I_bij_iaj &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- + I_bij_ija &
- + I_bij_jai &
- - I_bij_aji &
- - I_bij_iaj &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_a_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' Wall time for fock_3e_uhf_mo_a_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_mo_b_old, (mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! BETA part of the Fock matrix from three-electron terms
- !
- ! WARNING :: non hermitian if bi-ortho MOS used
- !
- END_DOC
-
- implicit none
- integer :: a, b, i, j, o
- double precision :: I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia
- double precision :: ti, tf
- double precision, allocatable :: tmp(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' PROVIDING fock_3e_uhf_mo_b_old ...'
- !call wall_time(ti)
-
- o = elec_beta_num + 1
- call give_integrals_3_body_bi_ort(1, 1, 1, 1, 1, 1, I_bij_aij)
-
- PROVIDE fock_3e_uhf_mo_cs_old
- fock_3e_uhf_mo_b_old = fock_3e_uhf_mo_cs_old
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (a, b, i, j, I_bij_aij, I_bij_ija, I_bij_jai, I_bij_aji, I_bij_iaj, I_bij_jia, tmp) &
- !$OMP SHARED (mo_num, o, elec_alpha_num, elec_beta_num, fock_3e_uhf_mo_b_old)
-
- allocate(tmp(mo_num,mo_num))
- tmp = 0.d0
-
- !$OMP DO
- do a = 1, mo_num
- do b = 1, mo_num
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = 1, elec_beta_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- - I_bij_aji &
- - I_bij_iaj )
-
- enddo
- enddo
-
- ! ---
-
- do j = 1, elec_beta_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( 2.d0 * I_bij_aij &
- - I_bij_aji &
- - I_bij_jia )
-
- enddo
- enddo
-
- ! ---
-
- do j = o, elec_alpha_num
- do i = o, elec_alpha_num
-
- call give_integrals_3_body_bi_ort(b, i, j, a, i, j, I_bij_aij)
- call give_integrals_3_body_bi_ort(b, i, j, i, j, a, I_bij_ija)
- call give_integrals_3_body_bi_ort(b, i, j, j, a, i, I_bij_jai)
- call give_integrals_3_body_bi_ort(b, i, j, a, j, i, I_bij_aji)
- call give_integrals_3_body_bi_ort(b, i, j, i, a, j, I_bij_iaj)
- call give_integrals_3_body_bi_ort(b, i, j, j, i, a, I_bij_jia)
-
- tmp(b,a) -= 0.5d0 * ( I_bij_aij &
- - I_bij_aji )
-
- enddo
- enddo
-
- ! ---
-
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do a = 1, mo_num
- do b = 1, mo_num
- fock_3e_uhf_mo_b_old(b,a) += tmp(b,a)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_mo_b_old =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_a, (ao_num, ao_num)]
-
- BEGIN_DOC
- !
- ! Equations (B6) and (B7)
- !
- ! g <--> gamma
- ! d <--> delta
- ! e <--> eta
- ! k <--> kappa
- !
- END_DOC
-
- implicit none
- integer :: g, d, e, k, mu, nu
- double precision :: dm_ge_a, dm_ge_b, dm_ge
- double precision :: dm_dk_a, dm_dk_b, dm_dk
- double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
- double precision :: ti, tf
- double precision, allocatable :: f_tmp(:,:)
-
- !print *, ' PROVIDING fock_3e_uhf_ao_a ...'
- !call wall_time(ti)
-
- fock_3e_uhf_ao_a = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
- !$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
- !$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_a)
-
- allocate(f_tmp(ao_num,ao_num))
- f_tmp = 0.d0
-
- !$OMP DO
- do g = 1, ao_num
- do e = 1, ao_num
- dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
- dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
- dm_ge = dm_ge_a + dm_ge_b
- do d = 1, ao_num
- do k = 1, ao_num
- dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
- dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
- dm_dk = dm_dk_a + dm_dk_b
- do mu = 1, ao_num
- do nu = 1, ao_num
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
- f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
- + dm_ge_a * dm_dk_a * i_mugd_eknu &
- + dm_ge_a * dm_dk_a * i_mugd_knue &
- - dm_ge_a * dm_dk * i_mugd_enuk &
- - dm_ge * dm_dk_a * i_mugd_kenu &
- - dm_ge_a * dm_dk_a * i_mugd_nuke &
- - dm_ge_b * dm_dk_b * i_mugd_nuke )
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do mu = 1, ao_num
- do nu = 1, ao_num
- fock_3e_uhf_ao_a(mu,nu) += f_tmp(mu,nu)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(f_tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_ao_a =', tf - ti
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [double precision, fock_3e_uhf_ao_b, (ao_num, ao_num)]
-
- BEGIN_DOC
- !
- ! Equations (B6) and (B7)
- !
- ! g <--> gamma
- ! d <--> delta
- ! e <--> eta
- ! k <--> kappa
- !
- END_DOC
-
- implicit none
- integer :: g, d, e, k, mu, nu
- double precision :: dm_ge_a, dm_ge_b, dm_ge
- double precision :: dm_dk_a, dm_dk_b, dm_dk
- double precision :: i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu
- double precision :: ti, tf
- double precision, allocatable :: f_tmp(:,:)
-
- !print *, ' PROVIDING fock_3e_uhf_ao_b ...'
- !call wall_time(ti)
-
- fock_3e_uhf_ao_b = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (g, e, d, k, mu, nu, dm_ge_a, dm_ge_b, dm_ge, dm_dk_a, dm_dk_b, dm_dk, f_tmp, &
- !$OMP i_mugd_nuek, i_mugd_eknu, i_mugd_knue, i_mugd_nuke, i_mugd_enuk, i_mugd_kenu) &
- !$OMP SHARED (ao_num, TCSCF_bi_ort_dm_ao_alpha, TCSCF_bi_ort_dm_ao_beta, fock_3e_uhf_ao_b)
-
- allocate(f_tmp(ao_num,ao_num))
- f_tmp = 0.d0
-
- !$OMP DO
- do g = 1, ao_num
- do e = 1, ao_num
- dm_ge_a = TCSCF_bi_ort_dm_ao_alpha(g,e)
- dm_ge_b = TCSCF_bi_ort_dm_ao_beta (g,e)
- dm_ge = dm_ge_a + dm_ge_b
- do d = 1, ao_num
- do k = 1, ao_num
- dm_dk_a = TCSCF_bi_ort_dm_ao_alpha(d,k)
- dm_dk_b = TCSCF_bi_ort_dm_ao_beta (d,k)
- dm_dk = dm_dk_a + dm_dk_b
- do mu = 1, ao_num
- do nu = 1, ao_num
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, e, k, i_mugd_nuek)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, k, nu, i_mugd_eknu)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, nu, e, i_mugd_knue)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, nu, k, e, i_mugd_nuke)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, e, nu, k, i_mugd_enuk)
- call give_integrals_3_body_bi_ort_ao(mu, g, d, k, e, nu, i_mugd_kenu)
- f_tmp(mu,nu) -= 0.5d0 * ( dm_ge * dm_dk * i_mugd_nuek &
- + dm_ge_b * dm_dk_b * i_mugd_eknu &
- + dm_ge_b * dm_dk_b * i_mugd_knue &
- - dm_ge_b * dm_dk * i_mugd_enuk &
- - dm_ge * dm_dk_b * i_mugd_kenu &
- - dm_ge_b * dm_dk_b * i_mugd_nuke &
- - dm_ge_a * dm_dk_a * i_mugd_nuke )
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do mu = 1, ao_num
- do nu = 1, ao_num
- fock_3e_uhf_ao_b(mu,nu) += f_tmp(mu,nu)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(f_tmp)
- !$OMP END PARALLEL
-
- !call wall_time(tf)
- !print *, ' total Wall time for fock_3e_uhf_ao_b =', tf - ti
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f
index d3ddb8ad..508f3cd7 100644
--- a/plugins/local/tc_scf/fock_tc.irp.f
+++ b/plugins/local/tc_scf/fock_tc.irp.f
@@ -1,78 +1,15 @@
+
! ---
- BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_tc_non_hermit_integral_seq_beta , (ao_num, ao_num)]
+ BEGIN_PROVIDER [ double precision, two_e_tc_integral_alpha, (ao_num, ao_num)]
+&BEGIN_PROVIDER [ double precision, two_e_tc_integral_beta , (ao_num, ao_num)]
BEGIN_DOC
!
- ! two_e_tc_non_hermit_integral_seq_alpha(k,i) = ON THE AO BASIS
+ ! two_e_tc_integral_alpha(k,i) = ON THE AO BASIS
!
- ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
- !
- ! works in SEQUENTIAL
- END_DOC
-
- implicit none
- integer :: i, j, k, l
- double precision :: density, density_a, density_b
- double precision :: t0, t1
-
- PROVIDE ao_two_e_tc_tot
-
- !print*, ' providing two_e_tc_non_hermit_integral_seq ...'
- !call wall_time(t0)
-
- two_e_tc_non_hermit_integral_seq_alpha = 0.d0
- two_e_tc_non_hermit_integral_seq_beta = 0.d0
-
- do i = 1, ao_num
- do k = 1, ao_num
- 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_seq_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_seq_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_seq_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_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
-
- ! rho(l,j) * < k l| T | i j>
- two_e_tc_non_hermit_integral_seq_alpha(k,i) += density * ao_two_e_tc_tot(k,i,l,j)
- ! rho(l,j) * < k l| T | i j>
- two_e_tc_non_hermit_integral_seq_beta (k,i) += density * ao_two_e_tc_tot(k,i,l,j)
- ! rho_a(l,j) * < k l| T | j i>
- two_e_tc_non_hermit_integral_seq_alpha(k,i) -= density_a * ao_two_e_tc_tot(k,j,l,i)
- ! rho_b(l,j) * < k l| T | j i>
- two_e_tc_non_hermit_integral_seq_beta (k,i) -= density_b * ao_two_e_tc_tot(k,j,l,i)
-
- enddo
- enddo
- enddo
- enddo
-
- !call wall_time(t1)
- !print*, ' wall time for two_e_tc_non_hermit_integral_seq after = ', t1 - t0
-
-END_PROVIDER
-
-! ---
-
- 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) = ON THE AO BASIS
- !
- ! where F^tc is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
+ ! where F^tc_2e is the TWO-BODY part of the TC Fock matrix and k,i are AO basis functions
!
END_DOC
@@ -86,16 +23,13 @@ END_PROVIDER
PROVIDE mo_l_coef mo_r_coef
PROVIDE TCSCF_density_matrix_ao_alpha TCSCF_density_matrix_ao_beta
- !print*, ' Providing two_e_tc_non_hermit_integral ...'
- !call wall_time(t0)
-
- two_e_tc_non_hermit_integral_alpha = 0.d0
- two_e_tc_non_hermit_integral_beta = 0.d0
+ two_e_tc_integral_alpha = 0.d0
+ two_e_tc_integral_beta = 0.d0
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) &
!$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
- !$OMP two_e_tc_non_hermit_integral_alpha, two_e_tc_non_hermit_integral_beta)
+ !$OMP two_e_tc_integral_alpha, two_e_tc_integral_beta)
allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
tmp_a = 0.d0
@@ -124,8 +58,8 @@ END_PROVIDER
!$OMP CRITICAL
do i = 1, ao_num
do j = 1, ao_num
- two_e_tc_non_hermit_integral_alpha(j,i) += tmp_a(j,i)
- two_e_tc_non_hermit_integral_beta (j,i) += tmp_b(j,i)
+ two_e_tc_integral_alpha(j,i) += tmp_a(j,i)
+ two_e_tc_integral_beta (j,i) += tmp_b(j,i)
enddo
enddo
!$OMP END CRITICAL
@@ -133,9 +67,6 @@ END_PROVIDER
deallocate(tmp_a, tmp_b)
!$OMP END PARALLEL
- !call wall_time(t1)
- !print*, ' Wall time for two_e_tc_non_hermit_integral = ', t1 - t0
-
END_PROVIDER
! ---
@@ -149,13 +80,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_alpha, (ao_num, ao_num)]
implicit none
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_ao_alpha ...'
- !call wall_time(t0)
-
- Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_alpha
-
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_ao_alpha =', t1-t0
+ Fock_matrix_tc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_tc_integral_alpha
END_PROVIDER
@@ -169,7 +94,7 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_beta, (ao_num, ao_num)]
implicit none
- Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_non_hermit_integral_beta
+ Fock_matrix_tc_ao_beta = ao_one_e_integrals_tc_tot + two_e_tc_integral_beta
END_PROVIDER
@@ -185,9 +110,6 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
double precision :: t0, t1, tt0, tt1
double precision, allocatable :: tmp(:,:)
- !print*, ' Providing Fock_matrix_tc_mo_alpha ...'
- !call wall_time(t0)
-
if(bi_ortho) then
PROVIDE mo_l_coef mo_r_coef
@@ -196,8 +118,8 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
, Fock_matrix_tc_mo_alpha, size(Fock_matrix_tc_mo_alpha, 1) )
if(three_body_h_tc) then
- PROVIDE fock_3e_uhf_mo_a
- Fock_matrix_tc_mo_alpha += fock_3e_uhf_mo_a
+ PROVIDE fock_3e_mo_a
+ Fock_matrix_tc_mo_alpha += fock_3e_mo_a
endif
else
@@ -207,9 +129,6 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
endif
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_mo_alpha =', t1-t0
-
END_PROVIDER
! ---
@@ -229,8 +148,8 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
, Fock_matrix_tc_mo_beta, size(Fock_matrix_tc_mo_beta, 1) )
if(three_body_h_tc) then
- PROVIDE fock_3e_uhf_mo_b
- Fock_matrix_tc_mo_beta += fock_3e_uhf_mo_b
+ PROVIDE fock_3e_mo_b
+ Fock_matrix_tc_mo_beta += fock_3e_mo_b
endif
else
@@ -286,20 +205,895 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_ao_tot, (ao_num, ao_num) ]
implicit none
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_ao_tot ...'
- !call wall_time(t0)
-
PROVIDE mo_l_coef mo_r_coef
PROVIDE Fock_matrix_tc_mo_tot
call mo_to_ao_bi_ortho( Fock_matrix_tc_mo_tot, size(Fock_matrix_tc_mo_tot, 1) &
, Fock_matrix_tc_ao_tot, size(Fock_matrix_tc_ao_tot, 1) )
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_ao_tot =', t1-t0
-
END_PROVIDER
! ---
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_a, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Fock matrix alpha from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ double precision :: ti, tf
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! CLOSED-SHELL PART
+ PROVIDE fock_3e_mo_cs
+ fock_3e_mo_a = fock_3e_mo_cs
+
+ if(elec_alpha_num .ne. elec_beta_num) then
+
+ ! OPEN-SHELL PART
+ PROVIDE fock_3e_mo_a_os
+
+ fock_3e_mo_a += fock_3e_mo_a_os
+ endif
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_b, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Fock matrix beta from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ double precision :: ti, tf
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! CLOSED-SHELL PART
+ PROVIDE fock_3e_mo_cs
+ fock_3e_mo_b = fock_3e_mo_cs
+
+ if(elec_alpha_num .ne. elec_beta_num) then
+
+ ! OPEN-SHELL PART
+ PROVIDE fock_3e_mo_b_os
+
+ fock_3e_mo_b += fock_3e_mo_b_os
+ endif
+
+END_PROVIDER
+
+! ---
+
+
+! ---
+
+ BEGIN_PROVIDER [double precision, fock_3e_mo_a_os, (mo_num, mo_num)]
+&BEGIN_PROVIDER [double precision, fock_3e_mo_b_os, (mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! Open Shell part of the Fock matrix from three-electron terms
+ !
+ ! WARNING :: non hermitian if bi-ortho MOS used
+ !
+ END_DOC
+
+ implicit none
+ integer :: a, b, i, j, ipoint
+ double precision :: loc_1, loc_2, loc_3, loc_4
+ double precision :: ti, tf
+ double precision, allocatable :: Okappa(:), Jkappa(:,:), Obarkappa(:), Jbarkappa(:,:)
+ double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+ double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:)
+ double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! ---
+
+ allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+ allocate(Jbarkappa(n_points_final_grid,3), Obarkappa(n_points_final_grid))
+ Jkappa = 0.d0
+ Okappa = 0.d0
+ Jbarkappa = 0.d0
+ Obarkappa = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa, Obarkappa, Jbarkappa)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Okappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+ !$OMP DO
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jbarkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jbarkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jbarkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Obarkappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2, tmp_omp_d1)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_1(n_points_final_grid,4))
+
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = -2.d0 * Okappa (ipoint)
+ loc_2 = -2.d0 * Obarkappa(ipoint)
+ loc_3 = Obarkappa(ipoint)
+
+ tmp_1(ipoint,1) = (loc_1 - loc_3) * Jbarkappa(ipoint,1) + loc_2 * Jkappa(ipoint,1)
+ tmp_1(ipoint,2) = (loc_1 - loc_3) * Jbarkappa(ipoint,2) + loc_2 * Jkappa(ipoint,2)
+ tmp_1(ipoint,3) = (loc_1 - loc_3) * Jbarkappa(ipoint,3) + loc_2 * Jkappa(ipoint,3)
+
+ tmp_1(ipoint,4) = Obarkappa(ipoint)
+ enddo
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, loc_1, loc_2, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, elec_alpha_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_1)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3))
+
+ tmp_omp_d2 = 0.d0
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+ loc_2 = mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,1,j,i)
+ tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,2,j,i)
+ tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j) + loc_2 * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ tmp_omp_d2 = 0.d0
+ !$OMP DO COLLAPSE(2)
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_omp_d2(ipoint,1) += loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
+ tmp_omp_d2(ipoint,2) += loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
+ tmp_omp_d2(ipoint,3) += loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+
+ tmp_2(:,4,b,a) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,4,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, 1.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_b_os(1,1), 1)
+
+ deallocate(tmp_1, tmp_2)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,2,mo_num), tmp_4(n_points_final_grid,2,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ loc_1 = -2.0d0 * mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) = loc_1 * ( Jbarkappa(ipoint,1) * (Jkappa(ipoint,1) + 0.25d0 * Jbarkappa(ipoint,1)) &
+ + Jbarkappa(ipoint,2) * (Jkappa(ipoint,2) + 0.25d0 * Jbarkappa(ipoint,2)) &
+ + Jbarkappa(ipoint,3) * (Jkappa(ipoint,3) + 0.25d0 * Jbarkappa(ipoint,3)) )
+
+ tmp_4(ipoint,2,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) += loc_1 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,1,b) += loc_2 * ( Jbarkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + Jbarkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + Jbarkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+ enddo
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) += loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 2*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 2*n_points_final_grid &
+ , tmp_4(1,1,1), 2*n_points_final_grid &
+ , 1.d0, fock_3e_mo_b_os(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+
+ ! ---
+
+ fock_3e_mo_a_os = fock_3e_mo_b_os
+
+ allocate(tmp_1(n_points_final_grid,1))
+
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) = Obarkappa(ipoint) + 2.d0 * Okappa(ipoint)
+ enddo
+
+ allocate(tmp_2(n_points_final_grid,1,mo_num,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+
+ tmp_2(:,1,b,a) = 0.d0
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) += final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call dgemv( 'T', n_points_final_grid, mo_num*mo_num, 1.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 1.d0, fock_3e_mo_a_os(1,1), 1)
+
+ deallocate(tmp_1, tmp_2)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,8,mo_num), tmp_4(n_points_final_grid,8,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,8,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2, loc_3, loc_4) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, Jbarkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+ tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_3 = 2.d0 * loc_1
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+ loc_4 = 2.d0 * loc_2
+
+ tmp_3(ipoint,5,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,6,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,7,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+
+ tmp_3(ipoint,8,b) += loc_3 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,1,b) += loc_4 * ( (Jkappa(ipoint,1) + 0.5d0 * Jbarkappa(ipoint,1)) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + (Jkappa(ipoint,2) + 0.5d0 * Jbarkappa(ipoint,2)) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + (Jkappa(ipoint,3) + 0.5d0 * Jbarkappa(ipoint,3)) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+
+ tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+
+ tmp_4(ipoint,5,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,6,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,7,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, elec_alpha_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+
+ do i = 1, elec_beta_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_3 = mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,j,i) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,j,i) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,j,i) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = 0.5d0 * mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,8,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) -= loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 8*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 8*n_points_final_grid &
+ , tmp_4(1,1,1), 8*n_points_final_grid &
+ , 1.d0, fock_3e_mo_a_os(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+ deallocate(Jkappa, Okappa)
+
+END_PROVIDER
+
+! ---
+
+BEGIN_PROVIDER [double precision, fock_3e_mo_cs, (mo_num, mo_num)]
+
+ implicit none
+ integer :: a, b, i, j, ipoint
+ double precision :: ti, tf
+ double precision :: loc_1, loc_2, loc_3
+ double precision, allocatable :: Okappa(:), Jkappa(:,:)
+ double precision, allocatable :: tmp_omp_d1(:), tmp_omp_d2(:,:)
+ double precision, allocatable :: tmp_1(:,:), tmp_2(:,:,:,:), tmp_22(:,:,:)
+ double precision, allocatable :: tmp_3(:,:,:), tmp_4(:,:,:)
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ ! ---
+
+ allocate(Jkappa(n_points_final_grid,3), Okappa(n_points_final_grid))
+ Jkappa = 0.d0
+ Okappa = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, tmp_omp_d1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, Okappa, Jkappa)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3), tmp_omp_d1(n_points_final_grid))
+ tmp_omp_d2 = 0.d0
+ tmp_omp_d1 = 0.d0
+
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_omp_d2(ipoint,1) += int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_omp_d2(ipoint,2) += int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_omp_d2(ipoint,3) += int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ tmp_omp_d1(ipoint) += mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ Jkappa(ipoint,1) += tmp_omp_d2(ipoint,1)
+ Jkappa(ipoint,2) += tmp_omp_d2(ipoint,2)
+ Jkappa(ipoint,3) += tmp_omp_d2(ipoint,3)
+ Okappa(ipoint) += tmp_omp_d1(ipoint)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2, tmp_omp_d1)
+
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_1(n_points_final_grid,4))
+
+ do ipoint = 1, n_points_final_grid
+ loc_1 = 2.d0 * Okappa(ipoint)
+ tmp_1(ipoint,1) = loc_1 * Jkappa(ipoint,1)
+ tmp_1(ipoint,2) = loc_1 * Jkappa(ipoint,2)
+ tmp_1(ipoint,3) = loc_1 * Jkappa(ipoint,3)
+ tmp_1(ipoint,4) = Okappa(ipoint)
+ enddo
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, i, j, loc_1, tmp_omp_d2) &
+ !$OMP SHARED (n_points_final_grid, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_1)
+
+ allocate(tmp_omp_d2(n_points_final_grid,3))
+ tmp_omp_d2 = 0.d0
+
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_omp_d2(ipoint,1) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,i,j)
+ tmp_omp_d2(ipoint,2) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,i,j)
+ tmp_omp_d2(ipoint,3) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,i,j)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ do ipoint = 1, n_points_final_grid
+ tmp_1(ipoint,1) += tmp_omp_d2(ipoint,1)
+ tmp_1(ipoint,2) += tmp_omp_d2(ipoint,2)
+ tmp_1(ipoint,3) += tmp_omp_d2(ipoint,3)
+ enddo
+ !$OMP END CRITICAL
+
+ deallocate(tmp_omp_d2)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ if(tc_save_mem) then
+
+ allocate(tmp_22(n_points_final_grid,4,mo_num))
+ do a = 1, mo_num
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, a, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_22)
+ !$OMP DO
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_22(ipoint,1,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_22(ipoint,2,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_22(ipoint,3,b) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_22(:,4,b) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_22(ipoint,4,b) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num, -2.d0 &
+ , tmp_22(1,1,1), size(tmp_22, 1) * size(tmp_22, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_cs(1,a), 1)
+ enddo
+ deallocate(tmp_22)
+
+ else
+
+ allocate(tmp_2(n_points_final_grid,4,mo_num,mo_num))
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, a, b, i) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, final_weight_at_r_vector, &
+ !$OMP tmp_2)
+ !$OMP DO COLLAPSE(2)
+ do a = 1, mo_num
+ do b = 1, mo_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,1,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,1,b,a)
+ tmp_2(ipoint,2,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,2,b,a)
+ tmp_2(ipoint,3,b,a) = final_weight_at_r_vector(ipoint) * int2_grad1_u12_bimo_t(ipoint,3,b,a)
+ enddo
+ tmp_2(:,4,b,a) = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_2(ipoint,4,b,a) -= final_weight_at_r_vector(ipoint) * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,a) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,a) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+ call dgemv( 'T', 4*n_points_final_grid, mo_num*mo_num, -2.d0 &
+ , tmp_2(1,1,1,1), size(tmp_2, 1) * size(tmp_2, 2) &
+ , tmp_1(1,1), 1 &
+ , 0.d0, fock_3e_mo_cs(1,1), 1)
+ deallocate(tmp_2)
+
+ endif
+
+ deallocate(tmp_1)
+
+ ! ---
+
+ allocate(tmp_3(n_points_final_grid,5,mo_num), tmp_4(n_points_final_grid,5,mo_num))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP final_weight_at_r_vector, Jkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ tmp_3(:,:,b) = 0.d0
+ tmp_4(:,:,b) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ tmp_3(ipoint,1,b) = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,b)
+
+ tmp_4(ipoint,1,b) = -2.d0 * mos_r_in_r_array_transp(ipoint,b) * ( Jkappa(ipoint,1) * Jkappa(ipoint,1) &
+ + Jkappa(ipoint,2) * Jkappa(ipoint,2) &
+ + Jkappa(ipoint,3) * Jkappa(ipoint,3) )
+ tmp_4(ipoint,5,b) = mos_r_in_r_array_transp(ipoint,b)
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, loc_1, loc_2) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP Jkappa, tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,i)
+ loc_2 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,2,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,1,b,i)
+ tmp_3(ipoint,3,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,2,b,i)
+ tmp_3(ipoint,4,b) -= loc_1 * int2_grad1_u12_bimo_t(ipoint,3,b,i)
+ tmp_3(ipoint,5,b) += 2.d0 * loc_1 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,b,i) &
+ + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,b,i) &
+ + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,b,i) )
+
+ tmp_4(ipoint,2,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,1,i,b)
+ tmp_4(ipoint,3,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,2,i,b)
+ tmp_4(ipoint,4,b) += loc_2 * int2_grad1_u12_bimo_t(ipoint,3,i,b)
+ tmp_4(ipoint,1,b) += 2.d0 * loc_2 * ( Jkappa(ipoint,1) * int2_grad1_u12_bimo_t(ipoint,1,i,b) &
+ + Jkappa(ipoint,2) * int2_grad1_u12_bimo_t(ipoint,2,i,b) &
+ + Jkappa(ipoint,3) * int2_grad1_u12_bimo_t(ipoint,3,i,b) )
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint, b, i, j, loc_1, loc_2, loc_3) &
+ !$OMP SHARED (n_points_final_grid, mo_num, elec_beta_num, &
+ !$OMP final_weight_at_r_vector, int2_grad1_u12_bimo_t, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP tmp_3, tmp_4)
+ !$OMP DO
+ do b = 1, mo_num
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ loc_1 = final_weight_at_r_vector(ipoint) * mos_l_in_r_array_transp(ipoint,j)
+ loc_2 = mos_r_in_r_array_transp(ipoint,b)
+ loc_3 = mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_3(ipoint,5,b) -= loc_1 * ( int2_grad1_u12_bimo_t(ipoint,1,b,i) * int2_grad1_u12_bimo_t(ipoint,1,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,2,b,i) * int2_grad1_u12_bimo_t(ipoint,2,i,j) &
+ + int2_grad1_u12_bimo_t(ipoint,3,b,i) * int2_grad1_u12_bimo_t(ipoint,3,i,j) )
+
+ tmp_4(ipoint,1,b) += ( loc_2 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i) ) &
+ - loc_3 * ( int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,b) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,b) ) )
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ call dgemm( 'T', 'N', mo_num, mo_num, 5*n_points_final_grid, 1.d0 &
+ , tmp_3(1,1,1), 5*n_points_final_grid &
+ , tmp_4(1,1,1), 5*n_points_final_grid &
+ , 1.d0, fock_3e_mo_cs(1,1), mo_num)
+
+ deallocate(tmp_3, tmp_4)
+ deallocate(Jkappa, Okappa)
+
+ ! ---
+
+END_PROVIDER
+
+! ---
+
diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
index eb8973ff..2df2421e 100644
--- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
+++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
@@ -1,4 +1,6 @@
+! ---
+
BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_tot, (mo_num,mo_num) ]
&BEGIN_PROVIDER [ double precision, Fock_matrix_tc_diag_mo_tot, (mo_num)]
@@ -23,9 +25,6 @@
integer :: i, j, n
double precision :: t0, t1
- !print*, ' Providing Fock_matrix_tc_mo_tot ...'
- !call wall_time(t0)
-
if(elec_alpha_num == elec_beta_num) then
PROVIDE Fock_matrix_tc_mo_alpha
@@ -158,8 +157,8 @@
Fock_matrix_tc_mo_tot += fock_3_mat
endif
- !call wall_time(t1)
- !print*, ' Wall time for Fock_matrix_tc_mo_tot =', t1-t0
-
END_PROVIDER
+! ---
+
+
diff --git a/plugins/local/tc_scf/fock_vartc.irp.f b/plugins/local/tc_scf/fock_vartc.irp.f
deleted file mode 100644
index 2b4a57e5..00000000
--- a/plugins/local/tc_scf/fock_vartc.irp.f
+++ /dev/null
@@ -1,287 +0,0 @@
-
-! ---
-
- BEGIN_PROVIDER [ double precision, two_e_vartc_integral_alpha, (ao_num, ao_num)]
-&BEGIN_PROVIDER [ double precision, two_e_vartc_integral_beta , (ao_num, ao_num)]
-
- implicit none
- integer :: i, j, k, l
- double precision :: density, density_a, density_b, I_coul, I_kjli
- double precision :: t0, t1
- double precision, allocatable :: tmp_a(:,:), tmp_b(:,:)
-
- two_e_vartc_integral_alpha = 0.d0
- two_e_vartc_integral_beta = 0.d0
-
- !$OMP PARALLEL DEFAULT (NONE) &
- !$OMP PRIVATE (i, j, k, l, density_a, density_b, density, tmp_a, tmp_b, I_coul, I_kjli) &
- !$OMP SHARED (ao_num, TCSCF_density_matrix_ao_alpha, TCSCF_density_matrix_ao_beta, ao_two_e_tc_tot, &
- !$OMP two_e_vartc_integral_alpha, two_e_vartc_integral_beta)
-
- allocate(tmp_a(ao_num,ao_num), tmp_b(ao_num,ao_num))
- tmp_a = 0.d0
- tmp_b = 0.d0
-
- !$OMP DO
- 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
- do i = 1, ao_num
- do k = 1, ao_num
-
- I_coul = density * ao_two_e_tc_tot(k,i,l,j)
- I_kjli = ao_two_e_tc_tot(k,j,l,i)
-
- tmp_a(k,i) += I_coul - density_a * I_kjli
- tmp_b(k,i) += I_coul - density_b * I_kjli
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- do i = 1, ao_num
- do j = 1, ao_num
- two_e_vartc_integral_alpha(j,i) += tmp_a(j,i)
- two_e_vartc_integral_beta (j,i) += tmp_b(j,i)
- enddo
- enddo
- !$OMP END CRITICAL
-
- deallocate(tmp_a, tmp_b)
- !$OMP END PARALLEL
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_alpha, (ao_num, ao_num)]
-
- implicit none
-
- Fock_matrix_vartc_ao_alpha = ao_one_e_integrals_tc_tot + two_e_vartc_integral_alpha
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_beta, (ao_num, ao_num)]
-
- implicit none
-
- Fock_matrix_vartc_ao_beta = ao_one_e_integrals_tc_tot + two_e_vartc_integral_beta
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_alpha, (mo_num, mo_num) ]
-
- implicit none
-
- call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_alpha, size(Fock_matrix_vartc_ao_alpha, 1) &
- , Fock_matrix_vartc_mo_alpha, size(Fock_matrix_vartc_mo_alpha, 1) )
- if(three_body_h_tc) then
- Fock_matrix_vartc_mo_alpha += fock_3e_uhf_mo_a
- endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_beta, (mo_num,mo_num) ]
-
- implicit none
-
- call ao_to_mo_bi_ortho( Fock_matrix_vartc_ao_beta, size(Fock_matrix_vartc_ao_beta, 1) &
- , Fock_matrix_vartc_mo_beta, size(Fock_matrix_vartc_mo_beta, 1) )
- if(three_body_h_tc) then
- Fock_matrix_vartc_mo_beta += fock_3e_uhf_mo_b
- endif
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, grad_vartc]
-
- implicit none
- integer :: i, k
- double precision :: grad_left, grad_right
-
- grad_left = 0.d0
- grad_right = 0.d0
-
- do i = 1, elec_beta_num ! doc --> SOMO
- do k = elec_beta_num+1, elec_alpha_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- do i = 1, elec_beta_num ! doc --> virt
- do k = elec_alpha_num+1, mo_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- do i = elec_beta_num+1, elec_alpha_num ! SOMO --> virt
- do k = elec_alpha_num+1, mo_num
- grad_left = max(grad_left , dabs(Fock_matrix_vartc_mo_tot(k,i)))
- grad_right = max(grad_right, dabs(Fock_matrix_vartc_mo_tot(i,k)))
- enddo
- enddo
-
- grad_vartc = grad_left + grad_right
-
-END_PROVIDER
-
-! ---
-
-BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_ao_tot, (ao_num, ao_num) ]
-
- implicit none
-
- call mo_to_ao_bi_ortho( Fock_matrix_vartc_mo_tot, size(Fock_matrix_vartc_mo_tot, 1) &
- , Fock_matrix_vartc_ao_tot, size(Fock_matrix_vartc_ao_tot, 1) )
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_mo_tot, (mo_num,mo_num) ]
-&BEGIN_PROVIDER [ double precision, Fock_matrix_vartc_diag_mo_tot, (mo_num)]
-
- implicit none
- integer :: i, j, n
-
- if(elec_alpha_num == elec_beta_num) then
- Fock_matrix_vartc_mo_tot = Fock_matrix_vartc_mo_alpha
- else
-
- do j = 1, elec_beta_num
- ! F-K
- do i = 1, elec_beta_num !CC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F+K/2
- do i = elec_beta_num+1, elec_alpha_num !CA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F
- do i = elec_alpha_num+1, mo_num !CV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- enddo
-
- do j = elec_beta_num+1, elec_alpha_num
- ! F+K/2
- do i = 1, elec_beta_num !AC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- + 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F
- do i = elec_beta_num+1, elec_alpha_num !AA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- ! F-K/2
- do i = elec_alpha_num+1, mo_num !AV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- enddo
-
- do j = elec_alpha_num+1, mo_num
- ! F
- do i = 1, elec_beta_num !VC
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))
- enddo
- ! F-K/2
- do i = elec_beta_num+1, elec_alpha_num !VA
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j))&
- - 0.5d0*(Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- ! F+K
- do i = elec_alpha_num+1, mo_num !VV
- Fock_matrix_vartc_mo_tot(i,j) = 0.5d0*(Fock_matrix_vartc_mo_alpha(i,j)+Fock_matrix_vartc_mo_beta(i,j)) &
- + (Fock_matrix_vartc_mo_beta(i,j) - Fock_matrix_vartc_mo_alpha(i,j))
- enddo
- enddo
- if(three_body_h_tc)then
- ! C-O
- do j = 1, elec_beta_num
- do i = elec_beta_num+1, elec_alpha_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- ! C-V
- do j = 1, elec_beta_num
- do i = elec_alpha_num+1, mo_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- ! O-V
- do j = elec_beta_num+1, elec_alpha_num
- do i = elec_alpha_num+1, mo_num
- Fock_matrix_vartc_mo_tot(i,j) += 0.5d0*(fock_a_tot_3e_bi_orth(i,j) + fock_b_tot_3e_bi_orth(i,j))
- Fock_matrix_vartc_mo_tot(j,i) += 0.5d0*(fock_a_tot_3e_bi_orth(j,i) + fock_b_tot_3e_bi_orth(j,i))
- enddo
- enddo
- endif
-
- endif
-
- do i = 1, mo_num
- Fock_matrix_vartc_diag_mo_tot(i) = Fock_matrix_vartc_mo_tot(i,i)
- enddo
-
- if(frozen_orb_scf)then
- integer :: iorb, jorb
- do i = 1, n_core_orb
- iorb = list_core(i)
- do j = 1, n_act_orb
- jorb = list_act(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- enddo
- endif
-
- if(no_oa_or_av_opt)then
- do i = 1, n_act_orb
- iorb = list_act(i)
- do j = 1, n_inact_orb
- jorb = list_inact(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- do j = 1, n_virt_orb
- jorb = list_virt(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- do j = 1, n_core_orb
- jorb = list_core(j)
- Fock_matrix_vartc_mo_tot(iorb,jorb) = 0.d0
- Fock_matrix_vartc_mo_tot(jorb,iorb) = 0.d0
- enddo
- enddo
- endif
-
- !call check_sym(Fock_matrix_vartc_mo_tot, mo_num)
- !do i = 1, mo_num
- ! write(*,'(100(F15.8, I4))') Fock_matrix_vartc_mo_tot(i,:)
- !enddo
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
index 431b6e08..853c4ab5 100644
--- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
@@ -234,7 +234,7 @@ subroutine rh_tcscf_diis()
call unlock_io
if(er_delta .lt. 0.d0) then
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
+ call ezfio_set_tc_scf_tcscf_energy(etc_tot)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
write(json_unit, json_true_fmt) 'saved'
@@ -263,7 +263,7 @@ subroutine rh_tcscf_diis()
deallocate(mo_r_coef_save, mo_l_coef_save, F_DIIS, E_DIIS)
- call ezfio_set_tc_scf_bitc_energy(TC_HF_energy)
+ call ezfio_set_tc_scf_tcscf_energy(TC_HF_energy)
call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f
index 0b79e8ea..2c2cf2c2 100644
--- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_simple.irp.f
@@ -91,7 +91,7 @@ subroutine rh_tcscf_simple()
e_delta = dabs(etc_tot - e_save)
e_save = etc_tot
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
+ call ezfio_set_tc_scf_tcscf_energy(etc_tot)
call wall_time(t1)
write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
diff --git a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f b/plugins/local/tc_scf/rh_vartcscf_simple.irp.f
deleted file mode 100644
index ecb0709e..00000000
--- a/plugins/local/tc_scf/rh_vartcscf_simple.irp.f
+++ /dev/null
@@ -1,89 +0,0 @@
-! ---
-
-subroutine rh_vartcscf_simple()
-
- implicit none
- integer :: i, j, it, dim_DIIS
- double precision :: t0, t1
- double precision :: e_save, e_delta, rho_delta
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e
- double precision :: er_DIIS
-
-
- it = 0
- e_save = 0.d0
- dim_DIIS = 0
-
- ! ---
-
- PROVIDE level_shift_tcscf
- PROVIDE mo_r_coef
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '====', '========'
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- , ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '====', '========'
-
-
- ! first iteration (HF orbitals)
- call wall_time(t0)
-
- etc_tot = VARTC_HF_energy
- etc_1e = VARTC_HF_one_e_energy
- etc_2e = VARTC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
- do while(er_DIIS .gt. dsqrt(thresh_tcscf))
- call wall_time(t0)
-
- it += 1
- if(it > n_it_tcscf_max) then
- print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
- stop
- endif
-
- mo_r_coef = fock_vartc_eigvec_ao
- mo_l_coef = mo_r_coef
- 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
-
- etc_tot = VARTC_HF_energy
- etc_1e = VARTC_HF_one_e_energy
- etc_2e = VARTC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call ezfio_set_tc_scf_bitc_energy(etc_tot)
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
- enddo
-
- print *, ' VAR-TCSCF Simple converged !'
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index 768069d6..ee8e8dad 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -13,7 +13,6 @@ program tc_scf
PROVIDE j1e_type
PROVIDE j2e_type
PROVIDE tcscf_algorithm
- PROVIDE var_tc
print *, ' TC-SCF with:'
print *, ' j1e_type = ', j1e_type
@@ -45,46 +44,29 @@ program tc_scf
!call create_guess()
!call orthonormalize_mos()
-
- if(var_tc) then
-
- print *, ' VAR-TC'
-
- if(tcscf_algorithm == 'DIIS') then
- print*, ' NOT implemented yet'
- elseif(tcscf_algorithm == 'Simple') then
- call rh_vartcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
-
+ if(tcscf_algorithm == 'DIIS') then
+ call rh_tcscf_diis()
+ elseif(tcscf_algorithm == 'Simple') then
+ call rh_tcscf_simple()
else
-
- if(tcscf_algorithm == 'DIIS') then
- call rh_tcscf_diis()
- elseif(tcscf_algorithm == 'Simple') then
- call rh_tcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
-
- PROVIDE Fock_matrix_tc_diag_mo_tot
- print*, ' Eigenvalues:'
- do i = 1, mo_num
- print*, i, Fock_matrix_tc_diag_mo_tot(i)
- enddo
-
- ! TODO
- ! rotate angles in separate code only if necessary
- if(minimize_lr_angles)then
- call minimize_tc_orb_angles()
- endif
- call print_energy_and_mos(good_angles)
-
+ print *, ' not implemented yet', tcscf_algorithm
+ stop
endif
+ PROVIDE Fock_matrix_tc_diag_mo_tot
+ print*, ' Eigenvalues:'
+ do i = 1, mo_num
+ print*, i, Fock_matrix_tc_diag_mo_tot(i)
+ enddo
+
+ ! TODO
+ ! rotate angles in separate code only if necessary
+ if(minimize_lr_angles)then
+ call minimize_tc_orb_angles()
+ endif
+ call print_energy_and_mos(good_angles)
+
+
write(json_unit,json_array_close_fmtx)
call json_close
diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f
index 833b48aa..0266c605 100644
--- a/plugins/local/tc_scf/tc_scf_energy.irp.f
+++ b/plugins/local/tc_scf/tc_scf_energy.irp.f
@@ -11,11 +11,8 @@
integer :: i, j
double precision :: t0, t1
- !print*, ' Providing TC energy ...'
- !call wall_time(t0)
-
PROVIDE mo_l_coef mo_r_coef
- PROVIDE two_e_tc_non_hermit_integral_alpha two_e_tc_non_hermit_integral_beta
+ PROVIDE two_e_tc_integral_alpha two_e_tc_integral_beta
TC_HF_energy = nuclear_repulsion
TC_HF_one_e_energy = 0.d0
@@ -23,8 +20,8 @@
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_two_e_energy += 0.5d0 * ( two_e_tc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
+ + two_e_tc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
TC_HF_one_e_energy += ao_one_e_integrals_tc_tot(i,j) &
* (TCSCF_density_matrix_ao_alpha(i,j) + TCSCF_density_matrix_ao_beta (i,j) )
enddo
@@ -33,38 +30,6 @@
TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy
TC_HF_energy += diag_three_elem_hf
- !call wall_time(t1)
- !print*, ' Wall time for TC energy=', t1-t0
-
-END_PROVIDER
-
-! ---
-
- BEGIN_PROVIDER [ double precision, VARTC_HF_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_one_e_energy]
-&BEGIN_PROVIDER [ double precision, VARTC_HF_two_e_energy]
-
- implicit none
- integer :: i, j
-
- PROVIDE mo_r_coef
-
- VARTC_HF_energy = nuclear_repulsion
- VARTC_HF_one_e_energy = 0.d0
- VARTC_HF_two_e_energy = 0.d0
-
- do j = 1, ao_num
- do i = 1, ao_num
- VARTC_HF_two_e_energy += 0.5d0 * ( two_e_vartc_integral_alpha(i,j) * TCSCF_density_matrix_ao_alpha(i,j) &
- + two_e_vartc_integral_beta (i,j) * TCSCF_density_matrix_ao_beta (i,j) )
- VARTC_HF_one_e_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
-
- VARTC_HF_energy += VARTC_HF_one_e_energy + VARTC_HF_two_e_energy
- VARTC_HF_energy += diag_three_elem_hf
-
END_PROVIDER
! ---
diff --git a/plugins/local/tc_scf/test_int.irp.f b/plugins/local/tc_scf/test_int.irp.f
deleted file mode 100644
index e135fcd8..00000000
--- a/plugins/local/tc_scf/test_int.irp.f
+++ /dev/null
@@ -1,970 +0,0 @@
-program test_ints
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, ' starting test_ints ...'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- my_extra_grid_becke = .True.
- my_n_pt_r_extra_grid = 30
- my_n_pt_a_extra_grid = 50 ! small extra_grid for quick debug
- touch my_extra_grid_becke my_n_pt_r_extra_grid my_n_pt_a_extra_grid
-
-!! OK
-! call routine_int2_u_grad1u_env2
-! OK
-! call routine_v_ij_erf_rk_cst_mu_env
-! OK
-! call routine_x_v_ij_erf_rk_cst_mu_env
-! OK
-! call routine_int2_u2_env2
-! OK
-! call routine_int2_u_grad1u_x_env2
-! OK
-! call routine_int2_grad1u2_grad2u2_env2
-! call routine_int2_u_grad1u_env2
-! call test_int2_grad1_u12_ao_test
-! call routine_v_ij_u_cst_mu_env_test
-! call test_grid_points_ao
- !call test_int_gauss
-
- !call test_fock_3e_uhf_ao()
- !call test_fock_3e_uhf_mo()
-
- !call test_two_e_tc_non_hermit_integral()
-
-!!PROVIDE TC_HF_energy VARTC_HF_energy
-!!print *, ' TC_HF_energy = ', TC_HF_energy
-!!print *, ' VARTC_HF_energy = ', VARTC_HF_energy
-
- call test_fock_3e_uhf_mo_cs()
- call test_fock_3e_uhf_mo_a()
- call test_fock_3e_uhf_mo_b()
-
-end
-
-! ---
-
-subroutine routine_test_env
- implicit none
- integer :: i,icount,j
- icount = 0
- do i = 1, List_env1s_square_size
- if(dabs(List_env1s_square_coef(i)).gt.1.d-10)then
- print*,''
- print*,List_env1s_square_expo(i),List_env1s_square_coef(i)
- print*,List_env1s_square_cent(1:3,i)
- print*,''
- icount += 1
- endif
-
- enddo
- print*,'List_env1s_square_coef,icount = ',List_env1s_square_size,icount
- do i = 1, ao_num
- do j = 1, ao_num
- do icount = 1, List_comb_thr_b3_size(j,i)
- print*,'',j,i
- print*,List_comb_thr_b3_expo(icount,j,i),List_comb_thr_b3_coef(icount,j,i)
- print*,List_comb_thr_b3_cent(1:3,icount,j,i)
- print*,''
- enddo
-! enddo
- enddo
- enddo
- print*,'max_List_comb_thr_b3_size = ',max_List_comb_thr_b3_size,List_env1s_square_size
-
-end
-
-subroutine routine_int2_u_grad1u_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_u_grad1u_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u_grad1u_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_erf_rk_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_erf_rk_cst_mu_env(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-subroutine routine_x_v_ij_erf_rk_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- do m = 1, 3
- array(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += x_v_ij_erf_rk_cst_mu_env (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
-
- print*,'******'
- print*,'******'
- print*,'routine_x_v_ij_erf_rk_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-
-subroutine routine_v_ij_u_cst_mu_env_test
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env_test'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-subroutine routine_int2_grad1u2_grad2u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- integer :: ii , jj
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- double precision, allocatable :: ints(:,:,:)
- allocate(ints(ao_num, ao_num, n_points_final_grid))
-! do ipoint = 1, n_points_final_grid
-! do i = 1, ao_num
-! do j = 1, ao_num
-! read(33,*)ints(j,i,ipoint)
-! enddo
-! enddo
-! enddo
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! !array(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! !array(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! array_ref(j,i,l,k) += int2_grad1u2_grad2u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += ints(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
-! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-! if(dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint)).gt.1.d-6)then
-! print*,j,i,ipoint
-! print*,int2_grad1u2_grad2u2_env2_test(j,i,ipoint) , int2_grad1u2_grad2u2_env2_test(j,i,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(j,i,ipoint) - int2_grad1u2_grad2u2_env2_test(j,i,ipoint))
-! print*,int2_grad1u2_grad2u2_env2_test(i,j,ipoint) , int2_grad1u2_grad2u2_env2_test(i,j,ipoint), dabs(int2_grad1u2_grad2u2_env2_test(i,j,ipoint) - int2_grad1u2_grad2u2_env2_test(i,j,ipoint))
-! stop
-! endif
-! endif
- enddo
- enddo
- enddo
- enddo
- enddo
- double precision :: e_ref, e_new
- accu_relat = 0.d0
- accu_abs = 0.d0
- e_ref = 0.d0
- e_new = 0.d0
- do ii = 1, elec_alpha_num
- do jj = ii, elec_alpha_num
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- e_ref += mo_coef(j,ii) * mo_coef(i,ii) * array_ref(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
- e_new += mo_coef(j,ii) * mo_coef(i,ii) * array(j,i,l,k) * mo_coef(l,jj) * mo_coef(k,jj)
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
-! if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
-! accu_relat += contrib/dabs(array_ref(j,i,l,k))
-! endif
- enddo
- enddo
- enddo
- enddo
-
- enddo
- enddo
- print*,'e_ref = ',e_ref
- print*,'e_new = ',e_new
-! print*,'accu_abs = ',accu_abs/dble(ao_num)**4
-! print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_int2_u2_env2
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_u2_env2_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u2_env2(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u2_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-
-subroutine routine_int2_u_grad1u_x_env2
- implicit none
- integer :: i,j,ipoint,k,l,m
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- do m = 1, 3
- array(j,i,l,k) += int2_u_grad1u_x_env2_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_u_grad1u_x_env2 (j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_int2_u_grad1u_x_env2'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-
-
-end
-
-subroutine routine_v_ij_u_cst_mu_env
- implicit none
- integer :: i,j,ipoint,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
-
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += v_ij_u_cst_mu_env_test(j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += v_ij_u_cst_mu_env_fit (j,i,ipoint) * aos_in_r_array(k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'routine_v_ij_u_cst_mu_env'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_ao()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff_ij, thr_ih, norm
- double precision, allocatable :: fock_3e_uhf_ao_a_mo(:,:), fock_3e_uhf_ao_b_mo(:,:)
-
- thr_ih = 1d-7
-
- PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
- PROVIDE fock_3e_uhf_ao_a fock_3e_uhf_ao_b
-
- ! ---
-
- allocate(fock_3e_uhf_ao_a_mo(mo_num,mo_num))
- call ao_to_mo_bi_ortho( fock_3e_uhf_ao_a , size(fock_3e_uhf_ao_a , 1) &
- , fock_3e_uhf_ao_a_mo, size(fock_3e_uhf_ao_a_mo, 1) )
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_ao_a_mo(j,i) - fock_a_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_ao_a_mo (j,i)
- !stop
- endif
-
- norm += dabs(fock_a_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_a = ', diff_tot / norm
- print *, ' '
-
- deallocate(fock_3e_uhf_ao_a_mo)
-
- ! ---
-
- allocate(fock_3e_uhf_ao_b_mo(mo_num,mo_num))
- call ao_to_mo_bi_ortho( fock_3e_uhf_ao_b , size(fock_3e_uhf_ao_b , 1) &
- , fock_3e_uhf_ao_b_mo, size(fock_3e_uhf_ao_b_mo, 1) )
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_ao_b_mo(j,i) - fock_b_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_ao_b_mo (j,i)
- !stop
- endif
-
- norm += dabs(fock_b_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_b = ', diff_tot/norm
- print *, ' '
-
- deallocate(fock_3e_uhf_ao_b_mo)
-
- ! ---
-
-end subroutine test_fock_3e_uhf_ao()
-
-! ---
-
-subroutine test_fock_3e_uhf_mo()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff_ij, thr_ih, norm
-
- thr_ih = 1d-12
-
- PROVIDE fock_a_tot_3e_bi_orth fock_b_tot_3e_bi_orth
- PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_b
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_mo_a(j,i) - fock_a_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_a_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_mo_a (j,i)
- !stop
- endif
-
- norm += dabs(fock_a_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_a = ', diff_tot / norm
- print *, ' norm_a = ', norm
- print *, ' '
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, mo_num
- do j = 1, mo_num
-
- diff_ij = dabs(fock_3e_uhf_mo_b(j,i) - fock_b_tot_3e_bi_orth(j,i))
- if(diff_ij .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' MANU : ', fock_b_tot_3e_bi_orth(j,i)
- print *, ' UHF : ', fock_3e_uhf_mo_b (j,i)
- !stop
- endif
-
- norm += dabs(fock_b_tot_3e_bi_orth(j,i))
- diff_tot += diff_ij
- enddo
- enddo
- print *, ' diff on F_b = ', diff_tot/norm
- print *, ' norm_b = ', norm
- print *, ' '
-
- ! ---
-
-end
-
-! ---
-
-subroutine test_grid_points_ao
- implicit none
- integer :: i,j,ipoint,icount,icount_good, icount_bad,icount_full
- double precision :: thr
- thr = 1.d-10
-! print*,'max_n_pts_grid_ao_prod = ',max_n_pts_grid_ao_prod
-! print*,'n_pts_grid_ao_prod'
- do i = 1, ao_num
- do j = i, ao_num
- icount = 0
- icount_good = 0
- icount_bad = 0
- icount_full = 0
- do ipoint = 1, n_points_final_grid
-! if(dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,1)) &
-! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,2)) &
-! + dabs(int2_u_grad1u_x_env2_test(j,i,ipoint,3)) )
-! if(dabs(int2_u2_env2_test(j,i,ipoint)).gt.thr)then
-! icount += 1
-! endif
- if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
- icount_full += 1
- endif
- if(dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)).gt.thr)then
- icount += 1
- if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr*0.1d0)then
- icount_good += 1
- else
- print*,j,i,ipoint
- print*,dabs(v_ij_u_cst_mu_env_test(j,i,ipoint)), dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)),dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint))/dabs(v_ij_u_cst_mu_env_test(j,i,ipoint))
- icount_bad += 1
- endif
- endif
-! if(dabs(v_ij_u_cst_mu_env_ng_1_test(j,i,ipoint)).gt.thr)then
-! endif
- enddo
- print*,''
- print*,j,i
- print*,icount,icount_full, icount_bad!,n_pts_grid_ao_prod(j,i)
- print*,dble(icount)/dble(n_points_final_grid),dble(icount_full)/dble(n_points_final_grid)
-! dble(n_pts_grid_ao_prod(j,i))/dble(n_points_final_grid)
-! if(icount.gt.n_pts_grid_ao_prod(j,i))then
-! print*,'pb !!'
-! endif
- enddo
- enddo
-end
-
-subroutine test_int_gauss
- implicit none
- integer :: i,j
- print*,'center'
- do i = 1, ao_num
- do j = i, ao_num
- print*,j,i
- print*,ao_prod_sigma(j,i),ao_overlap_abs_grid(j,i)
- print*,ao_prod_center(1:3,j,i)
- enddo
- enddo
- print*,''
- double precision :: weight, r(3),integral_1,pi,center(3),f_r,alpha,distance,integral_2
- center = 0.d0
- pi = dacos(-1.d0)
- integral_1 = 0.d0
- integral_2 = 0.d0
- alpha = 0.75d0
- do i = 1, n_points_final_grid
- ! you get x, y and z of the ith grid point
- r(1) = final_grid_points(1,i)
- r(2) = final_grid_points(2,i)
- r(3) = final_grid_points(3,i)
- weight = final_weight_at_r_vector(i)
- distance = dsqrt( (r(1) - center(1))**2 + (r(2) - center(2))**2 + (r(3) - center(3))**2 )
- f_r = dexp(-alpha * distance*distance)
- ! you add the contribution of the grid point to the integral
- integral_1 += f_r * weight
- integral_2 += f_r * distance * weight
- enddo
- print*,'integral_1 =',integral_1
- print*,'(pi/alpha)**1.5 =',(pi / alpha)**1.5
- print*,'integral_2 =',integral_2
- print*,'(pi/alpha)**1.5 =',2.d0*pi / (alpha)**2
-
-
-end
-
-! ---
-
-subroutine test_two_e_tc_non_hermit_integral()
-
- implicit none
- integer :: i, j
- double precision :: diff_tot, diff, thr_ih, norm
-
- thr_ih = 1d-10
-
- PROVIDE two_e_tc_non_hermit_integral_beta two_e_tc_non_hermit_integral_alpha
- PROVIDE two_e_tc_non_hermit_integral_seq_beta two_e_tc_non_hermit_integral_seq_alpha
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, ao_num
- do j = 1, ao_num
-
- diff = dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i) - two_e_tc_non_hermit_integral_alpha(j,i))
- if(diff .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' seq : ', two_e_tc_non_hermit_integral_seq_alpha(j,i)
- print *, ' // : ', two_e_tc_non_hermit_integral_alpha (j,i)
- !stop
- endif
-
- norm += dabs(two_e_tc_non_hermit_integral_seq_alpha(j,i))
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot a = ', diff_tot / norm
- print *, ' norm a = ', norm
- print *, ' '
-
- ! ---
-
- norm = 0.d0
- diff_tot = 0.d0
- do i = 1, ao_num
- do j = 1, ao_num
-
- diff = dabs(two_e_tc_non_hermit_integral_seq_beta(j,i) - two_e_tc_non_hermit_integral_beta(j,i))
- if(diff .gt. thr_ih) then
- print *, ' difference on ', j, i
- print *, ' seq : ', two_e_tc_non_hermit_integral_seq_beta(j,i)
- print *, ' // : ', two_e_tc_non_hermit_integral_beta (j,i)
- !stop
- endif
-
- norm += dabs(two_e_tc_non_hermit_integral_seq_beta(j,i))
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot b = ', diff_tot / norm
- print *, ' norm b = ', norm
- print *, ' '
-
- ! ---
-
- return
-
-end
-
-! ---
-
-subroutine test_int2_grad1_u12_ao_test
- implicit none
- integer :: i,j,ipoint,m,k,l
- double precision :: weight,accu_relat, accu_abs, contrib
- double precision, allocatable :: array(:,:,:,:), array_ref(:,:,:,:)
- allocate(array(ao_num, ao_num, ao_num, ao_num))
- array = 0.d0
- allocate(array_ref(ao_num, ao_num, ao_num, ao_num))
- array_ref = 0.d0
- do m = 1, 3
- do ipoint = 1, n_points_final_grid
- weight = final_weight_at_r_vector(ipoint)
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- array(j,i,l,k) += int2_grad1_u12_ao_test(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- array_ref(j,i,l,k) += int2_grad1_u12_ao(j,i,ipoint,m) * aos_grad_in_r_array_transp(m,k,ipoint) * aos_in_r_array(l,ipoint) * weight
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
-
- accu_relat = 0.d0
- accu_abs = 0.d0
- do k = 1, ao_num
- do l = 1, ao_num
- do i = 1, ao_num
- do j = 1, ao_num
- contrib = dabs(array(j,i,l,k) - array_ref(j,i,l,k))
- accu_abs += contrib
- if(dabs(array_ref(j,i,l,k)).gt.1.d-10)then
- accu_relat += contrib/dabs(array_ref(j,i,l,k))
- endif
- enddo
- enddo
- enddo
- enddo
- print*,'******'
- print*,'******'
- print*,'test_int2_grad1_u12_ao_test'
- print*,'accu_abs = ',accu_abs/dble(ao_num)**4
- print*,'accu_relat = ',accu_relat/dble(ao_num)**4
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_cs()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
-! double precision :: t0, t1
-! print*, ' Providing fock_a_tot_3e_bi_orth ...'
-! call wall_time(t0)
-! PROVIDE fock_a_tot_3e_bi_orth
-! call wall_time(t1)
-! print*, ' Wall time for fock_a_tot_3e_bi_orth =', t1 - t0
-
- PROVIDE fock_3e_uhf_mo_cs fock_3e_uhf_mo_cs_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_cs_old(j,i)
- I_new = fock_3e_uhf_mo_cs (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_cs on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_a()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
- PROVIDE fock_3e_uhf_mo_a fock_3e_uhf_mo_a_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_a_old(j,i)
- I_new = fock_3e_uhf_mo_a (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_a on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
-subroutine test_fock_3e_uhf_mo_b()
-
- implicit none
- integer :: i, j
- double precision :: I_old, I_new
- double precision :: diff_tot, diff, thr_ih, norm
-
- PROVIDE fock_3e_uhf_mo_b fock_3e_uhf_mo_b_old
-
- thr_ih = 1d-8
- norm = 0.d0
- diff_tot = 0.d0
-
- do i = 1, mo_num
- do j = 1, mo_num
-
- I_old = fock_3e_uhf_mo_b_old(j,i)
- I_new = fock_3e_uhf_mo_b (j,i)
-
- diff = dabs(I_old - I_new)
- if(diff .gt. thr_ih) then
- print *, ' problem in fock_3e_uhf_mo_b on ', j, i
- print *, ' old value = ', I_old
- print *, ' new value = ', I_new
- !stop
- endif
-
- norm += dabs(I_old)
- diff_tot += diff
- enddo
- enddo
-
- print *, ' diff tot (%) = ', 100.d0 * diff_tot / norm
-
- return
-end
-
-! ---
-
diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f
index 16a52dc6..e054e22c 100644
--- a/src/becke_numerical_grid/extra_grid_vector.irp.f
+++ b/src/becke_numerical_grid/extra_grid_vector.irp.f
@@ -70,17 +70,6 @@ END_PROVIDER
index_final_points_extra(2,i_count) = i
index_final_points_extra(3,i_count) = j
index_final_points_extra_reverse(k,i,j) = i_count
-
- if(final_weight_at_r_vector_extra(i_count) .lt. 0.d0) then
- print *, ' !!! WARNING !!!'
- print *, ' negative weight !!!!'
- print *, i_count, final_weight_at_r_vector_extra(i_count)
- if(dabs(final_weight_at_r_vector_extra(i_count)) .lt. 1d-10) then
- final_weight_at_r_vector_extra(i_count) = 0.d0
- else
- stop
- endif
- endif
enddo
enddo
enddo
diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f
index c35918c3..9da8a099 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -67,17 +67,6 @@ END_PROVIDER
index_final_points(2,i_count) = i
index_final_points(3,i_count) = j
index_final_points_reverse(k,i,j) = i_count
-
- if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
- print *, ' !!! WARNING !!!'
- print *, ' negative weight !!!!'
- print *, i_count, final_weight_at_r_vector(i_count)
- if(dabs(final_weight_at_r_vector(i_count)) .lt. 1d-10) then
- final_weight_at_r_vector(i_count) = 0.d0
- else
- stop
- endif
- endif
enddo
enddo
enddo
diff --git a/src/utils/util.irp.f b/src/utils/util.irp.f
index 97cbde67..c67bbf03 100644
--- a/src/utils/util.irp.f
+++ b/src/utils/util.irp.f
@@ -576,7 +576,7 @@ logical function is_same_spin(sigma_1, sigma_2)
is_same_spin = .false.
endif
-end function is_same_spin
+end
! ---
@@ -596,7 +596,7 @@ function Kronecker_delta(i, j) result(delta)
delta = 0.d0
endif
-end function Kronecker_delta
+end
! ---
@@ -634,7 +634,81 @@ subroutine diagonalize_sym_matrix(N, A, e)
print*,'Problem in diagonalize_sym_matrix (dsyev)!!'
endif
-end subroutine diagonalize_sym_matrix
+end
+
+! ---
+
+
+subroutine give_degen(A, n, shift, list_degen, n_degen_list)
+
+ BEGIN_DOC
+ ! returns n_degen_list :: the number of degenerated SET of elements (i.e. with |A(i)-A(i+1)| below shift)
+ !
+ ! for each of these sets, list_degen(1,i) = first degenerate element of the set i,
+ !
+ ! list_degen(2,i) = last degenerate element of the set i.
+ END_DOC
+
+ implicit none
+
+ double precision, intent(in) :: A(n)
+ double precision, intent(in) :: shift
+ integer, intent(in) :: n
+ integer, intent(out) :: list_degen(2,n), n_degen_list
+
+ integer :: i, j, n_degen, k
+ logical :: keep_on
+ double precision, allocatable :: Aw(:)
+
+ list_degen = -1
+ allocate(Aw(n))
+ Aw = A
+ i=1
+ k = 0
+ do while(i.lt.n)
+ if(dabs(Aw(i)-Aw(i+1)).lt.shift)then
+ k+=1
+ j=1
+ list_degen(1,k) = i
+ keep_on = .True.
+ do while(keep_on)
+ if(i+j.gt.n)then
+ keep_on = .False.
+ exit
+ endif
+ if(dabs(Aw(i)-Aw(i+j)).lt.shift)then
+ j+=1
+ else
+ keep_on=.False.
+ exit
+ endif
+ enddo
+ n_degen = j
+ list_degen(2,k) = list_degen(1,k)-1 + n_degen
+ j=0
+ keep_on = .True.
+ do while(keep_on)
+ if(i+j+1.gt.n)then
+ keep_on = .False.
+ exit
+ endif
+ if(dabs(Aw(i+j)-Aw(i+j+1)).lt.shift)then
+ Aw(i+j) += (j-n_degen/2) * shift
+ j+=1
+ else
+ keep_on = .False.
+ exit
+ endif
+ enddo
+ Aw(i+n_degen-1) += (n_degen-1-n_degen/2) * shift
+ i+=n_degen
+ else
+ i+=1
+ endif
+ enddo
+ n_degen_list = k
+
+end
! ---
From da8eac81e01e9ee558351195aba1f964ed5fbc0b Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Wed, 1 May 2024 21:52:00 +0200
Subject: [PATCH 114/140] TC-SCF CLEANED
---
plugins/local/bi_ort_ints/no_dressing.irp.f | 7 +-
plugins/local/tc_scf/EZFIO.cfg | 36 +
plugins/local/tc_scf/fock_hermit.irp.f | 107 ---
plugins/local/tc_scf/fock_tc.irp.f | 40 +-
plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 19 +-
plugins/local/tc_scf/fock_three_hermit.irp.f | 771 ------------------
.../local/tc_scf/integrals_in_r_stuff.irp.f | 391 ---------
plugins/local/tc_scf/jast_schmos_90.irp.f | 318 --------
plugins/local/tc_scf/plot_j_schMos.irp.f | 69 --
plugins/local/tc_scf/print_fit_param.irp.f | 59 --
plugins/local/tc_scf/print_tcscf_energy.irp.f | 55 --
plugins/local/tc_scf/rh_tcscf_simple.irp.f | 129 ---
.../local/tc_scf/rotate_tcscf_orbitals.irp.f | 369 ---------
.../local/tc_scf/tc_petermann_factor.irp.f | 91 ---
plugins/local/tc_scf/tc_scf.irp.f | 25 +-
plugins/local/tc_scf/tc_scf_dm.irp.f | 24 +-
plugins/local/tc_scf/tc_scf_energy.irp.f | 423 ++++++++++
plugins/local/tc_scf/tcscf_energy_naive.irp.f | 80 --
.../tc_scf/three_e_energy_bi_ortho.irp.f | 189 -----
.../local/tc_scf/write_ao_2e_tc_integ.irp.f | 6 +-
20 files changed, 502 insertions(+), 2706 deletions(-)
delete mode 100644 plugins/local/tc_scf/fock_hermit.irp.f
delete mode 100644 plugins/local/tc_scf/fock_three_hermit.irp.f
delete mode 100644 plugins/local/tc_scf/integrals_in_r_stuff.irp.f
delete mode 100644 plugins/local/tc_scf/jast_schmos_90.irp.f
delete mode 100644 plugins/local/tc_scf/plot_j_schMos.irp.f
delete mode 100644 plugins/local/tc_scf/print_fit_param.irp.f
delete mode 100644 plugins/local/tc_scf/print_tcscf_energy.irp.f
delete mode 100644 plugins/local/tc_scf/rh_tcscf_simple.irp.f
delete mode 100644 plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
delete mode 100644 plugins/local/tc_scf/tc_petermann_factor.irp.f
delete mode 100644 plugins/local/tc_scf/tcscf_energy_naive.irp.f
delete mode 100644 plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f
index bd225274..721ac0f8 100644
--- a/plugins/local/bi_ort_ints/no_dressing.irp.f
+++ b/plugins/local/bi_ort_ints/no_dressing.irp.f
@@ -322,6 +322,12 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, noL_0e]
+ BEGIN_DOC
+ !
+ ! < Phi_left | L | Phi_right >
+ !
+ END_DOC
+
implicit none
integer :: i, j, k, ipoint
double precision :: t0, t1
@@ -330,7 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
call wall_time(t0)
print*, " Providing noL_0e ..."
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 510c777c..6820a8b0 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -9,3 +9,39 @@ doc: If |true|, tc-scf has converged
interface: ezfio,provider,ocaml
default: False
+[max_dim_diis_tcscf]
+type: integer
+doc: Maximum size of the DIIS extrapolation procedure
+interface: ezfio,provider,ocaml
+default: 15
+
+[level_shift_tcscf]
+type: Positive_float
+doc: Energy shift on the virtual MOs to improve TCSCF convergence
+interface: ezfio,provider,ocaml
+default: 0.
+
+[im_thresh_tcscf]
+type: Threshold
+doc: Thresholds on the Imag part of energy
+interface: ezfio,provider,ocaml
+default: 1.e-7
+
+[thresh_tcscf]
+type: Threshold
+doc: Threshold on the convergence of the Hartree Fock energy.
+interface: ezfio,provider,ocaml
+default: 1.e-8
+
+[n_it_tcscf_max]
+type: Strictly_positive_int
+doc: Maximum number of SCF iterations
+interface: ezfio,provider,ocaml
+default: 50
+
+[tc_Brillouin_Right]
+type: logical
+doc: If |true|, impose only right-Brillouin condition
+interface: ezfio,provider,ocaml
+default: False
+
diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f
deleted file mode 100644
index 5a51b324..00000000
--- a/plugins/local/tc_scf/fock_hermit.irp.f
+++ /dev/null
@@ -1,107 +0,0 @@
-
-! ---
-
-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/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f
index 508f3cd7..16bb5c87 100644
--- a/plugins/local/tc_scf/fock_tc.irp.f
+++ b/plugins/local/tc_scf/fock_tc.irp.f
@@ -110,23 +110,14 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
double precision :: t0, t1, tt0, tt1
double precision, allocatable :: tmp(:,:)
- if(bi_ortho) then
+ PROVIDE mo_l_coef mo_r_coef
- PROVIDE mo_l_coef mo_r_coef
-
- 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) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_mo_a
- Fock_matrix_tc_mo_alpha += fock_3e_mo_a
- endif
-
- 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) )
+ 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) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_a
+ Fock_matrix_tc_mo_alpha += fock_3e_mo_a
endif
END_PROVIDER
@@ -142,21 +133,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
implicit none
double precision, allocatable :: tmp(:,:)
- 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) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_mo_b
- Fock_matrix_tc_mo_beta += fock_3e_mo_b
- endif
-
- 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) )
+ 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) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_b
+ Fock_matrix_tc_mo_beta += fock_3e_mo_b
endif
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
index 2df2421e..fd490af6 100644
--- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
+++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
@@ -132,7 +132,7 @@
enddo
endif
- if(no_oa_or_av_opt)then
+ if(no_oa_or_av_opt) then
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
@@ -153,8 +153,21 @@
enddo
endif
- if(.not.bi_ortho .and. three_body_h_tc)then
- Fock_matrix_tc_mo_tot += fock_3_mat
+ if(tc_Brillouin_Right) then
+
+ double precision, allocatable :: tmp(:,:)
+ allocate(tmp(mo_num,mo_num))
+
+ tmp = Fock_matrix_tc_mo_tot
+ do j = 1, mo_num
+ do i = 1, j-1
+ tmp(i,j) = Fock_matrix_tc_mo_tot(j,i)
+ enddo
+ enddo
+
+ Fock_matrix_tc_mo_tot = tmp
+ deallocate(tmp)
+
endif
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f
deleted file mode 100644
index 00d47fae..00000000
--- a/plugins/local/tc_scf/fock_three_hermit.irp.f
+++ /dev/null
@@ -1,771 +0,0 @@
-
-! ---
-
-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
- !else if(bi_ortho.and.three_body_h_tc) then
- !! !$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
- double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
- double precision, allocatable :: tmp(:)
- double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
- double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
- double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' providing diag_three_elem_hf'
-
- if(.not. three_body_h_tc) then
-
- if(noL_standard) then
- PROVIDE noL_0e
- diag_three_elem_hf = noL_0e
- else
- diag_three_elem_hf = 0.d0
- endif
-
- else
-
- if(.not. bi_ortho) 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
-
- ! ------------
- ! SLOW VERSION
- ! ------------
-
- !call give_aaa_contrib(integral_aaa)
- !call give_aab_contrib(integral_aab)
- !call give_abb_contrib(integral_abb)
- !call give_bbb_contrib(integral_bbb)
- !diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
-
- ! ------------
- ! ------------
-
- PROVIDE int2_grad1_u12_bimo_t
- PROVIDE mos_l_in_r_array_transp
- PROVIDE mos_r_in_r_array_transp
-
- if(elec_alpha_num .eq. elec_beta_num) then
-
- allocate(tmp(elec_beta_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- else
-
- allocate(tmp(elec_alpha_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = elec_beta_num+1, elec_alpha_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- endif
-
-
- endif
-
- 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
- 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
-
-
-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/plugins/local/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
deleted file mode 100644
index 3ce85a97..00000000
--- a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
+++ /dev/null
@@ -1,391 +0,0 @@
-
-! ---
-
-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/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f
deleted file mode 100644
index 5c5e625f..00000000
--- a/plugins/local/tc_scf/jast_schmos_90.irp.f
+++ /dev/null
@@ -1,318 +0,0 @@
- BEGIN_PROVIDER [integer , m_max_sm_7]
-&BEGIN_PROVIDER [integer , n_max_sm_7]
-&BEGIN_PROVIDER [integer , o_max_sm_7]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_7 version of Table IV
- END_DOC
- m_max_sm_7 = 4
- n_max_sm_7 = 0
- o_max_sm_7 = 4
-END_PROVIDER
-
- BEGIN_PROVIDER [integer , m_max_sm_9]
-&BEGIN_PROVIDER [integer , n_max_sm_9]
-&BEGIN_PROVIDER [integer , o_max_sm_9]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_9 version of Table IV
- END_DOC
- m_max_sm_9 = 4
- n_max_sm_9 = 2
- o_max_sm_9 = 4
-END_PROVIDER
-
-
- BEGIN_PROVIDER [integer , m_max_sm_17]
-&BEGIN_PROVIDER [integer , n_max_sm_17]
-&BEGIN_PROVIDER [integer , o_max_sm_17]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_17 version of Table IV
- END_DOC
- m_max_sm_17 = 6
- n_max_sm_17 = 2
- o_max_sm_17 = 6
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_7, (0:m_max_sm_7,0:n_max_sm_7,0:o_max_sm_7,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_7(0:4,0:4,2:10) = coefficient for the SM_7 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_7
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_7 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_7(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,2) = 0.50516d0
- c_mn_o_sm_7(0,0,3,2) = -0.19313d0
- c_mn_o_sm_7(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,2) = -0.16995d0
- c_mn_o_sm_7(3,0,0,2) = -0.34505d0
- c_mn_o_sm_7(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,10) = -0.792d0
- c_mn_o_sm_7(0,0,3,10) = 1.05232d0
- c_mn_o_sm_7(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,10) = -0.13312d0
- c_mn_o_sm_7(3,0,0,10) = -0.00131d0
- c_mn_o_sm_7(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_9, (0:m_max_sm_9,0:n_max_sm_9,0:o_max_sm_9,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_9(0:4,0:4,2:10) = coefficient for the SM_9 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_9
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_9 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_9(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,2) = 0.50516d0
- c_mn_o_sm_9(0,0,3,2) = -0.19313d0
- c_mn_o_sm_9(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,2) = -0.16995d0
- c_mn_o_sm_9(3,0,0,2) = -0.34505d0
- c_mn_o_sm_9(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,10) = -0.792d0
- c_mn_o_sm_9(0,0,3,10) = 1.05232d0
- c_mn_o_sm_9(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,10) = -0.13312d0
- c_mn_o_sm_9(3,0,0,10) = -0.00131d0
- c_mn_o_sm_9(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_17, (0:m_max_sm_17,0:n_max_sm_17,0:o_max_sm_17,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_17(0:4,0:4,2:10) = coefficient for the SM_17 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_17
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_17 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_17(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,2) = 0.09239d0
- c_mn_o_sm_17(0,0,3,2) = -0.38664d0
- c_mn_o_sm_17(0,0,4,2) = 0.95764d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,2) = 0.23208d0
- c_mn_o_sm_17(3,0,0,2) = -0.45032d0
- c_mn_o_sm_17(4,0,0,2) = 0.82777d0
- c_mn_o_sm_17(2,2,0,2) = -4.15388d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,2) = 0.80622d0
- c_mn_o_sm_17(2,2,2,2) = 10.19704d0
- c_mn_o_sm_17(4,0,2,2) = -4.96259d0
- c_mn_o_sm_17(2,0,4,2) = -1.35647d0
- c_mn_o_sm_17(4,2,2,2) = -5.90907d0
- c_mn_o_sm_17(6,0,2,2) = 0.90343d0
- c_mn_o_sm_17(4,0,4,2) = 5.50739d0
- c_mn_o_sm_17(2,2,4,2) = -0.03154d0
- c_mn_o_sm_17(2,0,6,2) = -1.1051860
-
-
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,10) = -0.80909d0
- c_mn_o_sm_17(0,0,3,10) = -0.00219d0
- c_mn_o_sm_17(0,0,4,10) = 0.59188d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,10) = -0.00567d0
- c_mn_o_sm_17(3,0,0,10) = 0.14011d0
- c_mn_o_sm_17(4,0,0,10) = -0.05671d0
- c_mn_o_sm_17(2,2,0,10) = -3.33767d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,10) = 1.95067d0
- c_mn_o_sm_17(2,2,2,10) = 6.83340d0
- c_mn_o_sm_17(4,0,2,10) = -3.29231d0
- c_mn_o_sm_17(2,0,4,10) = -2.44998d0
- c_mn_o_sm_17(4,2,2,10) = -2.13029d0
- c_mn_o_sm_17(6,0,2,10) = 2.25768d0
- c_mn_o_sm_17(4,0,4,10) = 1.97951d0
- c_mn_o_sm_17(2,2,4,10) = -2.0924160
- c_mn_o_sm_17(2,0,6,10) = 0.35493d0
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ double precision, b_I_sm_90,(2:10)]
-&BEGIN_PROVIDER [ double precision, d_I_sm_90,(2:10)]
- implicit none
- BEGIN_DOC
-! "b_I" and "d_I" parameters of Eqs. (4) and (5) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- END_DOC
- b_I_sm_90 = 1.d0
- d_I_sm_90 = 1.d0
-
-END_PROVIDER
-
-subroutine get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- integer, intent(in) :: sm_j, i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- END_DOC
- double precision :: r_inucl,r_jnucl,r_ij,b_I, d_I
- b_I = b_I_sm_90(i_charge)
- d_I = d_I_sm_90(i_charge)
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- call jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-end
-
-subroutine get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
- ! rescaled variables of Eq. (5) and (6) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the "b_I" and "d_I" parameters are the same as in Eqs. (5) and (6)
- END_DOC
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- double precision, intent(in) :: b_I, d_I
- double precision, intent(out):: r_inucl,r_jnucl,r_ij
- double precision :: rin, rjn, rij
- integer :: i
- rin = 0.d0
- rjn = 0.d0
- rij = 0.d0
- do i = 1,3
- rin += (r1(i) - rI(i)) * (r1(i) - rI(i))
- rjn += (r2(i) - rI(i)) * (r2(i) - rI(i))
- rij += (r2(i) - r1(i)) * (r2(i) - r1(i))
- enddo
- rin = dsqrt(rin)
- rjn = dsqrt(rjn)
- rij = dsqrt(rij)
- r_inucl = b_I * rin/(1.d0 + b_I * rin)
- r_jnucl = b_I * rjn/(1.d0 + b_I * rjn)
- r_ij = d_I * rij/(1.d0 + b_I * rij)
-end
-
-subroutine jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! Here the r_inucl, r_jnucl are the rescaled variables as defined in Eq. (5) with "b_I"
- ! r_ij is the rescaled variable as defined in Eq. (6) with "d_I"
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- !
- ! it returns the j_1e : sum of terms with "o" = "n" = 0, "m" /= 0,
- ! j_2e : sum of terms with "m" = "n" = 0, "o" /= 0,
- ! j_een : sum of terms with "m" /=0, "n" /= 0, "o" /= 0,
- ! j_tot : the total sum
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer, intent(in) :: sm_j,i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- j_1e = 0.D0
- j_2e = 0.D0
- j_een = 0.D0
- double precision :: delta_mn,jastrow_sm_90_atomic
- integer :: m,n,o
-BEGIN_TEMPLATE
- ! pure 2e part
- n = 0
- m = 0
- if(sm_j == $X )then
- do o = 1, o_max_sm_$X
- if(dabs(c_mn_o_sm_$X(m,n,o,i_charge)).lt.1.d-10)cycle
- j_2e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! pure one-e part
- o = 0
- if(sm_j == $X)then
- do n = 2, n_max_sm_$X
- do m = 2, m_max_sm_$X
- j_1e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! e-e-n part
- if(sm_j == $X)then
- do o = 1, o_max_sm_$X
- do m = 2, m_max_sm_$X
- do n = 2, n_max_sm_$X
- j_een += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
- enddo
- else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- j_tot = j_1e + j_2e + j_een
-SUBST [ X]
- 7 ;;
- 9 ;;
- 17 ;;
-END_TEMPLATE
-end
-
-double precision function jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
-! contribution to the function of Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
-! for a given m,n,o and atom
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer , intent(in) :: m,n,o,i_charge
- double precision :: delta_mn
- if(m==n)then
- delta_mn = 0.5d0
- else
- delta_mn = 1.D0
- endif
- jastrow_sm_90_atomic = delta_mn * (r_inucl**m * r_jnucl**n + r_jnucl**m * r_inucl**n)*r_ij**o
-end
diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f
deleted file mode 100644
index eda0dd25..00000000
--- a/plugins/local/tc_scf/plot_j_schMos.irp.f
+++ /dev/null
@@ -1,69 +0,0 @@
-program plot_j
- implicit none
- double precision :: r1(3),rI(3),r2(3)
- double precision :: r12,dx,xmax, j_1e,j_2e,j_een,j_tot
- double precision :: j_mu_F_x_j
- integer :: i,nx,m,i_charge,sm_j
-
- character*(128) :: output
- integer :: i_unit_output_He_sm_7,i_unit_output_Ne_sm_7
- integer :: i_unit_output_He_sm_17,i_unit_output_Ne_sm_17
- integer :: getUnitAndOpen
- output='J_SM_7_He'
- i_unit_output_He_sm_7 = getUnitAndOpen(output,'w')
- output='J_SM_7_Ne'
- i_unit_output_Ne_sm_7 = getUnitAndOpen(output,'w')
-
- output='J_SM_17_He'
- i_unit_output_He_sm_17 = getUnitAndOpen(output,'w')
- output='J_SM_17_Ne'
- i_unit_output_Ne_sm_17 = getUnitAndOpen(output,'w')
-
- rI = 0.d0
- r1 = 0.d0
- r2 = 0.d0
- r1(1) = 1.5d0
- xmax = 20.d0
- r2(1) = -xmax*0.5d0
- nx = 1000
- dx = xmax/dble(nx)
- do i = 1, nx
- r12 = 0.d0
- do m = 1, 3
- r12 += (r1(m) - r2(m))*(r1(m) - r2(m))
- enddo
- r12 = dsqrt(r12)
- double precision :: jmu,env_nucl,jmu_env,jmu_scaled, jmu_scaled_env
- double precision :: b_I,d_I,r_inucl,r_jnucl,r_ij
- b_I = 1.D0
- d_I = 1.D0
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- jmu=j_mu_F_x_j(r12)
- jmu_scaled=j_mu_F_x_j(r_ij)
- jmu_env = jmu * env_nucl(r1) * env_nucl(r2)
-! jmu_scaled_env= jmu_scaled * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_inucl**2)) * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_jnucl**2))
- jmu_scaled_env= jmu_scaled * env_nucl(r1) * env_nucl(r2)
- ! He
- i_charge = 2
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! Ne
- i_charge = 10
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- r2(1) += dx
- enddo
-
-end
diff --git a/plugins/local/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f
deleted file mode 100644
index e62f0dde..00000000
--- a/plugins/local/tc_scf/print_fit_param.irp.f
+++ /dev/null
@@ -1,59 +0,0 @@
-program print_fit_param
-
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- !call create_guess
- !call orthonormalize_mos
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i
-
- mu_erf = 1.d0
- touch mu_erf
-
- print *, ' fit for (1 - erf(x))^2'
- do i = 1, n_max_fit_slat
- print*, expo_gauss_1_erf_x_2(i), coef_gauss_1_erf_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x(i), 2.d0 * coef_gauss_j_mu_x(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]^2'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x_2(i), 4.d0 * coef_gauss_j_mu_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)] x [1 - erf(mu * r12)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_1_erf(i), 4.d0 * coef_gauss_j_mu_1_erf(i)
- enddo
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f
deleted file mode 100644
index 6f9afd9a..00000000
--- a/plugins/local/tc_scf/print_tcscf_energy.irp.f
+++ /dev/null
@@ -1,55 +0,0 @@
-program print_tcscf_energy
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e
-
- PROVIDE j2e_type mu_erf
- PROVIDE j1e_type j1e_coef j1e_expo
- PROVIDE env_type env_coef env_expo
-
- print*, ' j2e_type = ', j2e_type
- print*, ' j1e_type = ', j1e_type
- print*, ' env_type = ', env_type
-
- print*, ' mu_erf = ', mu_erf
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- !etc_3e = diag_three_elem_hf
- etc_3e = tcscf_energy_3e_naive
- endif
-
- print *, " E_TC = ", etc_tot
- print *, " E_1e = ", etc_1e
- print *, " E_2e = ", etc_2e
- print *, " E_3e = ", etc_3e
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f
deleted file mode 100644
index 2c2cf2c2..00000000
--- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f
+++ /dev/null
@@ -1,129 +0,0 @@
-! ---
-
-subroutine rh_tcscf_simple()
-
- implicit none
- integer :: i, j, it, dim_DIIS
- double precision :: t0, t1
- double precision :: e_save, e_delta, rho_delta
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e, tc_grad
- double precision :: er_DIIS
- double precision, allocatable :: rho_old(:,:), rho_new(:,:)
-
- allocate(rho_old(ao_num,ao_num), rho_new(ao_num,ao_num))
-
- it = 0
- e_save = 0.d0
- dim_DIIS = 0
-
- ! ---
-
- if(.not. bi_ortho) then
- print *, ' grad_hermit = ', grad_hermit
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- endif
-
- ! ---
-
- if(bi_ortho) then
-
- PROVIDE level_shift_tcscf
- PROVIDE mo_l_coef mo_r_coef
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- , ' gradient ', ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
-
- ! first iteration (HF orbitals)
- call wall_time(t0)
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
- do while(tc_grad .gt. dsqrt(thresh_tcscf))
- call wall_time(t0)
-
- it += 1
- if(it > n_it_tcscf_max) then
- print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
- stop
- endif
-
- mo_l_coef = fock_tc_leigvec_ao
- mo_r_coef = fock_tc_reigvec_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
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call ezfio_set_tc_scf_tcscf_energy(etc_tot)
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
- 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_e_energy
- print *, 'TC HF 2 e energy = ', TC_HF_two_e_energy
- print *, 'TC HF 3 body = ', diag_three_elem_hf
- print *, '***'
- print *, ''
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- enddo
-
- endif
-
- print *, ' TCSCF Simple converged !'
- !call print_energy_and_mos(good_angles)
-
- deallocate(rho_old, rho_new)
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
deleted file mode 100644
index 0f2663e5..00000000
--- a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
+++ /dev/null
@@ -1,369 +0,0 @@
-
-! ---
-
-program rotate_tcscf_orbitals
-
- BEGIN_DOC
- ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- bi_ortho = .True.
- touch bi_ortho
-
- call minimize_tc_orb_angles()
- !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_to_maximize_overlap(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_to_maximize_overlap(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, tot_deg
- 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 = thr_degen_tc
-
- 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
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- 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_to_maximize_overlap
-
-! ---
-
-subroutine fix_right_to_one()
-
- implicit none
- integer :: i, j, m, n, mm, tot_deg
- double precision :: accu_d, accu_nd
- double precision :: de_thr, ei, ej, de
- integer, allocatable :: deg_num(:)
- double precision, allocatable :: R0(:,:), L0(:,:), W(:,:), e0(:)
- double precision, allocatable :: R(:,:), L(:,:), S(:,:), Stmp(:,:), tmp(:,:)
-
- n = ao_num
- m = mo_num
-
- allocate(L0(n,m), R0(n,m), W(n,n), e0(m))
- L0 = mo_l_coef
- R0 = mo_r_coef
- W = ao_overlap
-
- print*, ' fock matrix diag elements'
- do i = 1, m
- e0(i) = Fock_matrix_tc_mo_tot(i,i)
- print*, e0(i)
- enddo
-
- ! ---
-
- allocate( deg_num(m) )
- do i = 1, m
- deg_num(i) = 1
- enddo
-
- de_thr = 1d-6
-
- 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
-
- deallocate(e0)
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- do i = 1, m
- mm = deg_num(i)
-
- if(mm .gt. 1) then
-
- allocate(L(n,mm), R(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)
- enddo
-
- ! ---
-
- call impose_weighted_orthog_svd(n, mm, W, R)
- call impose_weighted_biorthog_qr(n, mm, thresh_biorthog_diag, thresh_biorthog_nondiag, R, W, L)
-
- ! ---
-
- do j = 1, mm
- L0(1:n,i+j-1) = L(1:n,j)
- R0(1:n,i+j-1) = R(1:n,j)
- enddo
- deallocate(L, R)
-
- endif
- enddo
-
- call check_weighted_biorthog_binormalize(n, m, L0, W, R0, thresh_biorthog_diag, thresh_biorthog_nondiag, .true.)
-
- deallocate(W, deg_num)
-
- mo_l_coef = L0
- mo_r_coef = R0
- deallocate(L0, R0)
-
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
- print *, ' orbitals are rotated '
-
- return
-end subroutine fix_right_to_one
-
-! ---
diff --git a/plugins/local/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f
deleted file mode 100644
index 14fff898..00000000
--- a/plugins/local/tc_scf/tc_petermann_factor.irp.f
+++ /dev/null
@@ -1,91 +0,0 @@
-
-! ---
-
-program tc_petermann_factor
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i, j
- double precision :: Pf_diag_av
- double precision, allocatable :: Sl(:,:), Sr(:,:), Pf(:,:)
-
- allocate(Sl(mo_num,mo_num), Sr(mo_num,mo_num), Pf(mo_num,mo_num))
-
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_r_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-right orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_l_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_r_coef, ao_overlap, mo_r_coef, Sr)
-! call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
-! , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-! , 0.d0, Sr, size(Sr, 1) )
-
- print *, ''
- print *, ' right-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sr(:,i)
- enddo
-
- print *, ''
- print *, ' Petermann matrix:'
- do i = 1, mo_num
- do j = 1, mo_num
- Pf(j,i) = Sl(j,i) * Sr(j,i)
- enddo
- write(*,'(100(F8.4,X))') Pf(:,i)
- enddo
-
- Pf_diag_av = 0.d0
- do i = 1, mo_num
- Pf_diag_av = Pf_diag_av + Pf(i,i)
- enddo
- Pf_diag_av = Pf_diag_av / dble(mo_num)
-
- print *, ''
- print *, ' mean of the diagonal Petermann factor = ', Pf_diag_av
-
- deallocate(Sl, Sr, Pf)
-
- return
-end subroutine
-
-! ---
-
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index ee8e8dad..f099b90e 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -10,13 +10,10 @@ program tc_scf
integer :: i
logical :: good_angles
- PROVIDE j1e_type
- PROVIDE j2e_type
- PROVIDE tcscf_algorithm
-
print *, ' TC-SCF with:'
- print *, ' j1e_type = ', j1e_type
print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
write(json_unit,json_array_open_fmt) 'tc-scf'
@@ -29,7 +26,6 @@ program tc_scf
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
-
if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
@@ -41,17 +37,7 @@ program tc_scf
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
- !call create_guess()
- !call orthonormalize_mos()
-
- if(tcscf_algorithm == 'DIIS') then
- call rh_tcscf_diis()
- elseif(tcscf_algorithm == 'Simple') then
- call rh_tcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
+ call rh_tcscf_diis()
PROVIDE Fock_matrix_tc_diag_mo_tot
print*, ' Eigenvalues:'
@@ -59,14 +45,11 @@ program tc_scf
print*, i, Fock_matrix_tc_diag_mo_tot(i)
enddo
- ! TODO
- ! rotate angles in separate code only if necessary
- if(minimize_lr_angles)then
+ if(minimize_lr_angles) then
call minimize_tc_orb_angles()
endif
call print_energy_and_mos(good_angles)
-
write(json_unit,json_array_close_fmtx)
call json_close
diff --git a/plugins/local/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f
index bf31a4a1..5d25fce2 100644
--- a/plugins/local/tc_scf/tc_scf_dm.irp.f
+++ b/plugins/local/tc_scf/tc_scf_dm.irp.f
@@ -10,16 +10,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
-
- else
-
- TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
END_PROVIDER
@@ -35,16 +27,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
-
- else
-
- TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
END_PROVIDER
diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f
index 0266c605..c9366195 100644
--- a/plugins/local/tc_scf/tc_scf_energy.irp.f
+++ b/plugins/local/tc_scf/tc_scf_energy.irp.f
@@ -34,3 +34,426 @@ END_PROVIDER
! ---
+BEGIN_PROVIDER [double precision, diag_three_elem_hf]
+
+ BEGIN_DOC
+ !
+ ! < Phi_left | L | Phi_right >
+ !
+ !
+ ! if three_body_h_tc == false and noL_standard == true ==> do a normal ordering
+ !
+ ! todo
+ ! this should be equivalent to
+ ! three_body_h_tc == true and noL_standard == false
+ !
+ ! if three_body_h_tc == false and noL_standard == false ==> this is equal to 0
+ !
+ END_DOC
+
+ implicit none
+ integer :: i, j, k, ipoint, mm
+ double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
+ double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
+ double precision, allocatable :: tmp(:)
+ double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
+ double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
+ double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ if(.not. three_body_h_tc) then
+
+ if(noL_standard) then
+ PROVIDE noL_0e
+ diag_three_elem_hf = noL_0e
+ else
+ diag_three_elem_hf = 0.d0
+ endif
+
+ else
+
+ PROVIDE int2_grad1_u12_bimo_t
+ PROVIDE mos_l_in_r_array_transp
+ PROVIDE mos_r_in_r_array_transp
+
+ if(elec_alpha_num .eq. elec_beta_num) then
+
+ allocate(tmp(elec_beta_num))
+ allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
+ !$OMP SHARED(elec_beta_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
+
+ !$OMP DO
+ do j = 1, elec_beta_num
+
+ tmp_L = 0.d0
+ tmp_R = 0.d0
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
+
+ tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+
+ tmp(j) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
+ enddo
+ enddo ! j
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ diag_three_elem_hf = -2.d0 * sum(tmp)
+
+ deallocate(tmp)
+ deallocate(tmp_L, tmp_R)
+
+ ! ---
+
+ allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
+ tmp_O = 0.d0
+ tmp_J = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
+ !$OMP SHARED(elec_beta_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
+
+ allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
+ tmp_O_priv = 0.d0
+ tmp_J_priv = 0.d0
+
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ tmp_O = tmp_O + tmp_O_priv
+ tmp_J = tmp_J + tmp_J_priv
+ !$OMP END CRITICAL
+
+ deallocate(tmp_O_priv, tmp_J_priv)
+ !$OMP END PARALLEL
+
+ allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
+ tmp_M = 0.d0
+ tmp_S = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
+ !$OMP SHARED(elec_beta_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
+
+ allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
+ tmp_M_priv = 0.d0
+ tmp_S_priv = 0.d0
+
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ tmp_M = tmp_M + tmp_M_priv
+ tmp_S = tmp_S + tmp_S_priv
+ !$OMP END CRITICAL
+
+ deallocate(tmp_M_priv, tmp_S_priv)
+ !$OMP END PARALLEL
+
+ allocate(tmp(n_points_final_grid))
+
+ do ipoint = 1, n_points_final_grid
+
+ tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
+
+ tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
+ - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
+ + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
+ + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
+ enddo
+
+ diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
+
+ deallocate(tmp)
+
+ else ! elec_alpha_num .neq. elec_beta_num
+
+ allocate(tmp(elec_alpha_num))
+ allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
+ !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
+
+ !$OMP DO
+ do j = 1, elec_beta_num
+
+ tmp_L = 0.d0
+ tmp_R = 0.d0
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
+
+ tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+
+ tmp(j) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
+ enddo
+
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
+
+ tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+
+ do ipoint = 1, n_points_final_grid
+ tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
+ enddo
+ enddo ! j
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ ! ---
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
+ !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
+
+ !$OMP DO
+ do j = elec_beta_num+1, elec_alpha_num
+
+ tmp_L = 0.d0
+ tmp_R = 0.d0
+ do i = 1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
+ tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
+
+ tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
+ enddo
+ enddo
+
+ tmp(j) = 0.d0
+ do ipoint = 1, n_points_final_grid
+ tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
+ enddo
+ enddo ! j
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ diag_three_elem_hf = -2.d0 * sum(tmp)
+
+ deallocate(tmp)
+ deallocate(tmp_L, tmp_R)
+
+ ! ---
+
+ allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
+ tmp_O = 0.d0
+ tmp_J = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
+ !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
+
+ allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
+ tmp_O_priv = 0.d0
+ tmp_J_priv = 0.d0
+
+ !$OMP DO
+ do i = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+ tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP DO
+ do i = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+ tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
+ tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
+ tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ tmp_O = tmp_O + tmp_O_priv
+ tmp_J = tmp_J + tmp_J_priv
+ !$OMP END CRITICAL
+
+ deallocate(tmp_O_priv, tmp_J_priv)
+ !$OMP END PARALLEL
+
+ ! ---
+
+ allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
+ tmp_M = 0.d0
+ tmp_S = 0.d0
+
+ !$OMP PARALLEL &
+ !$OMP DEFAULT(NONE) &
+ !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
+ !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
+ !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
+ !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
+
+ allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
+ tmp_M_priv = 0.d0
+ tmp_S_priv = 0.d0
+
+ !$OMP DO COLLAPSE(2)
+ do i = 1, elec_beta_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP DO COLLAPSE(2)
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = 1, elec_beta_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+ tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
+
+ tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP DO COLLAPSE(2)
+ do i = elec_beta_num+1, elec_alpha_num
+ do j = elec_beta_num+1, elec_alpha_num
+ do ipoint = 1, n_points_final_grid
+
+ tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+ tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
+
+ tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
+ + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
+ + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
+ enddo
+ enddo
+ enddo
+ !$OMP END DO NOWAIT
+
+ !$OMP CRITICAL
+ tmp_M = tmp_M + tmp_M_priv
+ tmp_S = tmp_S + tmp_S_priv
+ !$OMP END CRITICAL
+
+ deallocate(tmp_M_priv, tmp_S_priv)
+ !$OMP END PARALLEL
+
+ allocate(tmp(n_points_final_grid))
+
+ do ipoint = 1, n_points_final_grid
+
+ tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
+
+ tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
+ - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
+ + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
+ + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
+ enddo
+
+ diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
+
+ deallocate(tmp)
+
+ endif ! alpha/beta condition
+
+ endif ! three_body_h_tc
+
+END_PROVIDER
+
+! ---
+
diff --git a/plugins/local/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f
deleted file mode 100644
index 82bb8799..00000000
--- a/plugins/local/tc_scf/tcscf_energy_naive.irp.f
+++ /dev/null
@@ -1,80 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, tcscf_energy_3e_naive]
-
- implicit none
- integer :: i, j, k
- integer :: neu, ned, D(elec_num)
- integer :: ii, jj, kk
- integer :: si, sj, sk
- double precision :: I_ijk, I_jki, I_kij, I_jik, I_ikj, I_kji
- double precision :: I_tot
-
- PROVIDE mo_l_coef mo_r_coef
-
- neu = elec_alpha_num
- ned = elec_beta_num
- if (neu > 0) D(1:neu) = [(2*i-1, i = 1, neu)]
- if (ned > 0) D(neu+1:neu+ned) = [(2*i, i = 1, ned)]
-
- !print*, "D = "
- !do i = 1, elec_num
- ! ii = (D(i) - 1) / 2 + 1
- ! si = mod(D(i), 2)
- ! print*, i, D(i), ii, si
- !enddo
-
- tcscf_energy_3e_naive = 0.d0
-
- do i = 1, elec_num - 2
- ii = (D(i) - 1) / 2 + 1
- si = mod(D(i), 2)
-
- do j = i + 1, elec_num - 1
- jj = (D(j) - 1) / 2 + 1
- sj = mod(D(j), 2)
-
- do k = j + 1, elec_num
- kk = (D(k) - 1) / 2 + 1
- sk = mod(D(k), 2)
-
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, jj, kk, I_ijk)
- I_tot = I_ijk
-
- if(sj==si .and. sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, kk, ii, I_jki)
- I_tot += I_jki
- endif
-
- if(sk==si .and. si==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, ii, jj, I_kij)
- I_tot += I_kij
- endif
-
- if(sj==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, ii, kk, I_jik)
- I_tot -= I_jik
- endif
-
- if(sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, kk, jj, I_ikj)
- I_tot -= I_ikj
- endif
-
- if(sk==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, jj, ii, I_kji)
- I_tot -= I_kji
- endif
-
- tcscf_energy_3e_naive += I_tot
- enddo
- enddo
- enddo
-
- tcscf_energy_3e_naive = -tcscf_energy_3e_naive
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
deleted file mode 100644
index 0c9ebbd7..00000000
--- a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
+++ /dev/null
@@ -1,189 +0,0 @@
-
-subroutine contrib_3e_diag_sss(i, j, k, integral)
-
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
-
- implicit none
- integer, intent(in) :: i, j, k
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
-
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int )!!! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, j, i, k, c_3_int) ! < i k j | j i k >
- call give_integrals_3_body_bi_ort(i, k, j, k, j, i, c_minus_3_int)! < i k j | k j i >
- integral = direct_int + c_3_int + c_minus_3_int
-
- ! negative terms :: exchange contrib
- call give_integrals_3_body_bi_ort(i, k, j, j, k, i, exch_13_int)!!! < i k j | j k i > : E_13
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)!!! < i k j | i j k > : E_23
- call give_integrals_3_body_bi_ort(i, k, j, k, i, j, exch_12_int)!!! < i k j | k i j > : E_12
-
- integral += - exch_13_int - exch_23_int - exch_12_int
- integral = -integral
-
-end
-
-! ---
-
-subroutine contrib_3e_diag_soo(i,j,k,integral)
- implicit none
- integer, intent(in) :: i,j,k
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_23_int
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int) ! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)! < i k j | i j k > : E_23
- integral = direct_int - exch_23_int
- integral = -integral
-end
-
-
-subroutine give_aaa_contrib_bis(integral_aaa)
- implicit none
- double precision, intent(out) :: integral_aaa
- double precision :: integral
- integer :: i,j,k
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = i+1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine give_aaa_contrib(integral_aaa)
-
- implicit none
- integer :: i, j, k
- double precision :: integral
- double precision, intent(out) :: integral_aaa
-
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_sss(i, j, k, integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
- integral_aaa *= 1.d0/6.d0
-
- return
-end
-
-! ---
-
-subroutine give_aab_contrib(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
- integral_aab *= 0.5d0
-end
-
-
-subroutine give_aab_contrib_bis(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
-end
-
-
-subroutine give_abb_contrib(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
- integral_abb *= 0.5d0
-end
-
-subroutine give_abb_contrib_bis(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
-end
-
-subroutine give_bbb_contrib_bis(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = i+1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
-
-end
-
-subroutine give_bbb_contrib(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
- integral_bbb *= 1.d0/6.d0
-end
-
-
diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
index 7ce57578..ec5167d1 100644
--- a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
+++ b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
@@ -4,11 +4,9 @@ program write_ao_2e_tc_integ
implicit none
- PROVIDE j1e_type
- PROVIDE j2e_type
-
- print *, ' j1e_type = ', j1e_type
print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
From d43d960b1a15e7ddb9dcf1e871bf6e9a4e70983b Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Wed, 1 May 2024 21:52:00 +0200
Subject: [PATCH 115/140] TC-SCF CLEANED
---
plugins/local/bi_ort_ints/no_dressing.irp.f | 7 +-
plugins/local/non_hermit_dav/biorthog.irp.f | 2 +-
plugins/local/slater_tc/NEED | 1 +
.../symmetrized_3_e_int_prov.irp.f | 0
plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 33 -
plugins/local/tc_keywords/EZFIO.cfg | 48 +-
plugins/local/tc_keywords/tc_keywords.irp.f | 7 -
plugins/local/tc_scf/EZFIO.cfg | 30 +
plugins/local/tc_scf/fock_hermit.irp.f | 107 ---
plugins/local/tc_scf/fock_tc.irp.f | 40 +-
plugins/local/tc_scf/fock_tc_mo_tot.irp.f | 19 +-
plugins/local/tc_scf/fock_three_hermit.irp.f | 771 ------------------
.../local/tc_scf/integrals_in_r_stuff.irp.f | 391 ---------
plugins/local/tc_scf/jast_schmos_90.irp.f | 318 --------
plugins/local/tc_scf/plot_j_schMos.irp.f | 69 --
plugins/local/tc_scf/print_fit_param.irp.f | 59 --
plugins/local/tc_scf/print_tcscf_energy.irp.f | 55 --
plugins/local/tc_scf/rh_tcscf_diis.irp.f | 4 +-
plugins/local/tc_scf/rh_tcscf_simple.irp.f | 129 ---
.../local/tc_scf/rotate_tcscf_orbitals.irp.f | 369 ---------
.../local/tc_scf/tc_petermann_factor.irp.f | 91 ---
plugins/local/tc_scf/tc_scf.irp.f | 25 +-
plugins/local/tc_scf/tc_scf_dm.irp.f | 24 +-
plugins/local/tc_scf/tc_scf_energy.irp.f | 16 +-
plugins/local/tc_scf/tcscf_energy_naive.irp.f | 80 --
.../tc_scf/three_e_energy_bi_ortho.irp.f | 189 -----
.../local/tc_scf/write_ao_2e_tc_integ.irp.f | 6 +-
27 files changed, 94 insertions(+), 2796 deletions(-)
rename plugins/local/{tc_bi_ortho => slater_tc}/symmetrized_3_e_int_prov.irp.f (100%)
delete mode 100644 plugins/local/tc_keywords/tc_keywords.irp.f
delete mode 100644 plugins/local/tc_scf/fock_hermit.irp.f
delete mode 100644 plugins/local/tc_scf/fock_three_hermit.irp.f
delete mode 100644 plugins/local/tc_scf/integrals_in_r_stuff.irp.f
delete mode 100644 plugins/local/tc_scf/jast_schmos_90.irp.f
delete mode 100644 plugins/local/tc_scf/plot_j_schMos.irp.f
delete mode 100644 plugins/local/tc_scf/print_fit_param.irp.f
delete mode 100644 plugins/local/tc_scf/print_tcscf_energy.irp.f
delete mode 100644 plugins/local/tc_scf/rh_tcscf_simple.irp.f
delete mode 100644 plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
delete mode 100644 plugins/local/tc_scf/tc_petermann_factor.irp.f
delete mode 100644 plugins/local/tc_scf/tcscf_energy_naive.irp.f
delete mode 100644 plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f
index bd225274..721ac0f8 100644
--- a/plugins/local/bi_ort_ints/no_dressing.irp.f
+++ b/plugins/local/bi_ort_ints/no_dressing.irp.f
@@ -322,6 +322,12 @@ END_PROVIDER
BEGIN_PROVIDER [double precision, noL_0e]
+ BEGIN_DOC
+ !
+ ! < Phi_left | L | Phi_right >
+ !
+ END_DOC
+
implicit none
integer :: i, j, k, ipoint
double precision :: t0, t1
@@ -330,7 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
call wall_time(t0)
print*, " Providing noL_0e ..."
diff --git a/plugins/local/non_hermit_dav/biorthog.irp.f b/plugins/local/non_hermit_dav/biorthog.irp.f
index b36b0130..4b618228 100644
--- a/plugins/local/non_hermit_dav/biorthog.irp.f
+++ b/plugins/local/non_hermit_dav/biorthog.irp.f
@@ -43,7 +43,7 @@ subroutine non_hrmt_bieig(n, A, thr_d, thr_nd, leigvec, reigvec, n_real_eigv, ei
! track & sort the real eigenvalues
n_good = 0
- thr = Im_thresh_tcscf
+ thr = Im_thresh_tc
do i = 1, n
if(dabs(WI(i)) .lt. thr) then
n_good += 1
diff --git a/plugins/local/slater_tc/NEED b/plugins/local/slater_tc/NEED
index ef0aa3f7..a8669866 100644
--- a/plugins/local/slater_tc/NEED
+++ b/plugins/local/slater_tc/NEED
@@ -5,3 +5,4 @@ bi_ortho_mos
tc_keywords
non_hermit_dav
dav_general_mat
+tc_scf
diff --git a/plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f b/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/symmetrized_3_e_int_prov.irp.f
rename to plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f
diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
index f1a7cc0a..85f3ed97 100644
--- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
+++ b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
@@ -24,44 +24,12 @@ program test_tc_fock
!call routine_2
! call routine_3()
-! call test_3e
call routine_tot
end
! ---
-subroutine test_3e
- implicit none
- double precision :: integral_aaa,integral_aab,integral_abb,integral_bbb,accu
- double precision :: hmono, htwoe, hthree, htot
- call htilde_mu_mat_bi_ortho_slow(ref_bitmask, ref_bitmask, N_int, hmono, htwoe, hthree, htot)
- print*,'hmono = ',hmono
- print*,'htwoe = ',htwoe
- print*,'hthree= ',hthree
- print*,'htot = ',htot
- print*,''
- print*,''
- print*,'TC_one= ',tc_hf_one_e_energy
- print*,'TC_two= ',TC_HF_two_e_energy
- print*,'TC_3e = ',diag_three_elem_hf
- print*,'TC_tot= ',TC_HF_energy
- print*,''
- print*,''
- call give_aaa_contrib(integral_aaa)
- print*,'integral_aaa = ',integral_aaa
- call give_aab_contrib(integral_aab)
- print*,'integral_aab = ',integral_aab
- call give_abb_contrib(integral_abb)
- print*,'integral_abb = ',integral_abb
- call give_bbb_contrib(integral_bbb)
- print*,'integral_bbb = ',integral_bbb
- accu = integral_aaa + integral_aab + integral_abb + integral_bbb
- print*,'accu = ',accu
- print*,'delta = ',hthree - accu
-
-end
-
subroutine routine_3()
use bitmasks ! you need to include the bitmasks_module.f90 features
@@ -86,7 +54,6 @@ subroutine routine_3()
do i = 1, elec_num_tab(s1)
do a = elec_num_tab(s1)+1, mo_num ! virtual
-
det_i = ref_bitmask
call do_single_excitation(det_i, i, a, s1, i_ok)
if(i_ok == -1) then
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index e4d9701a..33b9db57 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -100,30 +100,12 @@ 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^t 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-8
-
-[n_it_tcscf_max]
-type: Strictly_positive_int
-doc: Maximum number of SCF iterations
-interface: ezfio,provider,ocaml
-default: 50
-
[selection_tc]
type: integer
doc: if +1: only positive is selected, -1: only negative is selected, :0 both positive and negative
@@ -160,30 +142,6 @@ doc: If |true|, maximize the overlap between orthogonalized left- and right eige
interface: ezfio,provider,ocaml
default: False
-[max_dim_diis_tcscf]
-type: integer
-doc: Maximum size of the DIIS extrapolation procedure
-interface: ezfio,provider,ocaml
-default: 15
-
-[level_shift_tcscf]
-type: Positive_float
-doc: Energy shift on the virtual MOs to improve TCSCF convergence
-interface: ezfio,provider,ocaml
-default: 0.
-
-[tcscf_algorithm]
-type: character*(32)
-doc: Type of TCSCF algorithm used. Possible choices are [Simple | DIIS]
-interface: ezfio,provider,ocaml
-default: DIIS
-
-[im_thresh_tcscf]
-type: Threshold
-doc: Thresholds on the Imag part of energy
-interface: ezfio,provider,ocaml
-default: 1.e-7
-
[test_cycle_tc]
type: logical
doc: If |true|, the integrals of the three-body jastrow are computed with cycles
@@ -304,3 +262,9 @@ doc: If |true|, more calc but less mem
interface: ezfio,provider,ocaml
default: False
+[im_thresh_tc]
+type: Threshold
+doc: Thresholds on the Imag part of TC energy
+interface: ezfio,provider,ocaml
+default: 1.e-7
+
diff --git a/plugins/local/tc_keywords/tc_keywords.irp.f b/plugins/local/tc_keywords/tc_keywords.irp.f
deleted file mode 100644
index 3bc68550..00000000
--- a/plugins/local/tc_keywords/tc_keywords.irp.f
+++ /dev/null
@@ -1,7 +0,0 @@
-program tc_keywords
- implicit none
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
- print *, 'Hello world'
-end
diff --git a/plugins/local/tc_scf/EZFIO.cfg b/plugins/local/tc_scf/EZFIO.cfg
index 510c777c..e3d24338 100644
--- a/plugins/local/tc_scf/EZFIO.cfg
+++ b/plugins/local/tc_scf/EZFIO.cfg
@@ -9,3 +9,33 @@ doc: If |true|, tc-scf has converged
interface: ezfio,provider,ocaml
default: False
+[max_dim_diis_tcscf]
+type: integer
+doc: Maximum size of the DIIS extrapolation procedure
+interface: ezfio,provider,ocaml
+default: 15
+
+[level_shift_tcscf]
+type: Positive_float
+doc: Energy shift on the virtual MOs to improve TCSCF convergence
+interface: ezfio,provider,ocaml
+default: 0.
+
+[thresh_tcscf]
+type: Threshold
+doc: Threshold on the convergence of the Hartree Fock energy.
+interface: ezfio,provider,ocaml
+default: 1.e-8
+
+[n_it_tcscf_max]
+type: Strictly_positive_int
+doc: Maximum number of SCF iterations
+interface: ezfio,provider,ocaml
+default: 50
+
+[tc_Brillouin_Right]
+type: logical
+doc: If |true|, impose only right-Brillouin condition
+interface: ezfio,provider,ocaml
+default: False
+
diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f
deleted file mode 100644
index 5a51b324..00000000
--- a/plugins/local/tc_scf/fock_hermit.irp.f
+++ /dev/null
@@ -1,107 +0,0 @@
-
-! ---
-
-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/plugins/local/tc_scf/fock_tc.irp.f b/plugins/local/tc_scf/fock_tc.irp.f
index 508f3cd7..16bb5c87 100644
--- a/plugins/local/tc_scf/fock_tc.irp.f
+++ b/plugins/local/tc_scf/fock_tc.irp.f
@@ -110,23 +110,14 @@ BEGIN_PROVIDER [double precision, Fock_matrix_tc_mo_alpha, (mo_num, mo_num)]
double precision :: t0, t1, tt0, tt1
double precision, allocatable :: tmp(:,:)
- if(bi_ortho) then
+ PROVIDE mo_l_coef mo_r_coef
- PROVIDE mo_l_coef mo_r_coef
-
- 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) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_mo_a
- Fock_matrix_tc_mo_alpha += fock_3e_mo_a
- endif
-
- 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) )
+ 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) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_a
+ Fock_matrix_tc_mo_alpha += fock_3e_mo_a
endif
END_PROVIDER
@@ -142,21 +133,12 @@ BEGIN_PROVIDER [ double precision, Fock_matrix_tc_mo_beta, (mo_num,mo_num) ]
implicit none
double precision, allocatable :: tmp(:,:)
- 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) )
-
- if(three_body_h_tc) then
- PROVIDE fock_3e_mo_b
- Fock_matrix_tc_mo_beta += fock_3e_mo_b
- endif
-
- 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) )
+ 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) )
+ if(three_body_h_tc) then
+ PROVIDE fock_3e_mo_b
+ Fock_matrix_tc_mo_beta += fock_3e_mo_b
endif
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
index 2df2421e..fd490af6 100644
--- a/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
+++ b/plugins/local/tc_scf/fock_tc_mo_tot.irp.f
@@ -132,7 +132,7 @@
enddo
endif
- if(no_oa_or_av_opt)then
+ if(no_oa_or_av_opt) then
do i = 1, n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
@@ -153,8 +153,21 @@
enddo
endif
- if(.not.bi_ortho .and. three_body_h_tc)then
- Fock_matrix_tc_mo_tot += fock_3_mat
+ if(tc_Brillouin_Right) then
+
+ double precision, allocatable :: tmp(:,:)
+ allocate(tmp(mo_num,mo_num))
+
+ tmp = Fock_matrix_tc_mo_tot
+ do j = 1, mo_num
+ do i = 1, j-1
+ tmp(i,j) = Fock_matrix_tc_mo_tot(j,i)
+ enddo
+ enddo
+
+ Fock_matrix_tc_mo_tot = tmp
+ deallocate(tmp)
+
endif
END_PROVIDER
diff --git a/plugins/local/tc_scf/fock_three_hermit.irp.f b/plugins/local/tc_scf/fock_three_hermit.irp.f
deleted file mode 100644
index 00d47fae..00000000
--- a/plugins/local/tc_scf/fock_three_hermit.irp.f
+++ /dev/null
@@ -1,771 +0,0 @@
-
-! ---
-
-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
- !else if(bi_ortho.and.three_body_h_tc) then
- !! !$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
- double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
- double precision, allocatable :: tmp(:)
- double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
- double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
- double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- !print *, ' providing diag_three_elem_hf'
-
- if(.not. three_body_h_tc) then
-
- if(noL_standard) then
- PROVIDE noL_0e
- diag_three_elem_hf = noL_0e
- else
- diag_three_elem_hf = 0.d0
- endif
-
- else
-
- if(.not. bi_ortho) 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
-
- ! ------------
- ! SLOW VERSION
- ! ------------
-
- !call give_aaa_contrib(integral_aaa)
- !call give_aab_contrib(integral_aab)
- !call give_abb_contrib(integral_abb)
- !call give_bbb_contrib(integral_bbb)
- !diag_three_elem_hf = integral_aaa + integral_aab + integral_abb + integral_bbb
-
- ! ------------
- ! ------------
-
- PROVIDE int2_grad1_u12_bimo_t
- PROVIDE mos_l_in_r_array_transp
- PROVIDE mos_r_in_r_array_transp
-
- if(elec_alpha_num .eq. elec_beta_num) then
-
- allocate(tmp(elec_beta_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- else
-
- allocate(tmp(elec_alpha_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = elec_beta_num+1, elec_alpha_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- endif
-
-
- endif
-
- 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
- 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
-
-
-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/plugins/local/tc_scf/integrals_in_r_stuff.irp.f b/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
deleted file mode 100644
index 3ce85a97..00000000
--- a/plugins/local/tc_scf/integrals_in_r_stuff.irp.f
+++ /dev/null
@@ -1,391 +0,0 @@
-
-! ---
-
-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/plugins/local/tc_scf/jast_schmos_90.irp.f b/plugins/local/tc_scf/jast_schmos_90.irp.f
deleted file mode 100644
index 5c5e625f..00000000
--- a/plugins/local/tc_scf/jast_schmos_90.irp.f
+++ /dev/null
@@ -1,318 +0,0 @@
- BEGIN_PROVIDER [integer , m_max_sm_7]
-&BEGIN_PROVIDER [integer , n_max_sm_7]
-&BEGIN_PROVIDER [integer , o_max_sm_7]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_7 version of Table IV
- END_DOC
- m_max_sm_7 = 4
- n_max_sm_7 = 0
- o_max_sm_7 = 4
-END_PROVIDER
-
- BEGIN_PROVIDER [integer , m_max_sm_9]
-&BEGIN_PROVIDER [integer , n_max_sm_9]
-&BEGIN_PROVIDER [integer , o_max_sm_9]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_9 version of Table IV
- END_DOC
- m_max_sm_9 = 4
- n_max_sm_9 = 2
- o_max_sm_9 = 4
-END_PROVIDER
-
-
- BEGIN_PROVIDER [integer , m_max_sm_17]
-&BEGIN_PROVIDER [integer , n_max_sm_17]
-&BEGIN_PROVIDER [integer , o_max_sm_17]
- implicit none
- BEGIN_DOC
-! maximum value of the "m", "n" and "o" integer in the Jastrow function as in Eq. (4)
-! of Schmidt,Moskowitz, JCP, 93, 4172 (1990) for the SM_17 version of Table IV
- END_DOC
- m_max_sm_17 = 6
- n_max_sm_17 = 2
- o_max_sm_17 = 6
-END_PROVIDER
-
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_7, (0:m_max_sm_7,0:n_max_sm_7,0:o_max_sm_7,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_7(0:4,0:4,2:10) = coefficient for the SM_7 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_7
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_7 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_7(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,2) = 0.50516d0
- c_mn_o_sm_7(0,0,3,2) = -0.19313d0
- c_mn_o_sm_7(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,2) = -0.16995d0
- c_mn_o_sm_7(3,0,0,2) = -0.34505d0
- c_mn_o_sm_7(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_7(0,0,2,10) = -0.792d0
- c_mn_o_sm_7(0,0,3,10) = 1.05232d0
- c_mn_o_sm_7(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_7(2,0,0,10) = -0.13312d0
- c_mn_o_sm_7(3,0,0,10) = -0.00131d0
- c_mn_o_sm_7(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_9, (0:m_max_sm_9,0:n_max_sm_9,0:o_max_sm_9,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_9(0:4,0:4,2:10) = coefficient for the SM_9 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_9
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_9 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_9(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,2) = 0.50516d0
- c_mn_o_sm_9(0,0,3,2) = -0.19313d0
- c_mn_o_sm_9(0,0,4,2) = 0.30276d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,2) = -0.16995d0
- c_mn_o_sm_9(3,0,0,2) = -0.34505d0
- c_mn_o_sm_9(4,0,0,2) = -0.54777d0
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_9(0,0,2,10) = -0.792d0
- c_mn_o_sm_9(0,0,3,10) = 1.05232d0
- c_mn_o_sm_9(0,0,4,10) = -0.65615d0
- ! one-electron terms
- c_mn_o_sm_9(2,0,0,10) = -0.13312d0
- c_mn_o_sm_9(3,0,0,10) = -0.00131d0
- c_mn_o_sm_9(4,0,0,10) = 0.09083d0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, c_mn_o_sm_17, (0:m_max_sm_17,0:n_max_sm_17,0:o_max_sm_17,2:10)]
- implicit none
- BEGIN_DOC
- !
- !c_mn_o_17(0:4,0:4,2:10) = coefficient for the SM_17 correlation factor as given is Table IV of
- ! Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the first index (0:4) is the "m" integer for the 1e part
- ! the second index(0:0) is the "n" integer for the 1e part WHICH IS ALWAYS SET TO 0 FOR SM_17
- ! the third index (0:4) is the "o" integer for the 2e part
- ! the fourth index (2:10) is the nuclear charge of the atom
- END_DOC
- c_mn_o_sm_17 = 0.d0
- integer :: i
- do i = 2, 10 ! loop over nuclear charge
- c_mn_o_sm_17(0,0,1,i) = 0.5d0 ! all the linear terms are set to 1/2 to satisfy the anti-parallel spin condition
- enddo
- ! He atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,2) = 0.09239d0
- c_mn_o_sm_17(0,0,3,2) = -0.38664d0
- c_mn_o_sm_17(0,0,4,2) = 0.95764d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,2) = 0.23208d0
- c_mn_o_sm_17(3,0,0,2) = -0.45032d0
- c_mn_o_sm_17(4,0,0,2) = 0.82777d0
- c_mn_o_sm_17(2,2,0,2) = -4.15388d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,2) = 0.80622d0
- c_mn_o_sm_17(2,2,2,2) = 10.19704d0
- c_mn_o_sm_17(4,0,2,2) = -4.96259d0
- c_mn_o_sm_17(2,0,4,2) = -1.35647d0
- c_mn_o_sm_17(4,2,2,2) = -5.90907d0
- c_mn_o_sm_17(6,0,2,2) = 0.90343d0
- c_mn_o_sm_17(4,0,4,2) = 5.50739d0
- c_mn_o_sm_17(2,2,4,2) = -0.03154d0
- c_mn_o_sm_17(2,0,6,2) = -1.1051860
-
-
- ! Ne atom
- ! two electron terms
- c_mn_o_sm_17(0,0,2,10) = -0.80909d0
- c_mn_o_sm_17(0,0,3,10) = -0.00219d0
- c_mn_o_sm_17(0,0,4,10) = 0.59188d0
- ! one-electron terms
- c_mn_o_sm_17(2,0,0,10) = -0.00567d0
- c_mn_o_sm_17(3,0,0,10) = 0.14011d0
- c_mn_o_sm_17(4,0,0,10) = -0.05671d0
- c_mn_o_sm_17(2,2,0,10) = -3.33767d0
- ! ee-n terms
- c_mn_o_sm_17(2,0,2,10) = 1.95067d0
- c_mn_o_sm_17(2,2,2,10) = 6.83340d0
- c_mn_o_sm_17(4,0,2,10) = -3.29231d0
- c_mn_o_sm_17(2,0,4,10) = -2.44998d0
- c_mn_o_sm_17(4,2,2,10) = -2.13029d0
- c_mn_o_sm_17(6,0,2,10) = 2.25768d0
- c_mn_o_sm_17(4,0,4,10) = 1.97951d0
- c_mn_o_sm_17(2,2,4,10) = -2.0924160
- c_mn_o_sm_17(2,0,6,10) = 0.35493d0
-
-END_PROVIDER
-
- BEGIN_PROVIDER [ double precision, b_I_sm_90,(2:10)]
-&BEGIN_PROVIDER [ double precision, d_I_sm_90,(2:10)]
- implicit none
- BEGIN_DOC
-! "b_I" and "d_I" parameters of Eqs. (4) and (5) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- END_DOC
- b_I_sm_90 = 1.d0
- d_I_sm_90 = 1.d0
-
-END_PROVIDER
-
-subroutine get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- integer, intent(in) :: sm_j, i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- END_DOC
- double precision :: r_inucl,r_jnucl,r_ij,b_I, d_I
- b_I = b_I_sm_90(i_charge)
- d_I = d_I_sm_90(i_charge)
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- call jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
-end
-
-subroutine get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
- ! rescaled variables of Eq. (5) and (6) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! the "b_I" and "d_I" parameters are the same as in Eqs. (5) and (6)
- END_DOC
- double precision, intent(in) :: r1(3),r2(3),rI(3)
- double precision, intent(in) :: b_I, d_I
- double precision, intent(out):: r_inucl,r_jnucl,r_ij
- double precision :: rin, rjn, rij
- integer :: i
- rin = 0.d0
- rjn = 0.d0
- rij = 0.d0
- do i = 1,3
- rin += (r1(i) - rI(i)) * (r1(i) - rI(i))
- rjn += (r2(i) - rI(i)) * (r2(i) - rI(i))
- rij += (r2(i) - r1(i)) * (r2(i) - r1(i))
- enddo
- rin = dsqrt(rin)
- rjn = dsqrt(rjn)
- rij = dsqrt(rij)
- r_inucl = b_I * rin/(1.d0 + b_I * rin)
- r_jnucl = b_I * rjn/(1.d0 + b_I * rjn)
- r_ij = d_I * rij/(1.d0 + b_I * rij)
-end
-
-subroutine jastrow_func_sm_90(r_inucl,r_jnucl,r_ij,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- implicit none
- BEGIN_DOC
- ! Jastrow function as in Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
- ! Here the r_inucl, r_jnucl are the rescaled variables as defined in Eq. (5) with "b_I"
- ! r_ij is the rescaled variable as defined in Eq. (6) with "d_I"
- ! the i_charge variable is the integer specifying the charge of the atom for the Jastrow
- ! the sm_j integer variable represents the "quality" of the jastrow : sm_j = 7, 9, 17
- !
- ! it returns the j_1e : sum of terms with "o" = "n" = 0, "m" /= 0,
- ! j_2e : sum of terms with "m" = "n" = 0, "o" /= 0,
- ! j_een : sum of terms with "m" /=0, "n" /= 0, "o" /= 0,
- ! j_tot : the total sum
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer, intent(in) :: sm_j,i_charge
- double precision, intent(out):: j_1e,j_2e,j_een,j_tot
- j_1e = 0.D0
- j_2e = 0.D0
- j_een = 0.D0
- double precision :: delta_mn,jastrow_sm_90_atomic
- integer :: m,n,o
-BEGIN_TEMPLATE
- ! pure 2e part
- n = 0
- m = 0
- if(sm_j == $X )then
- do o = 1, o_max_sm_$X
- if(dabs(c_mn_o_sm_$X(m,n,o,i_charge)).lt.1.d-10)cycle
- j_2e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! pure one-e part
- o = 0
- if(sm_j == $X)then
- do n = 2, n_max_sm_$X
- do m = 2, m_max_sm_$X
- j_1e += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
-! else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- ! e-e-n part
- if(sm_j == $X)then
- do o = 1, o_max_sm_$X
- do m = 2, m_max_sm_$X
- do n = 2, n_max_sm_$X
- j_een += c_mn_o_sm_$X(m,n,o,i_charge) * jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- enddo
- enddo
- enddo
- else
-! print*,'sm_j = ',sm_j
-! print*,'not implemented, stop'
-! stop
- endif
- j_tot = j_1e + j_2e + j_een
-SUBST [ X]
- 7 ;;
- 9 ;;
- 17 ;;
-END_TEMPLATE
-end
-
-double precision function jastrow_sm_90_atomic(m,n,o,i_charge,r_inucl,r_jnucl,r_ij)
- implicit none
- BEGIN_DOC
-! contribution to the function of Eq. (4) of Schmidt,Moskowitz, JCP, 93, 4172 (1990)
-! for a given m,n,o and atom
- END_DOC
- double precision, intent(in) :: r_inucl,r_jnucl,r_ij
- integer , intent(in) :: m,n,o,i_charge
- double precision :: delta_mn
- if(m==n)then
- delta_mn = 0.5d0
- else
- delta_mn = 1.D0
- endif
- jastrow_sm_90_atomic = delta_mn * (r_inucl**m * r_jnucl**n + r_jnucl**m * r_inucl**n)*r_ij**o
-end
diff --git a/plugins/local/tc_scf/plot_j_schMos.irp.f b/plugins/local/tc_scf/plot_j_schMos.irp.f
deleted file mode 100644
index eda0dd25..00000000
--- a/plugins/local/tc_scf/plot_j_schMos.irp.f
+++ /dev/null
@@ -1,69 +0,0 @@
-program plot_j
- implicit none
- double precision :: r1(3),rI(3),r2(3)
- double precision :: r12,dx,xmax, j_1e,j_2e,j_een,j_tot
- double precision :: j_mu_F_x_j
- integer :: i,nx,m,i_charge,sm_j
-
- character*(128) :: output
- integer :: i_unit_output_He_sm_7,i_unit_output_Ne_sm_7
- integer :: i_unit_output_He_sm_17,i_unit_output_Ne_sm_17
- integer :: getUnitAndOpen
- output='J_SM_7_He'
- i_unit_output_He_sm_7 = getUnitAndOpen(output,'w')
- output='J_SM_7_Ne'
- i_unit_output_Ne_sm_7 = getUnitAndOpen(output,'w')
-
- output='J_SM_17_He'
- i_unit_output_He_sm_17 = getUnitAndOpen(output,'w')
- output='J_SM_17_Ne'
- i_unit_output_Ne_sm_17 = getUnitAndOpen(output,'w')
-
- rI = 0.d0
- r1 = 0.d0
- r2 = 0.d0
- r1(1) = 1.5d0
- xmax = 20.d0
- r2(1) = -xmax*0.5d0
- nx = 1000
- dx = xmax/dble(nx)
- do i = 1, nx
- r12 = 0.d0
- do m = 1, 3
- r12 += (r1(m) - r2(m))*(r1(m) - r2(m))
- enddo
- r12 = dsqrt(r12)
- double precision :: jmu,env_nucl,jmu_env,jmu_scaled, jmu_scaled_env
- double precision :: b_I,d_I,r_inucl,r_jnucl,r_ij
- b_I = 1.D0
- d_I = 1.D0
- call get_rescaled_variables_j_sm_90(r1,r2,rI,b_I,d_I,r_inucl,r_jnucl,r_ij)
- jmu=j_mu_F_x_j(r12)
- jmu_scaled=j_mu_F_x_j(r_ij)
- jmu_env = jmu * env_nucl(r1) * env_nucl(r2)
-! jmu_scaled_env= jmu_scaled * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_inucl**2)) * (1.d0 - env_coef(1) * dexp(-env_expo(1)*r_jnucl**2))
- jmu_scaled_env= jmu_scaled * env_nucl(r1) * env_nucl(r2)
- ! He
- i_charge = 2
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_He_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! Ne
- i_charge = 10
- ! SM 7 Jastrow
- sm_j = 7
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_7,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- ! SM 17 Jastrow
- sm_j = 17
- call get_full_sm_90_jastrow(r1,r2,rI,sm_j,i_charge, j_1e,j_2e,j_een,j_tot)
- write(i_unit_output_Ne_sm_17,'(100(F16.10,X))')r2(1),r12,j_mu_F_x_j(r12), j_1e,j_2e,j_een,j_tot,jmu_env,jmu_scaled,jmu_scaled_env
- r2(1) += dx
- enddo
-
-end
diff --git a/plugins/local/tc_scf/print_fit_param.irp.f b/plugins/local/tc_scf/print_fit_param.irp.f
deleted file mode 100644
index e62f0dde..00000000
--- a/plugins/local/tc_scf/print_fit_param.irp.f
+++ /dev/null
@@ -1,59 +0,0 @@
-program print_fit_param
-
- BEGIN_DOC
-! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- !call create_guess
- !call orthonormalize_mos
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i
-
- mu_erf = 1.d0
- touch mu_erf
-
- print *, ' fit for (1 - erf(x))^2'
- do i = 1, n_max_fit_slat
- print*, expo_gauss_1_erf_x_2(i), coef_gauss_1_erf_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x(i), 2.d0 * coef_gauss_j_mu_x(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)]^2'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_x_2(i), 4.d0 * coef_gauss_j_mu_x_2(i)
- enddo
-
- print *, ''
- print *, ' fit for [x * (1 - erf(x)) - 1/sqrt(pi) * exp(-x**2)] x [1 - erf(mu * r12)]'
- do i = 1, n_max_fit_slat
- print *, expo_gauss_j_mu_1_erf(i), 4.d0 * coef_gauss_j_mu_1_erf(i)
- enddo
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/print_tcscf_energy.irp.f b/plugins/local/tc_scf/print_tcscf_energy.irp.f
deleted file mode 100644
index 6f9afd9a..00000000
--- a/plugins/local/tc_scf/print_tcscf_energy.irp.f
+++ /dev/null
@@ -1,55 +0,0 @@
-program print_tcscf_energy
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e
-
- PROVIDE j2e_type mu_erf
- PROVIDE j1e_type j1e_coef j1e_expo
- PROVIDE env_type env_coef env_expo
-
- print*, ' j2e_type = ', j2e_type
- print*, ' j1e_type = ', j1e_type
- print*, ' env_type = ', env_type
-
- print*, ' mu_erf = ', mu_erf
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- !etc_3e = diag_three_elem_hf
- etc_3e = tcscf_energy_3e_naive
- endif
-
- print *, " E_TC = ", etc_tot
- print *, " E_1e = ", etc_1e
- print *, " E_2e = ", etc_2e
- print *, " E_3e = ", etc_3e
-
- return
-end subroutine main
-
-! ---
-
diff --git a/plugins/local/tc_scf/rh_tcscf_diis.irp.f b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
index 853c4ab5..1cade02a 100644
--- a/plugins/local/tc_scf/rh_tcscf_diis.irp.f
+++ b/plugins/local/tc_scf/rh_tcscf_diis.irp.f
@@ -61,7 +61,7 @@ subroutine rh_tcscf_diis()
etc_tot = TC_HF_energy
etc_1e = TC_HF_one_e_energy
etc_2e = TC_HF_two_e_energy
- etc_3e = diag_three_elem_hf
+ etc_3e = TC_HF_three_e_energy
!tc_grad = grad_non_hermit
er_DIIS = maxval(abs(FQS_SQF_mo))
e_delta = dabs(etc_tot - e_save)
@@ -189,7 +189,7 @@ subroutine rh_tcscf_diis()
etc_tot = TC_HF_energy
etc_1e = TC_HF_one_e_energy
etc_2e = TC_HF_two_e_energy
- etc_3e = diag_three_elem_hf
+ etc_3e = TC_HF_three_e_energy
!tc_grad = grad_non_hermit
er_DIIS = maxval(abs(FQS_SQF_mo))
e_delta = dabs(etc_tot - e_save)
diff --git a/plugins/local/tc_scf/rh_tcscf_simple.irp.f b/plugins/local/tc_scf/rh_tcscf_simple.irp.f
deleted file mode 100644
index 2c2cf2c2..00000000
--- a/plugins/local/tc_scf/rh_tcscf_simple.irp.f
+++ /dev/null
@@ -1,129 +0,0 @@
-! ---
-
-subroutine rh_tcscf_simple()
-
- implicit none
- integer :: i, j, it, dim_DIIS
- double precision :: t0, t1
- double precision :: e_save, e_delta, rho_delta
- double precision :: etc_tot, etc_1e, etc_2e, etc_3e, tc_grad
- double precision :: er_DIIS
- double precision, allocatable :: rho_old(:,:), rho_new(:,:)
-
- allocate(rho_old(ao_num,ao_num), rho_new(ao_num,ao_num))
-
- it = 0
- e_save = 0.d0
- dim_DIIS = 0
-
- ! ---
-
- if(.not. bi_ortho) then
- print *, ' grad_hermit = ', grad_hermit
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- endif
-
- ! ---
-
- if(bi_ortho) then
-
- PROVIDE level_shift_tcscf
- PROVIDE mo_l_coef mo_r_coef
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- ' it ', ' SCF TC Energy ', ' E(1e) ', ' E(2e) ', ' E(3e) ', ' energy diff ' &
- , ' gradient ', ' DIIS error ', ' level shift ', 'DIIS', ' WT (m)'
-
- write(6, '(A4,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A16,1X, A4, 1X, A8)') &
- '====', '================', '================', '================', '================', '================' &
- , '================', '================', '================', '====', '========'
-
-
- ! first iteration (HF orbitals)
- call wall_time(t0)
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
-
- do while(tc_grad .gt. dsqrt(thresh_tcscf))
- call wall_time(t0)
-
- it += 1
- if(it > n_it_tcscf_max) then
- print *, ' max of TCSCF iterations is reached ', n_it_TCSCF_max
- stop
- endif
-
- mo_l_coef = fock_tc_leigvec_ao
- mo_r_coef = fock_tc_reigvec_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
-
- etc_tot = TC_HF_energy
- etc_1e = TC_HF_one_e_energy
- etc_2e = TC_HF_two_e_energy
- etc_3e = 0.d0
- if(three_body_h_tc) then
- etc_3e = diag_three_elem_hf
- endif
- tc_grad = grad_non_hermit
- er_DIIS = maxval(abs(FQS_SQF_mo))
- e_delta = dabs(etc_tot - e_save)
- e_save = etc_tot
-
- call ezfio_set_tc_scf_tcscf_energy(etc_tot)
-
- call wall_time(t1)
- write(6, '(I4,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, F16.10,1X, I4,1X, F8.2)') &
- it, etc_tot, etc_1e, etc_2e, etc_3e, e_delta, tc_grad, er_DIIS, level_shift_tcscf, dim_DIIS, (t1-t0)/60.d0
- 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_e_energy
- print *, 'TC HF 2 e energy = ', TC_HF_two_e_energy
- print *, 'TC HF 3 body = ', diag_three_elem_hf
- print *, '***'
- print *, ''
- call save_good_hermit_tc_eigvectors
- TOUCH mo_coef
- call save_mos
- enddo
-
- endif
-
- print *, ' TCSCF Simple converged !'
- !call print_energy_and_mos(good_angles)
-
- deallocate(rho_old, rho_new)
-
-end
-
-! ---
-
diff --git a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f b/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
deleted file mode 100644
index 0f2663e5..00000000
--- a/plugins/local/tc_scf/rotate_tcscf_orbitals.irp.f
+++ /dev/null
@@ -1,369 +0,0 @@
-
-! ---
-
-program rotate_tcscf_orbitals
-
- BEGIN_DOC
- ! TODO : Rotate the bi-orthonormal orbitals in order to minimize left-right angles when degenerate
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- bi_ortho = .True.
- touch bi_ortho
-
- call minimize_tc_orb_angles()
- !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_to_maximize_overlap(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_to_maximize_overlap(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, tot_deg
- 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 = thr_degen_tc
-
- 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
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- 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_to_maximize_overlap
-
-! ---
-
-subroutine fix_right_to_one()
-
- implicit none
- integer :: i, j, m, n, mm, tot_deg
- double precision :: accu_d, accu_nd
- double precision :: de_thr, ei, ej, de
- integer, allocatable :: deg_num(:)
- double precision, allocatable :: R0(:,:), L0(:,:), W(:,:), e0(:)
- double precision, allocatable :: R(:,:), L(:,:), S(:,:), Stmp(:,:), tmp(:,:)
-
- n = ao_num
- m = mo_num
-
- allocate(L0(n,m), R0(n,m), W(n,n), e0(m))
- L0 = mo_l_coef
- R0 = mo_r_coef
- W = ao_overlap
-
- print*, ' fock matrix diag elements'
- do i = 1, m
- e0(i) = Fock_matrix_tc_mo_tot(i,i)
- print*, e0(i)
- enddo
-
- ! ---
-
- allocate( deg_num(m) )
- do i = 1, m
- deg_num(i) = 1
- enddo
-
- de_thr = 1d-6
-
- 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
-
- deallocate(e0)
-
- tot_deg = 0
- do i = 1, m
- if(deg_num(i).gt.1) then
- print *, ' degen on', i, deg_num(i)
- tot_deg = tot_deg + 1
- endif
- enddo
-
- if(tot_deg .eq. 0) then
- print *, ' no degen'
- return
- endif
-
- ! ---
-
- do i = 1, m
- mm = deg_num(i)
-
- if(mm .gt. 1) then
-
- allocate(L(n,mm), R(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)
- enddo
-
- ! ---
-
- call impose_weighted_orthog_svd(n, mm, W, R)
- call impose_weighted_biorthog_qr(n, mm, thresh_biorthog_diag, thresh_biorthog_nondiag, R, W, L)
-
- ! ---
-
- do j = 1, mm
- L0(1:n,i+j-1) = L(1:n,j)
- R0(1:n,i+j-1) = R(1:n,j)
- enddo
- deallocate(L, R)
-
- endif
- enddo
-
- call check_weighted_biorthog_binormalize(n, m, L0, W, R0, thresh_biorthog_diag, thresh_biorthog_nondiag, .true.)
-
- deallocate(W, deg_num)
-
- mo_l_coef = L0
- mo_r_coef = R0
- deallocate(L0, R0)
-
- call ezfio_set_bi_ortho_mos_mo_l_coef(mo_l_coef)
- call ezfio_set_bi_ortho_mos_mo_r_coef(mo_r_coef)
- print *, ' orbitals are rotated '
-
- return
-end subroutine fix_right_to_one
-
-! ---
diff --git a/plugins/local/tc_scf/tc_petermann_factor.irp.f b/plugins/local/tc_scf/tc_petermann_factor.irp.f
deleted file mode 100644
index 14fff898..00000000
--- a/plugins/local/tc_scf/tc_petermann_factor.irp.f
+++ /dev/null
@@ -1,91 +0,0 @@
-
-! ---
-
-program tc_petermann_factor
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- call main()
-
-end
-
-! ---
-
-subroutine main()
-
- implicit none
- integer :: i, j
- double precision :: Pf_diag_av
- double precision, allocatable :: Sl(:,:), Sr(:,:), Pf(:,:)
-
- allocate(Sl(mo_num,mo_num), Sr(mo_num,mo_num), Pf(mo_num,mo_num))
-
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_r_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-right orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_l_coef, ao_overlap, mo_l_coef, Sl)
- !call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
- ! , mo_l_coef, size(mo_l_coef, 1), mo_l_coef, size(mo_l_coef, 1) &
- ! , 0.d0, Sl, size(Sl, 1) )
-
- print *, ''
- print *, ' left-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sl(:,i)
- enddo
-
- call LTxSxR(ao_num, mo_num, mo_r_coef, ao_overlap, mo_r_coef, Sr)
-! call dgemm( "T", "N", mo_num, mo_num, ao_num, 1.d0 &
-! , mo_r_coef, size(mo_r_coef, 1), mo_r_coef, size(mo_r_coef, 1) &
-! , 0.d0, Sr, size(Sr, 1) )
-
- print *, ''
- print *, ' right-orthog matrix:'
- do i = 1, mo_num
- write(*,'(100(F8.4,X))') Sr(:,i)
- enddo
-
- print *, ''
- print *, ' Petermann matrix:'
- do i = 1, mo_num
- do j = 1, mo_num
- Pf(j,i) = Sl(j,i) * Sr(j,i)
- enddo
- write(*,'(100(F8.4,X))') Pf(:,i)
- enddo
-
- Pf_diag_av = 0.d0
- do i = 1, mo_num
- Pf_diag_av = Pf_diag_av + Pf(i,i)
- enddo
- Pf_diag_av = Pf_diag_av / dble(mo_num)
-
- print *, ''
- print *, ' mean of the diagonal Petermann factor = ', Pf_diag_av
-
- deallocate(Sl, Sr, Pf)
-
- return
-end subroutine
-
-! ---
-
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index ee8e8dad..f099b90e 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -10,13 +10,10 @@ program tc_scf
integer :: i
logical :: good_angles
- PROVIDE j1e_type
- PROVIDE j2e_type
- PROVIDE tcscf_algorithm
-
print *, ' TC-SCF with:'
- print *, ' j1e_type = ', j1e_type
print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
write(json_unit,json_array_open_fmt) 'tc-scf'
@@ -29,7 +26,6 @@ program tc_scf
call write_int(6, my_n_pt_r_grid, 'radial external grid over')
call write_int(6, my_n_pt_a_grid, 'angular external grid over')
-
if(tc_integ_type .eq. "numeric") then
my_extra_grid_becke = .True.
PROVIDE tc_grid2_a tc_grid2_r
@@ -41,17 +37,7 @@ program tc_scf
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
- !call create_guess()
- !call orthonormalize_mos()
-
- if(tcscf_algorithm == 'DIIS') then
- call rh_tcscf_diis()
- elseif(tcscf_algorithm == 'Simple') then
- call rh_tcscf_simple()
- else
- print *, ' not implemented yet', tcscf_algorithm
- stop
- endif
+ call rh_tcscf_diis()
PROVIDE Fock_matrix_tc_diag_mo_tot
print*, ' Eigenvalues:'
@@ -59,14 +45,11 @@ program tc_scf
print*, i, Fock_matrix_tc_diag_mo_tot(i)
enddo
- ! TODO
- ! rotate angles in separate code only if necessary
- if(minimize_lr_angles)then
+ if(minimize_lr_angles) then
call minimize_tc_orb_angles()
endif
call print_energy_and_mos(good_angles)
-
write(json_unit,json_array_close_fmtx)
call json_close
diff --git a/plugins/local/tc_scf/tc_scf_dm.irp.f b/plugins/local/tc_scf/tc_scf_dm.irp.f
index bf31a4a1..5d25fce2 100644
--- a/plugins/local/tc_scf/tc_scf_dm.irp.f
+++ b/plugins/local/tc_scf/tc_scf_dm.irp.f
@@ -10,16 +10,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_beta, (ao_num, ao_num)
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
-
- else
-
- TCSCF_density_matrix_ao_beta = SCF_density_matrix_ao_beta
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_beta = TCSCF_bi_ort_dm_ao_beta
END_PROVIDER
@@ -35,16 +27,8 @@ BEGIN_PROVIDER [double precision, TCSCF_density_matrix_ao_alpha, (ao_num, ao_num
implicit none
- if(bi_ortho) then
-
- PROVIDE mo_l_coef mo_r_coef
- TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
-
- else
-
- TCSCF_density_matrix_ao_alpha = SCF_density_matrix_ao_alpha
-
- endif
+ PROVIDE mo_l_coef mo_r_coef
+ TCSCF_density_matrix_ao_alpha = TCSCF_bi_ort_dm_ao_alpha
END_PROVIDER
diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f
index 0266c605..74ab9d05 100644
--- a/plugins/local/tc_scf/tc_scf_energy.irp.f
+++ b/plugins/local/tc_scf/tc_scf_energy.irp.f
@@ -1,7 +1,8 @@
- BEGIN_PROVIDER [ double precision, TC_HF_energy ]
-&BEGIN_PROVIDER [ double precision, TC_HF_one_e_energy]
-&BEGIN_PROVIDER [ double precision, TC_HF_two_e_energy]
+ BEGIN_PROVIDER [double precision, TC_HF_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_one_e_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_two_e_energy ]
+&BEGIN_PROVIDER [double precision, TC_HF_three_e_energy]
BEGIN_DOC
! TC Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components.
@@ -27,8 +28,13 @@
enddo
enddo
- TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy
- TC_HF_energy += diag_three_elem_hf
+ if((three_body_h_tc .eq. .False.) .and. (.not. noL_standard)) then
+ TC_HF_three_e_energy = 0.d0
+ else
+ TC_HF_three_e_energy = noL_0e
+ endif
+
+ TC_HF_energy += TC_HF_one_e_energy + TC_HF_two_e_energy + TC_HF_three_e_energy
END_PROVIDER
diff --git a/plugins/local/tc_scf/tcscf_energy_naive.irp.f b/plugins/local/tc_scf/tcscf_energy_naive.irp.f
deleted file mode 100644
index 82bb8799..00000000
--- a/plugins/local/tc_scf/tcscf_energy_naive.irp.f
+++ /dev/null
@@ -1,80 +0,0 @@
-
-! ---
-
-BEGIN_PROVIDER [double precision, tcscf_energy_3e_naive]
-
- implicit none
- integer :: i, j, k
- integer :: neu, ned, D(elec_num)
- integer :: ii, jj, kk
- integer :: si, sj, sk
- double precision :: I_ijk, I_jki, I_kij, I_jik, I_ikj, I_kji
- double precision :: I_tot
-
- PROVIDE mo_l_coef mo_r_coef
-
- neu = elec_alpha_num
- ned = elec_beta_num
- if (neu > 0) D(1:neu) = [(2*i-1, i = 1, neu)]
- if (ned > 0) D(neu+1:neu+ned) = [(2*i, i = 1, ned)]
-
- !print*, "D = "
- !do i = 1, elec_num
- ! ii = (D(i) - 1) / 2 + 1
- ! si = mod(D(i), 2)
- ! print*, i, D(i), ii, si
- !enddo
-
- tcscf_energy_3e_naive = 0.d0
-
- do i = 1, elec_num - 2
- ii = (D(i) - 1) / 2 + 1
- si = mod(D(i), 2)
-
- do j = i + 1, elec_num - 1
- jj = (D(j) - 1) / 2 + 1
- sj = mod(D(j), 2)
-
- do k = j + 1, elec_num
- kk = (D(k) - 1) / 2 + 1
- sk = mod(D(k), 2)
-
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, jj, kk, I_ijk)
- I_tot = I_ijk
-
- if(sj==si .and. sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, kk, ii, I_jki)
- I_tot += I_jki
- endif
-
- if(sk==si .and. si==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, ii, jj, I_kij)
- I_tot += I_kij
- endif
-
- if(sj==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, jj, ii, kk, I_jik)
- I_tot -= I_jik
- endif
-
- if(sk==sj) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, ii, kk, jj, I_ikj)
- I_tot -= I_ikj
- endif
-
- if(sk==si) then
- call give_integrals_3_body_bi_ort(ii, jj, kk, kk, jj, ii, I_kji)
- I_tot -= I_kji
- endif
-
- tcscf_energy_3e_naive += I_tot
- enddo
- enddo
- enddo
-
- tcscf_energy_3e_naive = -tcscf_energy_3e_naive
-
-END_PROVIDER
-
-! ---
-
diff --git a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f b/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
deleted file mode 100644
index 0c9ebbd7..00000000
--- a/plugins/local/tc_scf/three_e_energy_bi_ortho.irp.f
+++ /dev/null
@@ -1,189 +0,0 @@
-
-subroutine contrib_3e_diag_sss(i, j, k, integral)
-
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
-
- implicit none
- integer, intent(in) :: i, j, k
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_13_int, exch_23_int, exch_12_int, c_3_int, c_minus_3_int
-
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int )!!! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, j, i, k, c_3_int) ! < i k j | j i k >
- call give_integrals_3_body_bi_ort(i, k, j, k, j, i, c_minus_3_int)! < i k j | k j i >
- integral = direct_int + c_3_int + c_minus_3_int
-
- ! negative terms :: exchange contrib
- call give_integrals_3_body_bi_ort(i, k, j, j, k, i, exch_13_int)!!! < i k j | j k i > : E_13
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)!!! < i k j | i j k > : E_23
- call give_integrals_3_body_bi_ort(i, k, j, k, i, j, exch_12_int)!!! < i k j | k i j > : E_12
-
- integral += - exch_13_int - exch_23_int - exch_12_int
- integral = -integral
-
-end
-
-! ---
-
-subroutine contrib_3e_diag_soo(i,j,k,integral)
- implicit none
- integer, intent(in) :: i,j,k
- BEGIN_DOC
- ! returns the pure same spin contribution to diagonal matrix element of 3e term
- END_DOC
- double precision, intent(out) :: integral
- double precision :: direct_int, exch_23_int
- call give_integrals_3_body_bi_ort(i, k, j, i, k, j, direct_int) ! < i k j | i k j >
- call give_integrals_3_body_bi_ort(i, k, j, i, j, k, exch_23_int)! < i k j | i j k > : E_23
- integral = direct_int - exch_23_int
- integral = -integral
-end
-
-
-subroutine give_aaa_contrib_bis(integral_aaa)
- implicit none
- double precision, intent(out) :: integral_aaa
- double precision :: integral
- integer :: i,j,k
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = i+1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
-
-end
-
-! ---
-
-subroutine give_aaa_contrib(integral_aaa)
-
- implicit none
- integer :: i, j, k
- double precision :: integral
- double precision, intent(out) :: integral_aaa
-
- integral_aaa = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_sss(i, j, k, integral)
- integral_aaa += integral
- enddo
- enddo
- enddo
- integral_aaa *= 1.d0/6.d0
-
- return
-end
-
-! ---
-
-subroutine give_aab_contrib(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = 1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
- integral_aab *= 0.5d0
-end
-
-
-subroutine give_aab_contrib_bis(integral_aab)
- implicit none
- double precision, intent(out) :: integral_aab
- double precision :: integral
- integer :: i,j,k
- integral_aab = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_alpha_num
- do k = j+1, elec_alpha_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_aab += integral
- enddo
- enddo
- enddo
-end
-
-
-subroutine give_abb_contrib(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
- integral_abb *= 0.5d0
-end
-
-subroutine give_abb_contrib_bis(integral_abb)
- implicit none
- double precision, intent(out) :: integral_abb
- double precision :: integral
- integer :: i,j,k
- integral_abb = 0.d0
- do i = 1, elec_alpha_num
- do j = 1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_soo(i,j,k,integral)
- integral_abb += integral
- enddo
- enddo
- enddo
-end
-
-subroutine give_bbb_contrib_bis(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = i+1, elec_beta_num
- do k = j+1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
-
-end
-
-subroutine give_bbb_contrib(integral_bbb)
- implicit none
- double precision, intent(out) :: integral_bbb
- double precision :: integral
- integer :: i,j,k
- integral_bbb = 0.d0
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do k = 1, elec_beta_num
- call contrib_3e_diag_sss(i,j,k,integral)
- integral_bbb += integral
- enddo
- enddo
- enddo
- integral_bbb *= 1.d0/6.d0
-end
-
-
diff --git a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
index 7ce57578..ec5167d1 100644
--- a/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
+++ b/plugins/local/tc_scf/write_ao_2e_tc_integ.irp.f
@@ -4,11 +4,9 @@ program write_ao_2e_tc_integ
implicit none
- PROVIDE j1e_type
- PROVIDE j2e_type
-
- print *, ' j1e_type = ', j1e_type
print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
From 23acd603d01118e0f2ce59fb14568a64d9994335 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Wed, 1 May 2024 23:17:36 +0200
Subject: [PATCH 116/140] removed diag_three_elem_hf
---
plugins/local/tc_scf/tc_scf_energy.irp.f | 423 -----------------------
1 file changed, 423 deletions(-)
diff --git a/plugins/local/tc_scf/tc_scf_energy.irp.f b/plugins/local/tc_scf/tc_scf_energy.irp.f
index 14d618ae..74ab9d05 100644
--- a/plugins/local/tc_scf/tc_scf_energy.irp.f
+++ b/plugins/local/tc_scf/tc_scf_energy.irp.f
@@ -40,426 +40,3 @@ END_PROVIDER
! ---
-BEGIN_PROVIDER [double precision, diag_three_elem_hf]
-
- BEGIN_DOC
- !
- ! < Phi_left | L | Phi_right >
- !
- !
- ! if three_body_h_tc == false and noL_standard == true ==> do a normal ordering
- !
- ! todo
- ! this should be equivalent to
- ! three_body_h_tc == true and noL_standard == false
- !
- ! if three_body_h_tc == false and noL_standard == false ==> this is equal to 0
- !
- END_DOC
-
- implicit none
- integer :: i, j, k, ipoint, mm
- double precision :: contrib, weight, four_third, one_third, two_third, exchange_int_231
- double precision :: integral_aaa, hthree, integral_aab, integral_abb, integral_bbb
- double precision, allocatable :: tmp(:)
- double precision, allocatable :: tmp_L(:,:), tmp_R(:,:)
- double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
- double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
-
- PROVIDE mo_l_coef mo_r_coef
-
- if(.not. three_body_h_tc) then
-
- if(noL_standard) then
- PROVIDE noL_0e
- diag_three_elem_hf = noL_0e
- else
- diag_three_elem_hf = 0.d0
- endif
-
- else
-
- PROVIDE int2_grad1_u12_bimo_t
- PROVIDE mos_l_in_r_array_transp
- PROVIDE mos_r_in_r_array_transp
-
- if(elec_alpha_num .eq. elec_beta_num) then
-
- allocate(tmp(elec_beta_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf -2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- else ! elec_alpha_num .neq. elec_beta_num
-
- allocate(tmp(elec_alpha_num))
- allocate(tmp_L(n_points_final_grid,3), tmp_R(n_points_final_grid,3))
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = 1, elec_beta_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
-
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- ! ---
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(j, i, ipoint, tmp_L, tmp_R) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp, final_weight_at_r_vector)
-
- !$OMP DO
- do j = elec_beta_num+1, elec_alpha_num
-
- tmp_L = 0.d0
- tmp_R = 0.d0
- do i = 1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_L(ipoint,1) = tmp_L(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,2) = tmp_L(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i)
- tmp_L(ipoint,3) = tmp_L(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i)
-
- tmp_R(ipoint,1) = tmp_R(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,2) = tmp_R(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_R(ipoint,3) = tmp_R(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_r_in_r_array_transp(ipoint,i)
- enddo
- enddo
-
- tmp(j) = 0.d0
- do ipoint = 1, n_points_final_grid
- tmp(j) = tmp(j) + 0.5d0 * final_weight_at_r_vector(ipoint) * (tmp_L(ipoint,1)*tmp_R(ipoint,1) + tmp_L(ipoint,2)*tmp_R(ipoint,2) + tmp_L(ipoint,3)*tmp_R(ipoint,3))
- enddo
- enddo ! j
- !$OMP END DO
- !$OMP END PARALLEL
-
- diag_three_elem_hf = -2.d0 * sum(tmp)
-
- deallocate(tmp)
- deallocate(tmp_L, tmp_R)
-
- ! ---
-
- allocate(tmp_O(n_points_final_grid), tmp_J(n_points_final_grid,3))
- tmp_O = 0.d0
- tmp_J = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, ipoint, tmp_O_priv, tmp_J_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_O, tmp_J)
-
- allocate(tmp_O_priv(n_points_final_grid), tmp_J_priv(n_points_final_grid,3))
- tmp_O_priv = 0.d0
- tmp_J_priv = 0.d0
-
- !$OMP DO
- do i = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO
- do i = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
- tmp_O_priv(ipoint) = tmp_O_priv(ipoint) + 0.5d0 * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,i)
- tmp_J_priv(ipoint,1) = tmp_J_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,i)
- tmp_J_priv(ipoint,2) = tmp_J_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,i)
- tmp_J_priv(ipoint,3) = tmp_J_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,i)
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_O = tmp_O + tmp_O_priv
- tmp_J = tmp_J + tmp_J_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_O_priv, tmp_J_priv)
- !$OMP END PARALLEL
-
- ! ---
-
- allocate(tmp_M(n_points_final_grid,3), tmp_S(n_points_final_grid))
- tmp_M = 0.d0
- tmp_S = 0.d0
-
- !$OMP PARALLEL &
- !$OMP DEFAULT(NONE) &
- !$OMP PRIVATE(i, j, ipoint, tmp_M_priv, tmp_S_priv) &
- !$OMP SHARED(elec_beta_num, elec_alpha_num, n_points_final_grid, &
- !$OMP mos_l_in_r_array_transp, mos_r_in_r_array_transp, &
- !$OMP int2_grad1_u12_bimo_t, tmp_M, tmp_S)
-
- allocate(tmp_M_priv(n_points_final_grid,3), tmp_S_priv(n_points_final_grid))
- tmp_M_priv = 0.d0
- tmp_S_priv = 0.d0
-
- !$OMP DO COLLAPSE(2)
- do i = 1, elec_beta_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = 1, elec_beta_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * mos_l_in_r_array_transp(ipoint,j) * mos_r_in_r_array_transp(ipoint,i)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP DO COLLAPSE(2)
- do i = elec_beta_num+1, elec_alpha_num
- do j = elec_beta_num+1, elec_alpha_num
- do ipoint = 1, n_points_final_grid
-
- tmp_M_priv(ipoint,1) = tmp_M_priv(ipoint,1) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,2) = tmp_M_priv(ipoint,2) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
- tmp_M_priv(ipoint,3) = tmp_M_priv(ipoint,3) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,j,i) * mos_l_in_r_array_transp(ipoint,i) * mos_r_in_r_array_transp(ipoint,j)
-
- tmp_S_priv(ipoint) = tmp_S_priv(ipoint) + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,1,i,j) * int2_grad1_u12_bimo_t(ipoint,1,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,2,i,j) * int2_grad1_u12_bimo_t(ipoint,2,j,i) &
- + 0.5d0 * int2_grad1_u12_bimo_t(ipoint,3,i,j) * int2_grad1_u12_bimo_t(ipoint,3,j,i)
- enddo
- enddo
- enddo
- !$OMP END DO NOWAIT
-
- !$OMP CRITICAL
- tmp_M = tmp_M + tmp_M_priv
- tmp_S = tmp_S + tmp_S_priv
- !$OMP END CRITICAL
-
- deallocate(tmp_M_priv, tmp_S_priv)
- !$OMP END PARALLEL
-
- allocate(tmp(n_points_final_grid))
-
- do ipoint = 1, n_points_final_grid
-
- tmp_S(ipoint) = 2.d0 * (tmp_J(ipoint,1)*tmp_J(ipoint,1) + tmp_J(ipoint,2)*tmp_J(ipoint,2) + tmp_J(ipoint,3)*tmp_J(ipoint,3)) - tmp_S(ipoint)
-
- tmp(ipoint) = final_weight_at_r_vector(ipoint) * ( tmp_O(ipoint) * tmp_S(ipoint) &
- - 2.d0 * ( tmp_J(ipoint,1) * tmp_M(ipoint,1) &
- + tmp_J(ipoint,2) * tmp_M(ipoint,2) &
- + tmp_J(ipoint,3) * tmp_M(ipoint,3)))
- enddo
-
- diag_three_elem_hf = diag_three_elem_hf - 2.d0 * (sum(tmp))
-
- deallocate(tmp)
-
- endif ! alpha/beta condition
-
- endif ! three_body_h_tc
-
-END_PROVIDER
-
-! ---
-
From 1c2b737586eba60cfec15ce8c452bdff727c70b9 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 2 May 2024 16:05:13 +0200
Subject: [PATCH 117/140] Fixed Warning with nproc
---
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 97cbde67..de01656b 100644
--- a/src/utils/util.irp.f
+++ b/src/utils/util.irp.f
@@ -327,12 +327,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, external :: omp_get_num_threads
nproc = 1
!$OMP PARALLEL
!$OMP MASTER
From 425e7e4ee0ac740220bb921ba7a607836b1acffe Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Thu, 2 May 2024 16:22:01 +0200
Subject: [PATCH 118/140] Changed symetric_fock_tc into symmetric_fock_tc
---
plugins/local/tc_keywords/EZFIO.cfg | 2 +-
plugins/local/tc_scf/fock_hermit.irp.f | 20 ++++++++++----------
2 files changed, 11 insertions(+), 11 deletions(-)
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index bc691fc3..e0776136 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -106,7 +106,7 @@ doc: If |true|, the MO basis is assumed to be bi-orthonormal
interface: ezfio,provider,ocaml
default: True
-[symetric_fock_tc]
+[symmetric_fock_tc]
type: logical
doc: If |true|, using F+F^t as Fock TC
interface: ezfio,provider,ocaml
diff --git a/plugins/local/tc_scf/fock_hermit.irp.f b/plugins/local/tc_scf/fock_hermit.irp.f
index 5a51b324..3460157e 100644
--- a/plugins/local/tc_scf/fock_hermit.irp.f
+++ b/plugins/local/tc_scf/fock_hermit.irp.f
@@ -4,7 +4,7 @@
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
+! 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
@@ -14,11 +14,11 @@ BEGIN_PROVIDER [ double precision, good_hermit_tc_fock_mat, (mo_num, mo_num)]
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)
+ good_hermit_tc_fock_mat(i,j) = Fock_matrix_tc_mo_tot(j,i)
enddo
enddo
-END_PROVIDER
+END_PROVIDER
BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
@@ -35,7 +35,7 @@ BEGIN_PROVIDER [ double precision, hermit_average_tc_fock_mat, (mo_num, mo_num)]
enddo
enddo
-END_PROVIDER
+END_PROVIDER
! ---
@@ -44,13 +44,13 @@ BEGIN_PROVIDER [ double precision, grad_hermit]
BEGIN_DOC
! square of gradient of the energy
END_DOC
- if(symetric_fock_tc)then
+ if(symmetric_fock_tc)then
grad_hermit = grad_hermit_average_tc_fock_mat
else
grad_hermit = grad_good_hermit_tc_fock_mat
endif
-END_PROVIDER
+END_PROVIDER
BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
implicit none
@@ -64,7 +64,7 @@ BEGIN_PROVIDER [ double precision, grad_good_hermit_tc_fock_mat]
grad_good_hermit_tc_fock_mat += dabs(good_hermit_tc_fock_mat(i,j))
enddo
enddo
-END_PROVIDER
+END_PROVIDER
! ---
@@ -80,7 +80,7 @@ BEGIN_PROVIDER [ double precision, grad_hermit_average_tc_fock_mat]
grad_hermit_average_tc_fock_mat += dabs(hermit_average_tc_fock_mat(i,j))
enddo
enddo
-END_PROVIDER
+END_PROVIDER
! ---
@@ -95,8 +95,8 @@ subroutine save_good_hermit_tc_eigvectors()
sign = 1
label = "Canonical"
output = .False.
-
- if(symetric_fock_tc)then
+
+ if(symmetric_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)
From bd8d45b99b7505e00533bd9e97ad1b43453fb037 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Thu, 2 May 2024 17:18:45 +0200
Subject: [PATCH 119/140] FIXED BUG IN OPTIM J_BH
---
plugins/local/bi_ort_ints/no_dressing.irp.f | 8 -
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 183 ++++++++----------
plugins/local/slater_tc/tc_hmat.irp.f | 1 +
.../local/tc_bi_ortho/print_tc_energy.irp.f | 27 ++-
plugins/local/tc_scf/tc_scf.irp.f | 31 ++-
5 files changed, 117 insertions(+), 133 deletions(-)
diff --git a/plugins/local/bi_ort_ints/no_dressing.irp.f b/plugins/local/bi_ort_ints/no_dressing.irp.f
index 721ac0f8..fd2c6285 100644
--- a/plugins/local/bi_ort_ints/no_dressing.irp.f
+++ b/plugins/local/bi_ort_ints/no_dressing.irp.f
@@ -336,9 +336,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
double precision, allocatable :: tmp_M(:,:), tmp_S(:), tmp_O(:), tmp_J(:,:)
double precision, allocatable :: tmp_M_priv(:,:), tmp_S_priv(:), tmp_O_priv(:), tmp_J_priv(:,:)
- call wall_time(t0)
- print*, " Providing noL_0e ..."
-
if(elec_alpha_num .eq. elec_beta_num) then
allocate(tmp(elec_beta_num))
@@ -713,11 +710,6 @@ BEGIN_PROVIDER [double precision, noL_0e]
endif
- call wall_time(t1)
- print*, " Wall time for noL_0e (min) = ", (t1 - t0)/60.d0
-
- print*, " noL_0e = ", noL_0e
-
END_PROVIDER
! ---
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 33563102..db06e835 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -4,7 +4,7 @@
subroutine get_grad1_u12_withsq_r1_seq(ipoint, n_grid2, resx, resy, resz, res)
BEGIN_DOC
- !
+ !
! grad_1 u(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -167,7 +167,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
integer :: jpoint
integer :: i_nucl, p, mpA, npA, opA
double precision :: r2(3)
- double precision :: dx, dy, dz, r12, tmp, r12_inv
+ double precision :: dx, dy, dz, r12, tmp
double precision :: mu_val, mu_tmp, mu_der(3)
double precision :: rn(3), f1A, grad1_f1A(3), f2A, grad2_f2A(3), g12, grad1_g12(3)
double precision :: tmp1, tmp2
@@ -181,7 +181,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
! d/dy1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (y1 - y2)
! d/dz1 j(mu,r12) = 0.5 * [(1 - erf(mu * r12)) / r12] * (z1 - z2)
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -191,19 +191,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dx * dx + dy * dy + dz * dz
-
- if(r12 .lt. 1d-20) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ if(r12 .lt. 1d-10) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
- r12_inv = 1.d0/dsqrt(r12)
- r12 = r12*r12_inv
-
- tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) * r12_inv
+ tmp = 0.5d0 * (1.d0 - derf(mu_erf * r12)) / r12
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
@@ -212,10 +208,10 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Mur") then
- ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
+ ! d/dx1 j(mu(r1,r2),r12) = exp(-(mu(r1,r2)*r12)**2) /(2 *sqrt(pi) * mu(r1,r2)**2 ) d/dx1 mu(r1,r2)
! + 0.5 * (1 - erf(mu(r1,r2) *r12))/r12 * (x1 - x2)
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -224,29 +220,23 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
- r12 = dx * dx + dy * dy + dz * dz
+ call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
+ mu_tmp = mu_val * r12
+ tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
+ gradx(jpoint) = tmp * mu_der(1)
+ grady(jpoint) = tmp * mu_der(2)
+ gradz(jpoint) = tmp * mu_der(3)
- if(r12 .lt. 1d-20) then
+ if(r12 .lt. 1d-10) then
gradx(jpoint) = 0.d0
grady(jpoint) = 0.d0
gradz(jpoint) = 0.d0
cycle
endif
- r12_inv = 1.d0/dsqrt(r12)
- r12 = r12*r12_inv
-
- call mu_r_val_and_grad(r1, r2, mu_val, mu_der)
-
- mu_tmp = mu_val * r12
- tmp = inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / (mu_val * mu_val)
-
- gradx(jpoint) = tmp * mu_der(1)
- grady(jpoint) = tmp * mu_der(2)
- gradz(jpoint) = tmp * mu_der(3)
-
- tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) * r12_inv
+ tmp = 0.5d0 * (1.d0 - derf(mu_tmp)) / r12
gradx(jpoint) = gradx(jpoint) + tmp * dx
grady(jpoint) = grady(jpoint) + tmp * dy
@@ -264,7 +254,7 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
PROVIDE a_boys
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -273,17 +263,14 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dx * dx + dy * dy + dz * dz
-
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
if(r12 .lt. 1d-10) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
- r12 = dsqrt(r12)
-
tmp = 1.d0 + a_boys * r12
tmp = 0.5d0 / (r12 * tmp * tmp)
@@ -294,13 +281,16 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
elseif(j2e_type .eq. "Boys_Handy") then
- integer :: powmax
- powmax = max(maxval(jBH_m),maxval(jBH_n))
-
+ integer :: powmax1, powmax, powmax2
double precision, allocatable :: f1A_power(:), f2A_power(:), double_p(:), g12_power(:)
- allocate (f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
- do p=0,powmax
+ powmax1 = max(maxval(jBH_m), maxval(jBH_n))
+ powmax2 = maxval(jBH_o)
+ powmax = max(powmax1, powmax2)
+
+ allocate(f1A_power(-1:powmax), f2A_power(-1:powmax), g12_power(-1:powmax), double_p(0:powmax))
+
+ do p = 0, powmax
double_p(p) = dble(p)
enddo
@@ -318,11 +308,10 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
-
- do i_nucl = 1, nucl_num
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
+ do i_nucl = 1, nucl_num
rn(1) = nucl_coord(i_nucl,1)
rn(2) = nucl_coord(i_nucl,2)
@@ -332,23 +321,15 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
call jBH_elem_fct_grad(jBH_en(i_nucl), r2, rn, f2A, grad2_f2A)
call jBH_elem_fct_grad(jBH_ee(i_nucl), r1, r2, g12, grad1_g12)
-
! Compute powers of f1A and f2A
-
- do p = 1, maxval(jBH_m(:,i_nucl))
+ do p = 1, powmax1
f1A_power(p) = f1A_power(p-1) * f1A
- enddo
-
- do p = 1, maxval(jBH_n(:,i_nucl))
f2A_power(p) = f2A_power(p-1) * f2A
enddo
-
- do p = 1, maxval(jBH_o(:,i_nucl))
+ do p = 1, powmax2
g12_power(p) = g12_power(p-1) * g12
enddo
-
-
do p = 1, jBH_size
mpA = jBH_m(p,i_nucl)
npA = jBH_n(p,i_nucl)
@@ -358,27 +339,22 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
tmp = tmp * 0.5d0
endif
-!TODO : Powers to optimize here
-
-! tmp1 = 0.d0
-! if(mpA .gt. 0) then
-! tmp1 = tmp1 + dble(mpA) * f1A**(mpA-1) * f2A**npA
-! endif
-! if(npA .gt. 0) then
-! tmp1 = tmp1 + dble(npA) * f1A**(npA-1) * f2A**mpA
-! endif
-! tmp1 = tmp1 * g12**(opA)
-!
-! tmp2 = 0.d0
-! if(opA .gt. 0) then
-! tmp2 = tmp2 + dble(opA) * g12**(opA-1) * (f1A**(mpA) * f2A**(npA) + f1A**(npA) * f2A**(mpA))
-! endif
-
tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
tmp1 = tmp1 * g12_power(opA)
-
tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
+ !tmp1 = 0.d0
+ !if(mpA .gt. 0) then
+ ! tmp1 = tmp1 + dble(mpA) * f1A**dble(mpA-1) * f2A**dble(npA)
+ !endif
+ !if(npA .gt. 0) then
+ ! tmp1 = tmp1 + dble(npA) * f1A**dble(npA-1) * f2A**dble(mpA)
+ !endif
+ !tmp1 = tmp1 * g12**dble(opA)
+ !tmp2 = 0.d0
+ !if(opA .gt. 0) then
+ ! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
+ !endif
gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
@@ -418,10 +394,10 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
integer :: jpoint
double precision :: r2(3)
- double precision :: dx, dy, dz, r12, r12_inv, tmp
+ double precision :: dx, dy, dz, r12, tmp
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -431,19 +407,15 @@ subroutine grad1_jmu_r1_seq(mu, r1, n_grid2, gradx, grady, gradz)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
- r12 = dx * dx + dy * dy + dz * dz
-
- if(r12 .lt. 1d-20) then
- gradx(jpoint) = 0.d0
- grady(jpoint) = 0.d0
- gradz(jpoint) = 0.d0
+ r12 = dsqrt(dx * dx + dy * dy + dz * dz)
+ if(r12 .lt. 1d-10) then
+ gradx(jpoint) = 0.d0
+ grady(jpoint) = 0.d0
+ gradz(jpoint) = 0.d0
cycle
endif
- r12_inv = 1.d0 / dsqrt(r12)
- r12 = r12 * r12_inv
-
- tmp = 0.5d0 * (1.d0 - derf(mu * r12)) * r12_inv
+ tmp = 0.5d0 * (1.d0 - derf(mu * r12)) / r12
gradx(jpoint) = tmp * dx
grady(jpoint) = tmp * dy
@@ -467,7 +439,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
integer :: jpoint
double precision :: r2(3)
double precision :: dx, dy, dz
- double precision :: mu_tmp, r12, mu_erf_inv
+ double precision :: mu_tmp, r12
PROVIDE final_grid_points_extra
@@ -475,21 +447,20 @@ subroutine j12_r1_seq(r1, n_grid2, res)
PROVIDE mu_erf
- mu_erf_inv = 1.d0 / mu_erf
- do jpoint = 1, n_points_extra_final_grid ! r2
-
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
-
+
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
mu_tmp = mu_erf * r12
-
- res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) * mu_erf_inv
+
+ res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(mu_tmp)) - inv_sq_pi_2 * dexp(-mu_tmp*mu_tmp) / mu_erf
enddo
elseif(j2e_type .eq. "Boys") then
@@ -498,7 +469,7 @@ subroutine j12_r1_seq(r1, n_grid2, res)
PROVIDE a_boys
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
@@ -540,19 +511,19 @@ subroutine jmu_r1_seq(mu, r1, n_grid2, res)
tmp1 = inv_sq_pi_2 / mu
- do jpoint = 1, n_points_extra_final_grid ! r2
-
+ do jpoint = 1, n_points_extra_final_grid ! r2
+
r2(1) = final_grid_points_extra(1,jpoint)
r2(2) = final_grid_points_extra(2,jpoint)
r2(3) = final_grid_points_extra(3,jpoint)
-
+
dx = r1(1) - r2(1)
dy = r1(2) - r2(2)
dz = r1(3) - r2(3)
r12 = dsqrt(dx * dx + dy * dy + dz * dz)
tmp2 = mu * r12
-
+
res(jpoint) = 0.5d0 * r12 * (1.d0 - derf(tmp2)) - tmp1 * dexp(-tmp2*tmp2)
enddo
@@ -579,7 +550,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -598,7 +569,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -618,7 +589,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -636,7 +607,7 @@ subroutine env_nucl_r1_seq(n_grid2, res)
res = 1.d0
- do jpoint = 1, n_points_extra_final_grid ! r2
+ do jpoint = 1, n_points_extra_final_grid ! r2
r(1) = final_grid_points_extra(1,jpoint)
r(2) = final_grid_points_extra(2,jpoint)
r(3) = final_grid_points_extra(3,jpoint)
@@ -666,7 +637,7 @@ end
subroutine get_grad1_u12_2e_r1_seq(ipoint, n_grid2, resx, resy, resz)
BEGIN_DOC
- !
+ !
! grad_1 u_2e(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -786,7 +757,7 @@ end
subroutine get_u12_2e_r1_seq(ipoint, n_grid2, res)
BEGIN_DOC
- !
+ !
! u_2e(r1,r2)
!
! we use grid for r1 and extra_grid for r2
@@ -909,7 +880,7 @@ subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct)
endif
return
-end
+end
! ---
diff --git a/plugins/local/slater_tc/tc_hmat.irp.f b/plugins/local/slater_tc/tc_hmat.irp.f
index abec410d..cc780364 100644
--- a/plugins/local/slater_tc/tc_hmat.irp.f
+++ b/plugins/local/slater_tc/tc_hmat.irp.f
@@ -22,6 +22,7 @@ BEGIN_PROVIDER [double precision, htilde_matrix_elmt_bi_ortho, (N_det,N_det)]
if(noL_standard) then
PROVIDE noL_0e
+ print*, "noL_0e =", noL_0e
PROVIDE noL_1e
PROVIDE noL_2e
endif
diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
index 1fa0c6d9..979d792b 100644
--- a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_energy.irp.f
@@ -9,15 +9,6 @@ program print_tc_energy
read_wf = .True.
touch read_wf
- PROVIDE j2e_type
- PROVIDE j1e_type
- PROVIDE env_type
-
- print *, ' j2e_type = ', j2e_type
- print *, ' j1e_type = ', j1e_type
- print *, ' env_type = ', env_type
-
-
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
my_n_pt_r_grid = tc_grid1_r
@@ -38,6 +29,24 @@ program print_tc_energy
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+
+ PROVIDE j2e_type
+ PROVIDE j1e_type
+ PROVIDE env_type
+
+ print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
+
call write_tc_energy()
end
diff --git a/plugins/local/tc_scf/tc_scf.irp.f b/plugins/local/tc_scf/tc_scf.irp.f
index f099b90e..83da03ec 100644
--- a/plugins/local/tc_scf/tc_scf.irp.f
+++ b/plugins/local/tc_scf/tc_scf.irp.f
@@ -7,15 +7,6 @@ program tc_scf
END_DOC
implicit none
- integer :: i
- logical :: good_angles
-
- print *, ' TC-SCF with:'
- print *, ' j2e_type = ', j2e_type
- print *, ' j1e_type = ', j1e_type
- print *, ' env_type = ', env_type
-
- write(json_unit,json_array_open_fmt) 'tc-scf'
my_grid_becke = .True.
PROVIDE tc_grid1_a tc_grid1_r
@@ -37,6 +28,26 @@ program tc_scf
call write_int(6, my_n_pt_a_extra_grid, 'angular internal grid over')
endif
+ call main()
+
+end
+
+! ---
+
+subroutine main()
+
+ implicit none
+
+ integer :: i
+ logical :: good_angles
+
+ print *, ' TC-SCF with:'
+ print *, ' j2e_type = ', j2e_type
+ print *, ' j1e_type = ', j1e_type
+ print *, ' env_type = ', env_type
+
+ write(json_unit,json_array_open_fmt) 'tc-scf'
+
call rh_tcscf_diis()
PROVIDE Fock_matrix_tc_diag_mo_tot
@@ -84,7 +95,7 @@ subroutine create_guess()
SOFT_TOUCH mo_label
endif
-end subroutine create_guess
+end
! ---
From 13785b267c36319925ffa72ebe42399fa932ffae Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 3 May 2024 11:34:30 +0200
Subject: [PATCH 120/140] fixed a bug in src/scf_utils/roothaan_hall_scf.irp.f
---
.../extra_grid_vector.irp.f | 20 +++++++++----------
.../grid_becke_vector.irp.f | 20 +++++++++----------
src/scf_utils/roothaan_hall_scf.irp.f | 2 +-
3 files changed, 21 insertions(+), 21 deletions(-)
diff --git a/src/becke_numerical_grid/extra_grid_vector.irp.f b/src/becke_numerical_grid/extra_grid_vector.irp.f
index 16a52dc6..44fc4435 100644
--- a/src/becke_numerical_grid/extra_grid_vector.irp.f
+++ b/src/becke_numerical_grid/extra_grid_vector.irp.f
@@ -71,16 +71,16 @@ END_PROVIDER
index_final_points_extra(3,i_count) = j
index_final_points_extra_reverse(k,i,j) = i_count
- if(final_weight_at_r_vector_extra(i_count) .lt. 0.d0) then
- print *, ' !!! WARNING !!!'
- print *, ' negative weight !!!!'
- print *, i_count, final_weight_at_r_vector_extra(i_count)
- if(dabs(final_weight_at_r_vector_extra(i_count)) .lt. 1d-10) then
- final_weight_at_r_vector_extra(i_count) = 0.d0
- else
- stop
- endif
- endif
+! if(final_weight_at_r_vector_extra(i_count) .lt. 0.d0) then
+! print *, ' !!! WARNING !!!'
+! print *, ' negative weight !!!!'
+! print *, i_count, final_weight_at_r_vector_extra(i_count)
+! if(dabs(final_weight_at_r_vector_extra(i_count)) .lt. 1d-10) then
+! final_weight_at_r_vector_extra(i_count) = 0.d0
+! else
+! stop
+! endif
+! endif
enddo
enddo
enddo
diff --git a/src/becke_numerical_grid/grid_becke_vector.irp.f b/src/becke_numerical_grid/grid_becke_vector.irp.f
index c35918c3..7097dbb3 100644
--- a/src/becke_numerical_grid/grid_becke_vector.irp.f
+++ b/src/becke_numerical_grid/grid_becke_vector.irp.f
@@ -68,16 +68,16 @@ END_PROVIDER
index_final_points(3,i_count) = j
index_final_points_reverse(k,i,j) = i_count
- if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
- print *, ' !!! WARNING !!!'
- print *, ' negative weight !!!!'
- print *, i_count, final_weight_at_r_vector(i_count)
- if(dabs(final_weight_at_r_vector(i_count)) .lt. 1d-10) then
- final_weight_at_r_vector(i_count) = 0.d0
- else
- stop
- endif
- endif
+! if(final_weight_at_r_vector(i_count) .lt. 0.d0) then
+! print *, ' !!! WARNING !!!'
+! print *, ' negative weight !!!!'
+! print *, i_count, final_weight_at_r_vector(i_count)
+! if(dabs(final_weight_at_r_vector(i_count)) .lt. 1d-10) then
+! final_weight_at_r_vector(i_count) = 0.d0
+! else
+! stop
+! endif
+! endif
enddo
enddo
enddo
diff --git a/src/scf_utils/roothaan_hall_scf.irp.f b/src/scf_utils/roothaan_hall_scf.irp.f
index 3f5c8549..e0fe5319 100644
--- a/src/scf_utils/roothaan_hall_scf.irp.f
+++ b/src/scf_utils/roothaan_hall_scf.irp.f
@@ -217,7 +217,7 @@ END_DOC
do while (i
Date: Mon, 6 May 2024 17:47:48 +0200
Subject: [PATCH 121/140] updated get_fci_tc_conv.sh
---
scripts/get_fci_tc_conv.sh | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scripts/get_fci_tc_conv.sh b/scripts/get_fci_tc_conv.sh
index 643f3ac0..f0c99baf 100755
--- a/scripts/get_fci_tc_conv.sh
+++ b/scripts/get_fci_tc_conv.sh
@@ -1,2 +1,2 @@
file=$1
-grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
+grep "Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
From b14325fef482bdf6cb471b40edf8fa46f2aeac65 Mon Sep 17 00:00:00 2001
From: Anthony Scemama
Date: Mon, 6 May 2024 18:21:58 +0200
Subject: [PATCH 122/140] Introducing qmckl
---
plugins/local/non_h_ints_mu/NEED | 1 +
plugins/local/non_h_ints_mu/deb_aos.irp.f | 49 ++++++++--
plugins/local/non_h_ints_mu/qmckl.irp.f | 104 ++++++++++++++++++++++
3 files changed, 148 insertions(+), 6 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/NEED b/plugins/local/non_h_ints_mu/NEED
index 48c1c24b..5ca1d543 100644
--- a/plugins/local/non_h_ints_mu/NEED
+++ b/plugins/local/non_h_ints_mu/NEED
@@ -3,3 +3,4 @@ hamiltonian
jastrow
ao_tc_eff_map
bi_ortho_mos
+trexio
diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f
index c9bc9c9a..86d011fb 100644
--- a/plugins/local/non_h_ints_mu/deb_aos.irp.f
+++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f
@@ -34,21 +34,58 @@ subroutine print_aos()
PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array
- do ipoint = 1, n_points_final_grid
- r(:) = final_grid_points(:,ipoint)
- print*, r
- enddo
+! do ipoint = 1, n_points_final_grid
+! r(:) = final_grid_points(:,ipoint)
+! print*, r
+! enddo
+double precision :: accu_vgl(5)
+double precision :: accu_vgl_nrm(5)
do ipoint = 1, n_points_final_grid
- r(:) = final_grid_points(:,ipoint)
do i = 1, ao_num
ao_val = aos_in_r_array (i,ipoint)
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
- write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ write(111, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
enddo
enddo
+ do ipoint = 1, n_points_final_grid
+ do i = 1, ao_num
+ ao_val = aos_in_r_array_qmckl (i,ipoint)
+ ao_der(:) = aos_grad_in_r_array_qmckl(i,ipoint,:)
+ ao_lap = aos_lapl_in_r_array_qmckl(i,ipoint)
+ write(222, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ enddo
+ enddo
+
+ accu_vgl = 0.d0
+ accu_vgl_nrm = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do i = 1, ao_num
+ ao_val = aos_in_r_array (i,ipoint)
+ ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
+ ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
+ accu_vgl_nrm(1) += dabs(ao_val)
+ accu_vgl_nrm(2) += dabs(ao_der(1))
+ accu_vgl_nrm(3) += dabs(ao_der(2))
+ accu_vgl_nrm(4) += dabs(ao_der(3))
+ accu_vgl_nrm(5) += dabs(ao_lap)
+
+ ao_val -= aos_in_r_array_qmckl (i,ipoint)
+ ao_der(:) -= aos_grad_in_r_array_qmckl(i,ipoint,:)
+ ao_lap -= aos_lapl_in_r_array_qmckl(i,ipoint)
+ accu_vgl(1) += dabs(ao_val)
+ accu_vgl(2) += dabs(ao_der(1))
+ accu_vgl(3) += dabs(ao_der(2))
+ accu_vgl(4) += dabs(ao_der(3))
+ accu_vgl(5) += dabs(ao_lap)
+ enddo
+
+ enddo
+ accu_vgl(:) *= 1.d0 / accu_vgl_nrm(:)
+ print *, accu_vgl
+
return
end
diff --git a/plugins/local/non_h_ints_mu/qmckl.irp.f b/plugins/local/non_h_ints_mu/qmckl.irp.f
index 1df80457..4d419e24 100644
--- a/plugins/local/non_h_ints_mu/qmckl.irp.f
+++ b/plugins/local/non_h_ints_mu/qmckl.irp.f
@@ -75,3 +75,107 @@ BEGIN_PROVIDER [ integer*8, qmckl_ctx_jastrow ]
endif
END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, aos_in_r_array_qmckl, (ao_num,n_points_final_grid)]
+&BEGIN_PROVIDER [ double precision, aos_grad_in_r_array_qmckl, (ao_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [ double precision, aos_lapl_in_r_array_qmckl, (ao_num, n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! AOS computed with qmckl
+ END_DOC
+ use qmckl
+
+ integer*8 :: qmckl_ctx
+ integer(qmckl_exit_code) :: rc
+
+ qmckl_ctx = qmckl_context_create()
+
+ rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in read_trexio'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in set_electron_point'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ double precision, allocatable :: vgl(:,:,:)
+ allocate( vgl(ao_num,5,n_points_final_grid))
+ rc = qmckl_get_ao_basis_ao_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*ao_num*5_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in get_ao_vgl'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ integer :: i,k
+ do k=1,n_points_final_grid
+ do i=1,ao_num
+ aos_in_r_array_qmckl(i,k) = vgl(i,1,k)
+ aos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
+ aos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
+ aos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
+ aos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
+ enddo
+ enddo
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, mos_in_r_array_qmckl, (mo_num,n_points_final_grid)]
+&BEGIN_PROVIDER [ double precision, mos_grad_in_r_array_qmckl, (mo_num,n_points_final_grid,3)]
+&BEGIN_PROVIDER [ double precision, mos_lapl_in_r_array_qmckl, (mo_num, n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! moS computed with qmckl
+ END_DOC
+ use qmckl
+
+ integer*8 :: qmckl_ctx
+ integer(qmckl_exit_code) :: rc
+
+ qmckl_ctx = qmckl_context_create()
+
+ rc = qmckl_trexio_read(qmckl_ctx, trexio_file, 1_8*len(trim(trexio_filename)))
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in read_trexio'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ rc = qmckl_set_point(qmckl_ctx, 'N', n_points_final_grid*1_8, final_grid_points, n_points_final_grid*3_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in set_electron_point'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ double precision, allocatable :: vgl(:,:,:)
+ allocate( vgl(mo_num,5,n_points_final_grid))
+ rc = qmckl_get_mo_basis_mo_vgl_inplace(qmckl_ctx, vgl, n_points_final_grid*mo_num*5_8)
+ if (rc /= QMCKL_SUCCESS) then
+ print *, irp_here, 'qmckl error in get_mo_vgl'
+ rc = qmckl_check(qmckl_ctx, rc)
+ stop -1
+ endif
+
+ integer :: i,k
+ do k=1,n_points_final_grid
+ do i=1,mo_num
+ mos_in_r_array_qmckl(i,k) = vgl(i,1,k)
+ mos_grad_in_r_array_qmckl(i,k,1) = vgl(i,2,k)
+ mos_grad_in_r_array_qmckl(i,k,2) = vgl(i,3,k)
+ mos_grad_in_r_array_qmckl(i,k,3) = vgl(i,4,k)
+ mos_lapl_in_r_array_qmckl(i,k) = vgl(i,5,k)
+ enddo
+ enddo
+
+END_PROVIDER
+
+
From 109a956f0d947665af7fbd3ed02d3569c49e592e Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 6 May 2024 18:30:05 +0200
Subject: [PATCH 123/140] does not compile but working on it
---
plugins/local/slater_tc/h_mat_triple.irp.f | 391 ------------------
.../local/slater_tc/slater_tc_opt_diag.irp.f | 311 +++++++++++++-
.../slater_tc/symmetrized_3_e_int_prov.irp.f | 140 -------
plugins/local/slater_tc_no_opt/.gitignore | 59 +++
plugins/local/slater_tc_no_opt/NEED | 8 +
plugins/local/slater_tc_no_opt/README.rst | 4 +
.../h_biortho.irp.f | 0
.../local/slater_tc_no_opt/h_mat_triple.irp.f | 193 +++++++++
.../h_tc_bi_ortho_psi.irp.f | 0
.../slater_tc_3e_slow.irp.f | 2 +-
.../slater_tc_no_opt.irp.f} | 2 +-
.../slater_tc_slow.irp.f | 73 +---
src/determinants/slater_rules_general.irp.f | 192 +++++++++
13 files changed, 769 insertions(+), 606 deletions(-)
delete mode 100644 plugins/local/slater_tc/h_mat_triple.irp.f
delete mode 100644 plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f
create mode 100644 plugins/local/slater_tc_no_opt/.gitignore
create mode 100644 plugins/local/slater_tc_no_opt/NEED
create mode 100644 plugins/local/slater_tc_no_opt/README.rst
rename plugins/local/{slater_tc => slater_tc_no_opt}/h_biortho.irp.f (100%)
create mode 100644 plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
rename plugins/local/{slater_tc => slater_tc_no_opt}/h_tc_bi_ortho_psi.irp.f (100%)
rename plugins/local/{slater_tc => slater_tc_no_opt}/slater_tc_3e_slow.irp.f (99%)
rename plugins/local/{slater_tc/slater_tc.irp.f => slater_tc_no_opt/slater_tc_no_opt.irp.f} (82%)
rename plugins/local/{slater_tc => slater_tc_no_opt}/slater_tc_slow.irp.f (80%)
create mode 100644 src/determinants/slater_rules_general.irp.f
diff --git a/plugins/local/slater_tc/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f
deleted file mode 100644
index 6f5697a2..00000000
--- a/plugins/local/slater_tc/h_mat_triple.irp.f
+++ /dev/null
@@ -1,391 +0,0 @@
-subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
- use bitmasks
- BEGIN_DOC
-! returns the array, for each spin, of holes/particles between key_i and key_j
-!
-! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
- END_DOC
- include 'utils/constants.include.F'
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
- double precision, intent(out) :: phase
- integer :: ispin,k,i,pos
- integer(bit_kind) :: key_hole, key_particle
- integer(bit_kind) :: xorvec(N_int_max,2)
- holes_array = -1
- particles_array = -1
- degree_array = 0
- do i = 1, N_int
- xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
- xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
- degree_array(1) += popcnt(xorvec(i,1))
- degree_array(2) += popcnt(xorvec(i,2))
- enddo
- degree_array(1) = shiftr(degree_array(1),1)
- degree_array(2) = shiftr(degree_array(2),1)
-
- do ispin = 1, 2
- k = 1
- !!! GETTING THE HOLES
- do i = 1, N_int
- key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- do ispin = 1, 2
- k = 1
- !!! GETTING THE PARTICLES
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general '
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- integer :: h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree_array(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
-subroutine get_holes_general(key_i, key_j,Nint, holes_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of holes between key_i and key_j
-!
-! with the following convention: a_{hole}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2)
- integer(bit_kind) :: key_hole
- integer :: ispin,k,i,pos
- holes_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_particles_general(key_i, key_j,Nint,particles_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of particles between key_i and key_j
-!
-! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: particles_array(100,2)
- integer(bit_kind) :: key_particle
- integer :: ispin,k,i,pos
- particles_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'Those are the two determinants'
- call debug_det(key_i, N_int)
- call debug_det(key_j, N_int)
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
- implicit none
- integer, intent(in) :: degree(2), Nint
- integer(bit_kind), intent(in) :: key_i(Nint,2)
- integer, intent(in) :: holes_array(100,2),particles_array(100,2)
- double precision, intent(out) :: phase
- integer :: i,ispin,h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
-subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
- BEGIN_DOC
- ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
- !
- ! Assumes that the determinants are in psi_det
- !
- ! istart, iend, ishift, istep are used in ZMQ parallelization.
- END_DOC
-
- use bitmasks
- implicit none
-
- integer, intent(in) :: N_st,sze
- double precision, intent(in) :: u_0(sze,N_st)
- double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
- call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
- integer :: i,j,degree,ist
- double precision :: hmono, htwoe, hthree, htot
- 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 .ne. 3)cycle
- call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
- do ist = 1, N_st
- v_0(i,ist) += htot * u_0(j,ist)
- enddo
- enddo
- enddo
-end
-
-subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
- BEGIN_DOC
- ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
- !
- ! Assumes that the determinants are in psi_det
- !
- ! istart, iend, ishift, istep are used in ZMQ parallelization.
- END_DOC
-
- use bitmasks
- implicit none
-
- integer, intent(in) :: N_st,sze
- double precision, intent(in) :: u_0(sze,N_st)
- double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
- call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
- integer :: i,j,degree,ist
- double precision :: hmono, htwoe, hthree, htot
- !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
- !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
- !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
- 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 .ne. 3)cycle
- call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
- do ist = 1, N_st
- v_0(i,ist) += htot * u_0(j,ist)
- enddo
- enddo
- enddo
- !$OMP END PARALLEL DO
-end
-
-! ---
-
-subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
- BEGIN_DOC
- ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
- !
- ! Assumes that the determinants are in psi_det
- !
- ! istart, iend, ishift, istep are used in ZMQ parallelization.
- END_DOC
-
- use bitmasks
- implicit none
-
- integer, intent(in) :: N_st,sze
- double precision, intent(in) :: u_0(sze,N_st)
- double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
- call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
- integer :: i,j,degree,ist
- double precision :: hmono, htwoe, hthree, htot
- 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 .ne. 3)cycle
- call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
- do ist = 1, N_st
- v_0(i,ist) += htot * u_0(j,ist)
- enddo
- enddo
- enddo
-end
-
-subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
- BEGIN_DOC
- ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
- !
- ! Assumes that the determinants are in psi_det
- !
- ! istart, iend, ishift, istep are used in ZMQ parallelization.
- END_DOC
-
- use bitmasks
- implicit none
-
- integer, intent(in) :: N_st,sze
- double precision, intent(in) :: u_0(sze,N_st)
- double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
- call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
- integer :: i,j,degree,ist
- double precision :: hmono, htwoe, hthree, htot
- !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
- !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
- !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
- 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 .ne. 3)cycle
- call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
- do ist = 1, N_st
- v_0(i,ist) += htot * u_0(j,ist)
- enddo
- enddo
- enddo
- !$OMP END PARALLEL DO
-end
-
-! ---
-subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
- use bitmasks
- BEGIN_DOC
-! for triple excitation
-!!
-!! WARNING !!
-!
-! Genuine triple excitations of the same spin are not yet implemented
- END_DOC
- implicit none
- integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2)
- integer, intent(in) :: Nint
- double precision, intent(out) :: hmono, htwoe, hthree, htot
- integer :: degree
- integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3
- integer :: holes_array(100,2),particles_array(100,2),degree_array(2)
- double precision :: phase,sym_3_e_int_from_6_idx_tensor
-
- hmono = 0.d0
- htwoe = 0.d0
- hthree = 0.d0
- htot = 0.d0
- call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase)
- degree = degree_array(1) + degree_array(2)
- if(degree .ne. 3)return
- if(degree_array(1)==3.or.degree_array(2)==3)then
- if(degree_array(1) == 3)then
- h1 = holes_array(1,1)
- h2 = holes_array(2,1)
- h3 = holes_array(3,1)
- p1 = particles_array(1,1)
- p2 = particles_array(2,1)
- p3 = particles_array(3,1)
- else
- h1 = holes_array(1,2)
- h2 = holes_array(2,2)
- h3 = holes_array(3,2)
- p1 = particles_array(1,2)
- p2 = particles_array(2,2)
- p3 = particles_array(3,2)
- endif
- hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1)
- else
- if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta
- h1 = holes_array(1,1)
- h2 = holes_array(2,1)
- h3 = holes_array(1,2)
- p1 = particles_array(1,1)
- p2 = particles_array(2,1)
- p3 = particles_array(1,2)
- else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha
- h1 = holes_array(1,2)
- h2 = holes_array(2,2)
- h3 = holes_array(1,1)
- p1 = particles_array(1,2)
- p2 = particles_array(2,2)
- p3 = particles_array(1,1)
- else
- print*,'PB !!'
- stop
- endif
- hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2)
- endif
- hthree *= phase
- htot = hthree
- end
-
diff --git a/plugins/local/slater_tc/slater_tc_opt_diag.irp.f b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
index 78f9dc66..3c5a5d12 100644
--- a/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_diag.irp.f
@@ -19,13 +19,13 @@
PROVIDE HF_bitmask
PROVIDE mo_l_coef mo_r_coef
- call diag_htilde_mu_mat_bi_ortho_slow(N_int, HF_bitmask, hmono, htwoe, htot)
+ call diag_htc_bi_orth_2e_brute(N_int, HF_bitmask, hmono, htwoe, htot)
ref_tc_energy_1e = hmono
ref_tc_energy_2e = htwoe
if(three_body_h_tc) then
- call diag_htilde_three_body_ints_bi_ort_slow(N_int, HF_bitmask, hthree)
+ call diag_htc_bi_orth_3e_brute(N_int, HF_bitmask, hthree)
ref_tc_energy_3e = hthree
else
ref_tc_energy_3e = 0.d0
@@ -524,3 +524,310 @@ end
! ---
+subroutine diag_htc_bi_orth_2e_brute(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_bi_ortho_tc_two_e
+
+ hmono = 0.d0
+ htwoe = 0.d0
+ htot = 0.d0
+
+ call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+ do ispin = 1, 2
+ do i = 1, Ne(ispin)
+ ii = occ(i,ispin)
+ hmono += mo_bi_ortho_tc_one_e(ii,ii)
+ 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 diag_htc_bi_orth_3e_brute(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, ref
+ double precision, external :: sym_3_e_int_from_6_idx_tensor
+ double precision, external :: three_e_diag_parrallel_spin
+
+ PROVIDE mo_l_coef mo_r_coef
+
+ 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_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)
+ 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
+ !hthree += 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
+ !hthree += 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
+
+
+
+BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
+ !
+ ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements
+ !
+ ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
+ !
+ END_DOC
+
+ implicit none
+ integer :: i, j, m
+ double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
+
+ three_e_diag_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
+
+ integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
+ call wall_time(wall0)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,m,integral) &
+ !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do m = j, mo_num
+ three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
+ 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_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
+ enddo
+ enddo
+ enddo
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
+ !
+ ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements
+ !
+ ! 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
+
+ implicit none
+ integer :: i, j, k, m
+ double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
+
+ three_e_single_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_single_parrallel_spin_prov ...'
+
+ integral = three_e_single_parrallel_spin(1,1,1,1)
+ call wall_time(wall0)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,k,m,integral) &
+ !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
+ !$OMP DO SCHEDULE (dynamic)
+ do i = 1, mo_num
+ do k = 1, mo_num
+ do j = 1, mo_num
+ do m = 1, mo_num
+ three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
+
+! ---
+
+BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
+
+ BEGIN_DOC
+ !
+ ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
+ !
+ ! three_e_double_parrallel_spin_prov(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
+
+ implicit none
+ integer :: i, j, k, m, l
+ double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
+
+ three_e_double_parrallel_spin_prov = 0.d0
+ print *, ' Providing the three_e_double_parrallel_spin_prov ...'
+ call wall_time(wall0)
+
+ integral = three_e_double_parrallel_spin(1,1,1,1,1)
+ !$OMP PARALLEL &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (i,j,k,m,l,integral) &
+ !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
+ !$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
+ three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ !$OMP END DO
+ !$OMP END PARALLEL
+
+ call wall_time(wall1)
+ print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
+
+END_PROVIDER
+
diff --git a/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f b/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f
deleted file mode 100644
index e8277a74..00000000
--- a/plugins/local/slater_tc/symmetrized_3_e_int_prov.irp.f
+++ /dev/null
@@ -1,140 +0,0 @@
-
-BEGIN_PROVIDER [ double precision, three_e_diag_parrallel_spin_prov, (mo_num, mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! matrix element of the -L three-body operator ON A BI ORTHONORMAL BASIS
- !
- ! three_e_diag_parrallel_spin_prov(m,j,i) = All combinations of the form for same spin matrix elements
- !
- ! notice the -1 sign: in this way three_e_diag_parrallel_spin_prov can be directly used to compute Slater rules with a + sign
- !
- END_DOC
-
- implicit none
- integer :: i, j, m
- double precision :: integral, wall1, wall0, three_e_diag_parrallel_spin
-
- three_e_diag_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_diag_parrallel_spin_prov ...'
-
- integral = three_e_diag_parrallel_spin(1,1,1) ! to provide all stuffs
- call wall_time(wall0)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,m,integral) &
- !$OMP SHARED (mo_num,three_e_diag_parrallel_spin_prov)
- !$OMP DO SCHEDULE (dynamic)
- do i = 1, mo_num
- do j = 1, mo_num
- do m = j, mo_num
- three_e_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin(m,j,i)
- 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_diag_parrallel_spin_prov(m,j,i) = three_e_diag_parrallel_spin_prov(j,m,i)
- enddo
- enddo
- enddo
-
- call wall_time(wall1)
- print *, ' wall time for three_e_diag_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
-BEGIN_PROVIDER [ double precision, three_e_single_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF SINGLE EXCITATIONS AND BI ORTHO MOs
- !
- ! three_e_single_parrallel_spin_prov(m,j,k,i) = All combination of for same spin matrix elements
- !
- ! 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
-
- implicit none
- integer :: i, j, k, m
- double precision :: integral, wall1, wall0, three_e_single_parrallel_spin
-
- three_e_single_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_single_parrallel_spin_prov ...'
-
- integral = three_e_single_parrallel_spin(1,1,1,1)
- call wall_time(wall0)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,k,m,integral) &
- !$OMP SHARED (mo_num,three_e_single_parrallel_spin_prov)
- !$OMP DO SCHEDULE (dynamic)
- do i = 1, mo_num
- do k = 1, mo_num
- do j = 1, mo_num
- do m = 1, mo_num
- three_e_single_parrallel_spin_prov(m,j,k,i) = three_e_single_parrallel_spin(m,j,k,i)
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call wall_time(wall1)
- print *, ' wall time for three_e_single_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
-
-! ---
-
-BEGIN_PROVIDER [ double precision, three_e_double_parrallel_spin_prov, (mo_num, mo_num, mo_num, mo_num, mo_num)]
-
- BEGIN_DOC
- !
- ! matrix element of the -L three-body operator FOR THE DIRECT TERMS OF DOUBLE EXCITATIONS AND BI ORTHO MOs
- !
- ! three_e_double_parrallel_spin_prov(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
-
- implicit none
- integer :: i, j, k, m, l
- double precision :: integral, wall1, wall0, three_e_double_parrallel_spin
-
- three_e_double_parrallel_spin_prov = 0.d0
- print *, ' Providing the three_e_double_parrallel_spin_prov ...'
- call wall_time(wall0)
-
- integral = three_e_double_parrallel_spin(1,1,1,1,1)
- !$OMP PARALLEL &
- !$OMP DEFAULT (NONE) &
- !$OMP PRIVATE (i,j,k,m,l,integral) &
- !$OMP SHARED (mo_num,three_e_double_parrallel_spin_prov)
- !$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
- three_e_double_parrallel_spin_prov(m,l,j,k,i) = three_e_double_parrallel_spin(m,l,j,k,i)
- enddo
- enddo
- enddo
- enddo
- enddo
- !$OMP END DO
- !$OMP END PARALLEL
-
- call wall_time(wall1)
- print *, ' wall time for three_e_double_parrallel_spin_prov', wall1 - wall0
-
-END_PROVIDER
-
diff --git a/plugins/local/slater_tc_no_opt/.gitignore b/plugins/local/slater_tc_no_opt/.gitignore
new file mode 100644
index 00000000..1561915b
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/.gitignore
@@ -0,0 +1,59 @@
+IRPF90_temp/
+IRPF90_man/
+build.ninja
+irpf90.make
+ezfio_interface.irp.f
+irpf90_entities
+tags
+Makefile
+ao_basis
+ao_one_e_ints
+ao_two_e_erf_ints
+ao_two_e_ints
+aux_quantities
+becke_numerical_grid
+bitmask
+cis
+cisd
+cipsi
+davidson
+davidson_dressed
+davidson_undressed
+density_for_dft
+determinants
+dft_keywords
+dft_utils_in_r
+dft_utils_one_e
+dft_utils_two_body
+dressing
+dummy
+electrons
+ezfio_files
+fci
+generators_cas
+generators_full
+hartree_fock
+iterations
+kohn_sham
+kohn_sham_rs
+mo_basis
+mo_guess
+mo_one_e_ints
+mo_two_e_erf_ints
+mo_two_e_ints
+mpi
+mrpt_utils
+nuclei
+perturbation
+pseudo
+psiref_cas
+psiref_utils
+scf_utils
+selectors_cassd
+selectors_full
+selectors_utils
+single_ref_method
+slave
+tools
+utils
+zmq
diff --git a/plugins/local/slater_tc_no_opt/NEED b/plugins/local/slater_tc_no_opt/NEED
new file mode 100644
index 00000000..a8669866
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/NEED
@@ -0,0 +1,8 @@
+determinants
+normal_order_old
+bi_ort_ints
+bi_ortho_mos
+tc_keywords
+non_hermit_dav
+dav_general_mat
+tc_scf
diff --git a/plugins/local/slater_tc_no_opt/README.rst b/plugins/local/slater_tc_no_opt/README.rst
new file mode 100644
index 00000000..90679e4c
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/README.rst
@@ -0,0 +1,4 @@
+================
+slater_tc_no_opt
+================
+
diff --git a/plugins/local/slater_tc/h_biortho.irp.f b/plugins/local/slater_tc_no_opt/h_biortho.irp.f
similarity index 100%
rename from plugins/local/slater_tc/h_biortho.irp.f
rename to plugins/local/slater_tc_no_opt/h_biortho.irp.f
diff --git a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
new file mode 100644
index 00000000..e2c8f982
--- /dev/null
+++ b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
@@ -0,0 +1,193 @@
+subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, for each spin, of holes/particles between key_i and key_j
+!
+! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
+ END_DOC
+ include 'utils/constants.include.F'
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
+ double precision, intent(out) :: phase
+ integer :: ispin,k,i,pos
+ integer(bit_kind) :: key_hole, key_particle
+ integer(bit_kind) :: xorvec(N_int_max,2)
+ holes_array = -1
+ particles_array = -1
+ degree_array = 0
+ do i = 1, N_int
+ xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
+ xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
+ degree_array(1) += popcnt(xorvec(i,1))
+ degree_array(2) += popcnt(xorvec(i,2))
+ enddo
+ degree_array(1) = shiftr(degree_array(1),1)
+ degree_array(2) = shiftr(degree_array(2),1)
+
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE HOLES
+ do i = 1, N_int
+ key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE PARTICLES
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general '
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ integer :: h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree_array(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
+
+subroutine get_holes_general(key_i, key_j,Nint, holes_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of holes between key_i and key_j
+!
+! with the following convention: a_{hole}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2)
+ integer(bit_kind) :: key_hole
+ integer :: ispin,k,i,pos
+ holes_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_particles_general(key_i, key_j,Nint,particles_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of particles between key_i and key_j
+!
+! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: particles_array(100,2)
+ integer(bit_kind) :: key_particle
+ integer :: ispin,k,i,pos
+ particles_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'Those are the two determinants'
+ call debug_det(key_i, N_int)
+ call debug_det(key_j, N_int)
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
+ implicit none
+ integer, intent(in) :: degree(2), Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ integer, intent(in) :: holes_array(100,2),particles_array(100,2)
+ double precision, intent(out) :: phase
+ integer :: i,ispin,h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
+
diff --git a/plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f b/plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f
similarity index 100%
rename from plugins/local/slater_tc/h_tc_bi_ortho_psi.irp.f
rename to plugins/local/slater_tc_no_opt/h_tc_bi_ortho_psi.irp.f
diff --git a/plugins/local/slater_tc/slater_tc_3e_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
similarity index 99%
rename from plugins/local/slater_tc/slater_tc_3e_slow.irp.f
rename to plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
index cb33d343..f7919653 100644
--- a/plugins/local/slater_tc/slater_tc_3e_slow.irp.f
+++ b/plugins/local/slater_tc_no_opt/slater_tc_3e_slow.irp.f
@@ -1,7 +1,7 @@
! ---
-subroutine diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
+subroutine diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
BEGIN_DOC
! diagonal element of htilde ONLY FOR THREE-BODY TERMS WITH BI ORTHONORMAL ORBITALS
diff --git a/plugins/local/slater_tc/slater_tc.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
similarity index 82%
rename from plugins/local/slater_tc/slater_tc.irp.f
rename to plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
index 27ab47c5..0fcc587f 100644
--- a/plugins/local/slater_tc/slater_tc.irp.f
+++ b/plugins/local/slater_tc_no_opt/slater_tc_no_opt.irp.f
@@ -1,4 +1,4 @@
-program slater_tc
+program slater_tc_no_opt
implicit none
BEGIN_DOC
! TODO : Put the documentation of the program here
diff --git a/plugins/local/slater_tc/slater_tc_slow.irp.f b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
similarity index 80%
rename from plugins/local/slater_tc/slater_tc_slow.irp.f
rename to plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
index caf7d665..b06fd12f 100644
--- a/plugins/local/slater_tc/slater_tc_slow.irp.f
+++ b/plugins/local/slater_tc_no_opt/slater_tc_slow.irp.f
@@ -61,7 +61,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
if(degree.gt.2) return
if(degree == 0) then
- call diag_htilde_mu_mat_bi_ortho_slow(Nint, key_i, hmono, htwoe, htot)
+ call diag_htc_bi_orth_2e_brute(Nint, key_i, hmono, htwoe, htot)
else if (degree == 1) then
call single_htilde_mu_mat_bi_ortho_slow(Nint, key_j, key_i, hmono, htwoe, htot)
else if(degree == 2) then
@@ -76,7 +76,7 @@ subroutine htilde_mu_mat_bi_ortho_slow(key_j, key_i, Nint, hmono, htwoe, hthree,
else if((degree == 1) .and. (elec_num .gt. 2) .and. three_e_4_idx_term) then
call single_htilde_three_body_ints_bi_ort_slow(Nint, key_j, key_i, hthree)
else if((degree == 0) .and. (elec_num .gt. 2) .and. three_e_3_idx_term) then
- call diag_htilde_three_body_ints_bi_ort_slow(Nint, key_i, hthree)
+ call diag_htc_bi_orth_3e_brute(Nint, key_i, hthree)
endif
endif
@@ -95,75 +95,6 @@ end
! ---
-subroutine diag_htilde_mu_mat_bi_ortho_slow(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_bi_ortho_tc_two_e
-
- hmono = 0.d0
- htwoe = 0.d0
- htot = 0.d0
-
- call bitstring_to_list_ab(key_i, occ, Ne, Nint)
-
- do ispin = 1, 2
- do i = 1, Ne(ispin)
- ii = occ(i,ispin)
- hmono += mo_bi_ortho_tc_one_e(ii,ii)
- 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_slow(Nint, key_j, key_i, hmono, htwoe, htot)
BEGIN_DOC
diff --git a/src/determinants/slater_rules_general.irp.f b/src/determinants/slater_rules_general.irp.f
new file mode 100644
index 00000000..e987c846
--- /dev/null
+++ b/src/determinants/slater_rules_general.irp.f
@@ -0,0 +1,192 @@
+subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, for each spin, of holes/particles between key_i and key_j
+!
+! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
+ END_DOC
+ include 'utils/constants.include.F'
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
+ double precision, intent(out) :: phase
+ integer :: ispin,k,i,pos
+ integer(bit_kind) :: key_hole, key_particle
+ integer(bit_kind) :: xorvec(N_int_max,2)
+ holes_array = -1
+ particles_array = -1
+ degree_array = 0
+ do i = 1, N_int
+ xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
+ xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
+ degree_array(1) += popcnt(xorvec(i,1))
+ degree_array(2) += popcnt(xorvec(i,2))
+ enddo
+ degree_array(1) = shiftr(degree_array(1),1)
+ degree_array(2) = shiftr(degree_array(2),1)
+
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE HOLES
+ do i = 1, N_int
+ key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ do ispin = 1, 2
+ k = 1
+ !!! GETTING THE PARTICLES
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_excitation_general '
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+ integer :: h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree_array(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
+
+subroutine get_holes_general(key_i, key_j,Nint, holes_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of holes between key_i and key_j
+!
+! with the following convention: a_{hole}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: holes_array(100,2)
+ integer(bit_kind) :: key_hole
+ integer :: ispin,k,i,pos
+ holes_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
+ do while(key_hole .ne.0_bit_kind)
+ pos = trailz(key_hole)
+ holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_hole = ibclr(key_hole,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_particles_general(key_i, key_j,Nint,particles_array)
+ use bitmasks
+ BEGIN_DOC
+! returns the array, per spin, of particles between key_i and key_j
+!
+! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
+ END_DOC
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
+ integer, intent(out) :: particles_array(100,2)
+ integer(bit_kind) :: key_particle
+ integer :: ispin,k,i,pos
+ particles_array = -1
+ do ispin = 1, 2
+ k = 1
+ do i = 1, N_int
+ key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
+ do while(key_particle .ne.0_bit_kind)
+ pos = trailz(key_particle)
+ particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
+ key_particle = ibclr(key_particle,pos)
+ k += 1
+ if(k .gt.100)then
+ print*,'WARNING in get_holes_general'
+ print*,'More than a 100-th excitation for spin ',ispin
+ print*,'Those are the two determinants'
+ call debug_det(key_i, N_int)
+ call debug_det(key_j, N_int)
+ print*,'stoping ...'
+ stop
+ endif
+ enddo
+ enddo
+ enddo
+end
+
+subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
+ implicit none
+ integer, intent(in) :: degree(2), Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2)
+ integer, intent(in) :: holes_array(100,2),particles_array(100,2)
+ double precision, intent(out) :: phase
+ integer :: i,ispin,h,p, i_ok
+ integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
+ integer :: exc(0:2,2,2)
+ double precision :: phase_tmp
+ allocate(det_i(Nint,2),det_ip(N_int,2))
+ det_i = key_i
+ phase = 1.d0
+ do ispin = 1, 2
+ do i = 1, degree(ispin)
+ h = holes_array(i,ispin)
+ p = particles_array(i,ispin)
+ det_ip = det_i
+ call do_single_excitation(det_ip,h,p,ispin,i_ok)
+ if(i_ok == -1)then
+ print*,'excitation was not possible '
+ stop
+ endif
+ call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
+ phase *= phase_tmp
+ det_i = det_ip
+ enddo
+ enddo
+
+end
From b749796d931401f2c7e966e2c7eeedfff2f4477c Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 6 May 2024 18:33:29 +0200
Subject: [PATCH 124/140] still not compiling
---
.../tc_bi_ortho/dressing_vectors_lr.irp.f | 8 ++++----
.../local/tc_bi_ortho/e_corr_bi_ortho.irp.f | 18 +++++++++---------
plugins/local/tc_bi_ortho/print_tc_wf.irp.f | 6 +++---
.../local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f | 2 +-
plugins/local/tc_bi_ortho/tc_som.irp.f | 4 ++--
plugins/local/tc_bi_ortho/tc_utils.irp.f | 10 +++++-----
.../local/tc_bi_ortho/test_normal_order.irp.f | 8 ++++----
.../local/tc_bi_ortho/test_tc_bi_ortho.irp.f | 10 +++++-----
plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 4 ++--
9 files changed, 35 insertions(+), 35 deletions(-)
diff --git a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
index 0aff9980..135f9d17 100644
--- a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
+++ b/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
@@ -27,7 +27,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
i = 1
j = 1
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
call hmat_bi_ortho (psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
delta = 0.d0
@@ -39,7 +39,7 @@ subroutine get_delta_bitc_right(psidet, psicoef, ndet, Nint, delta)
do j = 1, ndet
! < I |Htilde | J >
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
! < I |H | J >
call hmat_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, h_mono, h_twoe, h_tot)
@@ -78,7 +78,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
i = 1
j = 1
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta = 0.d0
!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
@@ -88,7 +88,7 @@ subroutine get_htc_bitc_right(psidet, psicoef, ndet, Nint, delta)
do j = 1, ndet
! < I |Htilde | J >
- call htilde_mu_mat_bi_ortho_slow(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
+ call htilde_mu_mat_opt_bi_ortho(psidet(1,1,i), psidet(1,1,j), Nint, htc_mono, htc_twoe, htc_three, htc_tot)
delta(i) = delta(i) + psicoef(j) * htc_tot
enddo
diff --git a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
index 6d5c3b21..4abdc25b 100644
--- a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
+++ b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
@@ -2,7 +2,7 @@
BEGIN_PROVIDER [ double precision, e_tilde_00]
implicit none
double precision :: hmono,htwoe,hthree,htot
- call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
+ call htilde_mu_mat_opt_bi_ortho(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,htot)
e_tilde_00 = htot
END_PROVIDER
@@ -18,11 +18,11 @@
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_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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
@@ -37,7 +37,7 @@
BEGIN_PROVIDER [ double precision, e_tilde_bi_orth_00]
implicit none
double precision :: hmono,htwoe,hthree,htilde_ij
- call htilde_mu_mat_bi_ortho_slow(HF_bitmask,HF_bitmask,N_int,hmono,htwoe,hthree,e_tilde_bi_orth_00)
+ call htilde_mu_mat_opt_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
@@ -57,7 +57,7 @@
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_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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)
e_corr_single_bi_orth_abs += dabs(reigvec_tc_bi_orth(i,1) * htilde_ij/reigvec_tc_bi_orth(1,1))
@@ -80,7 +80,7 @@
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_slow(psi_det(1,1,j),psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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
@@ -99,8 +99,8 @@ BEGIN_PROVIDER [ double precision, coef_pt1_bi_ortho, (N_det)]
if(degree==0)then
coef_pt1_bi_ortho(i) = 1.d0
else
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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
diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
index 2b88bc5b..ab5ce371 100644
--- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
@@ -61,12 +61,12 @@ subroutine routine
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_slow(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i),psi_det(1,1,i),N_int,hmono,htwoe,hthree,e_i0)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i),HF_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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
diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
index 4c3c0788..5cbf26d2 100644
--- a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
@@ -14,7 +14,7 @@
call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
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_slow(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
+ call htilde_mu_mat_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
endif
enddo
reigvec_tc_bi_orth_tmp = 0.d0
diff --git a/plugins/local/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_bi_ortho/tc_som.irp.f
index 1d11c81b..6bdcc1f0 100644
--- a/plugins/local/tc_bi_ortho/tc_som.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_som.irp.f
@@ -49,8 +49,8 @@ subroutine main()
U_SOM = 0.d0
do i = 1, N_det
if(i == i_HF) cycle
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i_HF), psi_det(1,1,i), N_int, hmono_1, htwoe_1, hthree_1, htot_1)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,i_HF), N_int, hmono_2, htwoe_2, hthree_2, htot_2)
U_SOM += htot_1 * htot_2
enddo
U_SOM = 0.5d0 * U_SOM
diff --git a/plugins/local/tc_bi_ortho/tc_utils.irp.f b/plugins/local/tc_bi_ortho/tc_utils.irp.f
index 43a6865e..2aa148a3 100644
--- a/plugins/local/tc_bi_ortho/tc_utils.irp.f
+++ b/plugins/local/tc_bi_ortho/tc_utils.irp.f
@@ -25,7 +25,7 @@ subroutine write_tc_energy()
E_2e_tmp(i) = 0.d0
E_3e_tmp(i) = 0.d0
do j = 1, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
E_TC_tmp(i) = E_TC_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htot
E_1e_tmp(i) = E_1e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * hmono
E_2e_tmp(i) = E_2e_tmp(i) + psi_l_coef_bi_ortho(i,1) * psi_r_coef_bi_ortho(j,1) * htwoe
@@ -70,7 +70,7 @@ subroutine write_tc_energy()
E_3e = 0.d0
do i = 1, N_det
do j = 1, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,i), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot)
E_TC = E_TC + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htot
E_1e = E_1e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * hmono
E_2e = E_2e + psi_l_coef_bi_ortho(i,k) * psi_r_coef_bi_ortho(j,k) * htwoe
@@ -109,8 +109,8 @@ subroutine write_tc_var()
SIGMA_TC = 0.d0
do j = 2, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,1), psi_det(1,1,j), N_int, hmono, htwoe, hthree, htot_1j)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot_j1)
SIGMA_TC = SIGMA_TC + htot_1j * htot_j1
enddo
@@ -132,7 +132,7 @@ subroutine write_tc_gs_var_HF()
SIGMA_TC = 0.d0
do j = 2, N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,1), N_int, hmono, htwoe, hthree, htot)
SIGMA_TC = SIGMA_TC + htot * htot
enddo
diff --git a/plugins/local/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f
index 0cf27396..7b4c558f 100644
--- a/plugins/local/tc_bi_ortho/test_normal_order.irp.f
+++ b/plugins/local/tc_bi_ortho/test_normal_order.irp.f
@@ -54,7 +54,7 @@ subroutine test
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,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_tmp *= phase
@@ -66,7 +66,7 @@ subroutine test
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,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_tmp *= phase
@@ -109,7 +109,7 @@ do h1 = 1, elec_alpha_num
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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)
integer :: hh1, pp1, hh2, pp2, ss1, ss2
@@ -145,7 +145,7 @@ do h1 = 1, elec_beta_num
if(i_ok.ne.1)cycle
call do_single_excitation(det_i,h2,p2,s2,i_ok)
if(i_ok.ne.1)cycle
- call htilde_mu_mat_bi_ortho_slow(det_i,ref_bitmask,N_int,hmono,htwoe,hthree,htilde_ij)
+ call htilde_mu_mat_opt_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)
call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
diff --git a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
index 369efd15..559c0200 100644
--- a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
+++ b/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
@@ -88,7 +88,7 @@ subroutine test_slater_tc_opt
i_count = 0.d0
do i = 1, N_det
do j = 1,N_det
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hnewmono, hnewtwoe, hnewthree, hnewtot)
if(dabs(htot).gt.1.d-15)then
i_count += 1.D0
@@ -124,7 +124,7 @@ subroutine timing_tot
do j = 1, N_det
! call get_excitation_degree(psi_det(1,1,j), psi_det(1,1,i),degree,N_int)
i_count += 1.d0
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@@ -171,7 +171,7 @@ subroutine timing_diag
do i = 1, N_det
do j = i,i
i_count += 1.d0
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
enddo
enddo
call wall_time(wall1)
@@ -208,7 +208,7 @@ subroutine timing_single
if(degree.ne.1)cycle
i_count += 1.d0
call wall_time(wall0)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo
@@ -250,7 +250,7 @@ subroutine timing_double
if(degree.ne.2)cycle
i_count += 1.d0
call wall_time(wall0)
- call htilde_mu_mat_bi_ortho_slow(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
+ call htilde_mu_mat_opt_bi_ortho(psi_det(1,1,j), psi_det(1,1,i), N_int, hmono, htwoe, hthree, htot)
call wall_time(wall1)
accu += wall1 - wall0
enddo
diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
index 85f3ed97..b33b2e93 100644
--- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
+++ b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
@@ -64,7 +64,7 @@ subroutine routine_3()
print*, ' excited det'
call debug_det(det_i, N_int)
- call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
if(dabs(hthree).lt.1.d-10)cycle
ref = hthree
if(s1 == 1)then
@@ -130,7 +130,7 @@ subroutine routine_tot()
stop
endif
- call htilde_mu_mat_bi_ortho_slow(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
+ call htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
print*,htilde_ij
! if(dabs(htilde_ij).lt.1.d-10)cycle
print*, ' excited det'
From 366afb2933baba919db1ad85b7eee965ea56d0c6 Mon Sep 17 00:00:00 2001
From: eginer
Date: Mon, 6 May 2024 18:53:20 +0200
Subject: [PATCH 125/140] compiling after some cleaning
---
plugins/local/old_delta_tc_qmc/NEED | 1 +
plugins/local/old_delta_tc_qmc/README.rst | 4 +
.../compute_deltamu_right.irp.f | 0
.../dressing_vectors_lr.irp.f | 0
.../old_delta_tc_qmc/old_delta_tc_qmc.irp.f | 7 +
plugins/local/slater_tc/h_mat_triple.irp.f | 198 ++++++++++++++++++
.../local/slater_tc_no_opt/h_mat_triple.irp.f | 193 -----------------
.../test_tc_bi_ortho.irp.f | 0
plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f | 129 ------------
plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f | 36 ----
.../local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f | 145 -------------
plugins/local/tc_bi_ortho/test_s2_tc.irp.f | 170 ---------------
12 files changed, 210 insertions(+), 673 deletions(-)
create mode 100644 plugins/local/old_delta_tc_qmc/NEED
create mode 100644 plugins/local/old_delta_tc_qmc/README.rst
rename plugins/local/{tc_bi_ortho => old_delta_tc_qmc}/compute_deltamu_right.irp.f (100%)
rename plugins/local/{tc_bi_ortho => old_delta_tc_qmc}/dressing_vectors_lr.irp.f (100%)
create mode 100644 plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
create mode 100644 plugins/local/slater_tc/h_mat_triple.irp.f
delete mode 100644 plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
rename plugins/local/{tc_bi_ortho => slater_tc_no_opt}/test_tc_bi_ortho.irp.f (100%)
delete mode 100644 plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f
delete mode 100644 plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f
delete mode 100644 plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
delete mode 100644 plugins/local/tc_bi_ortho/test_s2_tc.irp.f
diff --git a/plugins/local/old_delta_tc_qmc/NEED b/plugins/local/old_delta_tc_qmc/NEED
new file mode 100644
index 00000000..8b137891
--- /dev/null
+++ b/plugins/local/old_delta_tc_qmc/NEED
@@ -0,0 +1 @@
+
diff --git a/plugins/local/old_delta_tc_qmc/README.rst b/plugins/local/old_delta_tc_qmc/README.rst
new file mode 100644
index 00000000..1d56f96c
--- /dev/null
+++ b/plugins/local/old_delta_tc_qmc/README.rst
@@ -0,0 +1,4 @@
+================
+old_delta_tc_qmc
+================
+
diff --git a/plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f b/plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/compute_deltamu_right.irp.f
rename to plugins/local/old_delta_tc_qmc/compute_deltamu_right.irp.f
diff --git a/plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f b/plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/dressing_vectors_lr.irp.f
rename to plugins/local/old_delta_tc_qmc/dressing_vectors_lr.irp.f
diff --git a/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
new file mode 100644
index 00000000..5ff08bd6
--- /dev/null
+++ b/plugins/local/old_delta_tc_qmc/old_delta_tc_qmc.irp.f
@@ -0,0 +1,7 @@
+program old_delta_tc_qmc
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ print *, 'Hello world'
+end
diff --git a/plugins/local/slater_tc/h_mat_triple.irp.f b/plugins/local/slater_tc/h_mat_triple.irp.f
new file mode 100644
index 00000000..9cb4b60a
--- /dev/null
+++ b/plugins/local/slater_tc/h_mat_triple.irp.f
@@ -0,0 +1,198 @@
+subroutine H_tc_s2_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
+ BEGIN_DOC
+ ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
+ !
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+
+ use bitmasks
+ implicit none
+
+ integer, intent(in) :: N_st,sze
+ double precision, intent(in) :: u_0(sze,N_st)
+ double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
+ call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
+ integer :: i,j,degree,ist
+ double precision :: hmono, htwoe, hthree, htot
+ 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 .ne. 3)cycle
+ call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
+ do ist = 1, N_st
+ v_0(i,ist) += htot * u_0(j,ist)
+ enddo
+ enddo
+ enddo
+end
+
+subroutine H_tc_s2_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
+ BEGIN_DOC
+ ! Computes $v_0 = H^TC | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
+ !
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+
+ use bitmasks
+ implicit none
+
+ integer, intent(in) :: N_st,sze
+ double precision, intent(in) :: u_0(sze,N_st)
+ double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
+ call H_tc_s2_u_0_opt(v_0, s_0, u_0, N_st, sze)
+ integer :: i,j,degree,ist
+ double precision :: hmono, htwoe, hthree, htot
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
+ !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
+ !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
+ 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 .ne. 3)cycle
+ call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,i), psi_det(1,1,j), hmono, htwoe, hthree, htot)
+ do ist = 1, N_st
+ v_0(i,ist) += htot * u_0(j,ist)
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+end
+
+! ---
+
+subroutine H_tc_s2_dagger_u_0_with_pure_three(v_0, s_0, u_0, N_st, sze)
+ BEGIN_DOC
+ ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
+ !
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+
+ use bitmasks
+ implicit none
+
+ integer, intent(in) :: N_st,sze
+ double precision, intent(in) :: u_0(sze,N_st)
+ double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
+ call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
+ integer :: i,j,degree,ist
+ double precision :: hmono, htwoe, hthree, htot
+ 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 .ne. 3)cycle
+ call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
+ do ist = 1, N_st
+ v_0(i,ist) += htot * u_0(j,ist)
+ enddo
+ enddo
+ enddo
+end
+
+subroutine H_tc_s2_dagger_u_0_with_pure_three_omp(v_0, s_0, u_0, N_st, sze)
+ BEGIN_DOC
+ ! Computes $v_0 = (H^TC)^dagger | u_0\rangle$ WITH PURE TRIPLE EXCITATION TERMS
+ !
+ ! Assumes that the determinants are in psi_det
+ !
+ ! istart, iend, ishift, istep are used in ZMQ parallelization.
+ END_DOC
+
+ use bitmasks
+ implicit none
+
+ integer, intent(in) :: N_st,sze
+ double precision, intent(in) :: u_0(sze,N_st)
+ double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st)
+ call H_tc_s2_dagger_u_0_opt(v_0, s_0, u_0, N_st, sze)
+ integer :: i,j,degree,ist
+ double precision :: hmono, htwoe, hthree, htot
+ !$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(dynamic,8) &
+ !$OMP SHARED(N_st, N_det, N_int, psi_det, u_0, v_0) &
+ !$OMP PRIVATE(ist, i, j, degree, hmono, htwoe, hthree,htot)
+ 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 .ne. 3)cycle
+ call triple_htilde_mu_mat_fock_bi_ortho(N_int, psi_det(1,1,j), psi_det(1,1,i), hmono, htwoe, hthree, htot)
+ do ist = 1, N_st
+ v_0(i,ist) += htot * u_0(j,ist)
+ enddo
+ enddo
+ enddo
+ !$OMP END PARALLEL DO
+end
+
+! ---
+subroutine triple_htilde_mu_mat_fock_bi_ortho(Nint, key_j, key_i, hmono, htwoe, hthree, htot)
+ use bitmasks
+ BEGIN_DOC
+! for triple excitation
+!!
+!! WARNING !!
+!
+! Genuine triple excitations of the same spin are not yet implemented
+ END_DOC
+ implicit none
+ integer(bit_kind), intent(in) :: key_j(N_int,2),key_i(N_int,2)
+ integer, intent(in) :: Nint
+ double precision, intent(out) :: hmono, htwoe, hthree, htot
+ integer :: degree
+ integer :: h1, p1, h2, p2, s1, s2, h3, p3, s3
+ integer :: holes_array(100,2),particles_array(100,2),degree_array(2)
+ double precision :: phase,sym_3_e_int_from_6_idx_tensor
+
+ hmono = 0.d0
+ htwoe = 0.d0
+ hthree = 0.d0
+ htot = 0.d0
+ call get_excitation_general(key_j, key_i, Nint,degree_array,holes_array, particles_array,phase)
+ degree = degree_array(1) + degree_array(2)
+ if(degree .ne. 3)return
+ if(degree_array(1)==3.or.degree_array(2)==3)then
+ if(degree_array(1) == 3)then
+ h1 = holes_array(1,1)
+ h2 = holes_array(2,1)
+ h3 = holes_array(3,1)
+ p1 = particles_array(1,1)
+ p2 = particles_array(2,1)
+ p3 = particles_array(3,1)
+ else
+ h1 = holes_array(1,2)
+ h2 = holes_array(2,2)
+ h3 = holes_array(3,2)
+ p1 = particles_array(1,2)
+ p2 = particles_array(2,2)
+ p3 = particles_array(3,2)
+ endif
+ hthree = sym_3_e_int_from_6_idx_tensor(p3, p2, p1, h3, h2, h1)
+ else
+ if(degree_array(1) == 2.and.degree_array(2) == 1)then ! double alpha + single beta
+ h1 = holes_array(1,1)
+ h2 = holes_array(2,1)
+ h3 = holes_array(1,2)
+ p1 = particles_array(1,1)
+ p2 = particles_array(2,1)
+ p3 = particles_array(1,2)
+ else if(degree_array(2) == 2 .and. degree_array(1) == 1)then ! double beta + single alpha
+ h1 = holes_array(1,2)
+ h2 = holes_array(2,2)
+ h3 = holes_array(1,1)
+ p1 = particles_array(1,2)
+ p2 = particles_array(2,2)
+ p3 = particles_array(1,1)
+ else
+ print*,'PB !!'
+ stop
+ endif
+ hthree = three_body_ints_bi_ort(p3,p2,p1,h3,h2,h1) - three_body_ints_bi_ort(p3,p2,p1,h3,h1,h2)
+ endif
+ hthree *= phase
+ htot = hthree
+ end
+
diff --git a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f b/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
deleted file mode 100644
index e2c8f982..00000000
--- a/plugins/local/slater_tc_no_opt/h_mat_triple.irp.f
+++ /dev/null
@@ -1,193 +0,0 @@
-subroutine get_excitation_general(key_i,key_j, Nint,degree_array,holes_array, particles_array,phase)
- use bitmasks
- BEGIN_DOC
-! returns the array, for each spin, of holes/particles between key_i and key_j
-!
-! with the following convention: a^+_{particle} a_{hole}|key_i> = |key_j>
- END_DOC
- include 'utils/constants.include.F'
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2),particles_array(100,2),degree_array(2)
- double precision, intent(out) :: phase
- integer :: ispin,k,i,pos
- integer(bit_kind) :: key_hole, key_particle
- integer(bit_kind) :: xorvec(N_int_max,2)
- holes_array = -1
- particles_array = -1
- degree_array = 0
- do i = 1, N_int
- xorvec(i,1) = xor( key_i(i,1), key_j(i,1))
- xorvec(i,2) = xor( key_i(i,2), key_j(i,2))
- degree_array(1) += popcnt(xorvec(i,1))
- degree_array(2) += popcnt(xorvec(i,2))
- enddo
- degree_array(1) = shiftr(degree_array(1),1)
- degree_array(2) = shiftr(degree_array(2),1)
-
- do ispin = 1, 2
- k = 1
- !!! GETTING THE HOLES
- do i = 1, N_int
- key_hole = iand(xorvec(i,ispin),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- do ispin = 1, 2
- k = 1
- !!! GETTING THE PARTICLES
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_excitation_general '
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
- integer :: h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree_array(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
-subroutine get_holes_general(key_i, key_j,Nint, holes_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of holes between key_i and key_j
-!
-! with the following convention: a_{hole}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: holes_array(100,2)
- integer(bit_kind) :: key_hole
- integer :: ispin,k,i,pos
- holes_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_hole = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_i(i,ispin))
- do while(key_hole .ne.0_bit_kind)
- pos = trailz(key_hole)
- holes_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_hole = ibclr(key_hole,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_particles_general(key_i, key_j,Nint,particles_array)
- use bitmasks
- BEGIN_DOC
-! returns the array, per spin, of particles between key_i and key_j
-!
-! with the following convention: a^dagger_{particle}|key_i> --> |key_j>
- END_DOC
- implicit none
- integer, intent(in) :: Nint
- integer(bit_kind), intent(in) :: key_j(Nint,2),key_i(Nint,2)
- integer, intent(out) :: particles_array(100,2)
- integer(bit_kind) :: key_particle
- integer :: ispin,k,i,pos
- particles_array = -1
- do ispin = 1, 2
- k = 1
- do i = 1, N_int
- key_particle = iand(xor(key_i(i,ispin),key_j(i,ispin)),key_j(i,ispin))
- do while(key_particle .ne.0_bit_kind)
- pos = trailz(key_particle)
- particles_array(k,ispin) = 1+ bit_kind_size * (i-1) + pos
- key_particle = ibclr(key_particle,pos)
- k += 1
- if(k .gt.100)then
- print*,'WARNING in get_holes_general'
- print*,'More than a 100-th excitation for spin ',ispin
- print*,'Those are the two determinants'
- call debug_det(key_i, N_int)
- call debug_det(key_j, N_int)
- print*,'stoping ...'
- stop
- endif
- enddo
- enddo
- enddo
-end
-
-subroutine get_phase_general(key_i,Nint,degree, holes_array, particles_array,phase)
- implicit none
- integer, intent(in) :: degree(2), Nint
- integer(bit_kind), intent(in) :: key_i(Nint,2)
- integer, intent(in) :: holes_array(100,2),particles_array(100,2)
- double precision, intent(out) :: phase
- integer :: i,ispin,h,p, i_ok
- integer(bit_kind), allocatable :: det_i(:,:),det_ip(:,:)
- integer :: exc(0:2,2,2)
- double precision :: phase_tmp
- allocate(det_i(Nint,2),det_ip(N_int,2))
- det_i = key_i
- phase = 1.d0
- do ispin = 1, 2
- do i = 1, degree(ispin)
- h = holes_array(i,ispin)
- p = particles_array(i,ispin)
- det_ip = det_i
- call do_single_excitation(det_ip,h,p,ispin,i_ok)
- if(i_ok == -1)then
- print*,'excitation was not possible '
- stop
- endif
- call get_single_excitation(det_i,det_ip,exc,phase_tmp,Nint)
- phase *= phase_tmp
- det_i = det_ip
- enddo
- enddo
-
-end
-
diff --git a/plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f b/plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/test_tc_bi_ortho.irp.f
rename to plugins/local/slater_tc_no_opt/test_tc_bi_ortho.irp.f
diff --git a/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f b/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f
deleted file mode 100644
index 8940a4f6..00000000
--- a/plugins/local/tc_bi_ortho/pt2_tc_cisd.irp.f
+++ /dev/null
@@ -1,129 +0,0 @@
-program pt2_tc_cisd
-
- 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
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- print*, ' nb of states = ', N_states
- print*, ' nb of det = ', N_det
- call routine_diag()
-
- call routine
-end
-
-subroutine routine
- implicit none
- integer :: i,h1,p1,h2,p2,s1,s2,degree
- double precision :: h0i,hi0,e00,ei,delta_e
- double precision :: norm,e_corr,coef,e_corr_pos,e_corr_neg,e_corr_abs
-
- integer :: exc(0:2,2,2)
- double precision :: phase
- double precision :: eh1,ep1,eh2,ep2
-
- norm = 0.d0
- e_corr = 0.d0
- e_corr_abs = 0.d0
- e_corr_pos = 0.d0
- e_corr_neg = 0.d0
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,1), N_int, e00)
- do i = 2, N_det
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,1), N_int, hi0)
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,1), psi_det(1,1,i), N_int, h0i)
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, ei)
- call get_excitation_degree(psi_det(1,1,1), psi_det(1,1,i),degree,N_int)
- call get_excitation(psi_det(1,1,1), psi_det(1,1,i),exc,degree,phase,N_int)
- call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
- eh1 = Fock_matrix_tc_diag_mo_tot(h1)
- ep1 = Fock_matrix_tc_diag_mo_tot(p1)
- delta_e = eh1 - ep1
- if (degree==2)then
- eh2 = Fock_matrix_tc_diag_mo_tot(h2)
- ep2 = Fock_matrix_tc_diag_mo_tot(p2)
- delta_e += eh2 - ep2
- endif
-! delta_e = e00 - ei
- coef = hi0/delta_e
- norm += coef*coef
- e_corr = coef* h0i
- if(e_corr.lt.0.d0)then
- e_corr_neg += e_corr
- elseif(e_corr.gt.0.d0)then
- e_corr_pos += e_corr
- endif
- e_corr_abs += dabs(e_corr)
- enddo
- print*,'e_corr_abs = ',e_corr_abs
- print*,'e_corr_pos = ',e_corr_pos
- print*,'e_corr_neg = ',e_corr_neg
- print*,'norm = ',dsqrt(norm)
-
-end
-
-subroutine routine_diag()
-
- implicit none
- integer :: i, j, k
- double precision :: dE
-
- ! provide eigval_right_tc_bi_orth
- ! provide overlap_bi_ortho
- ! provide htilde_matrix_elmt_bi_ortho
-
- if(N_states .eq. 1) then
-
- 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_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
- print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
- print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
- print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
- print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
- 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),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
- enddo
-
- else
-
- print*,'eigval_right_tc_bi_orth : '
- do i = 1, N_states
- print*, i, eigval_right_tc_bi_orth(i)
- enddo
-
- print*,''
- print*,'******************************************************'
- print*,'TC Excitation energies (au) (eV)'
- do i = 2, N_states
- dE = eigval_right_tc_bi_orth(i) - eigval_right_tc_bi_orth(1)
- print*, i, dE, dE/0.0367502d0
- enddo
- print*,''
-
- endif
-
-end
-
-
-
diff --git a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f
deleted file mode 100644
index d4c8c55d..00000000
--- a/plugins/local/tc_bi_ortho/tc_cisd_sc2.irp.f
+++ /dev/null
@@ -1,36 +0,0 @@
-
-! ---
-
-program tc_cisd_sc2
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- 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/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f b/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
deleted file mode 100644
index 5cbf26d2..00000000
--- a/plugins/local/tc_bi_ortho/tc_cisd_sc2_utils.irp.f
+++ /dev/null
@@ -1,145 +0,0 @@
- 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,istate
- double precision :: e_before, e_current,thr, hmono,htwoe,hthree,accu
- 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))
- allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),eigval_tmp(N_states))
- dressing_dets = 0.d0
- do i = 1, N_det
- call htilde_mu_mat_bi_ortho_tot_slow(psi_det(1,1,i), psi_det(1,1,i), N_int, H_jj(i))
- 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_opt_bi_ortho(HF_bitmask,psi_det(1,1,i),N_int,hmono,htwoe,hthree,h0j(i))
- endif
- enddo
- reigvec_tc_bi_orth_tmp = 0.d0
- do i = 1, N_det
- reigvec_tc_bi_orth_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
- enddo
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- print*,'Diagonalizing the TC CISD '
- call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
- 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_before = eigval_tmp(1)
- print*,'Starting from ',E_before
-
- e_current = 10.d0
- thr = 1.d-5
- it = 0
- dressing_dets = 0.d0
- double precision, allocatable :: H_jj(:),vec_tmp(:,:),eigval_tmp(:)
- external htc_bi_ortho_calc_tdav_slow
- external htcdag_bi_ortho_calc_tdav_slow
- logical :: converged
- 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
- print*,'********************'
- print*,'iteration ',it
-! call non_hrmt_real_diag(N_det,h_sc2,&
-! leigvec_tc_bi_orth_tmp,reigvec_tc_bi_orth_tmp,&
-! n_real,eigval_right_tmp)
-! print*,'eigval_right_tmp(1)',eigval_right_tmp(1)
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(:,istate) = reigvec_tc_bi_orth_tmp(:,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- call davidson_general_diag_dressed_ext_rout_nonsym_b1space(vec_tmp, H_jj, dressing_dets,eigval_tmp, N_det, n_states, n_states_diag, converged, htc_bi_ortho_calc_tdav_slow)
- print*,'outside Davidson'
- print*,'eigval_tmp(1) = ',eigval_tmp(1)
- do i = 1, N_det
- reigvec_tc_bi_orth_tmp(i,1) = vec_tmp(i,1)
- 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)
- E_current = eigval_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/plugins/local/tc_bi_ortho/test_s2_tc.irp.f b/plugins/local/tc_bi_ortho/test_s2_tc.irp.f
deleted file mode 100644
index 7c70b119..00000000
--- a/plugins/local/tc_bi_ortho/test_s2_tc.irp.f
+++ /dev/null
@@ -1,170 +0,0 @@
-
-! ---
-
-program test_tc
-
- implicit none
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call provide_all_three_ints_bi_ortho()
- call routine_h_triple_left
- call routine_h_triple_right
-! call routine_test_s2_davidson
-
-end
-
-subroutine routine_h_triple_right
- implicit none
- logical :: do_right
- integer :: sze ,i, N_st, j
- double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
- double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- sze = N_det
- N_st = 1
- allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
- print*,'Checking first the Right '
- do i = 1, sze
- u_0(i,1) = psi_r_coef_bi_ortho(i,1)
- enddo
- double precision :: wall0,wall1
- call wall_time(wall0)
- call H_tc_s2_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
- call wall_time(wall1)
- print*,'time for omp',wall1 - wall0
- call wall_time(wall0)
- call H_tc_s2_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
- call wall_time(wall1)
- print*,'time serial ',wall1 - wall0
- accu_e = 0.d0
- accu_s = 0.d0
- do i = 1, sze
- accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
- accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
- enddo
- print*,'accu_e = ',accu_e
- print*,'accu_s = ',accu_s
-
-end
-
-subroutine routine_h_triple_left
- implicit none
- logical :: do_right
- integer :: sze ,i, N_st, j
- double precision :: sij, accu_e, accu_s, accu_e_0, accu_s_0
- double precision, allocatable :: v_0_ref(:,:),u_0(:,:),s_0_ref(:,:)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- sze = N_det
- N_st = 1
- allocate(v_0_ref(N_det,1),u_0(N_det,1),s_0_ref(N_det,1),s_0_new(N_det,1),v_0_new(N_det,1))
- print*,'Checking the Left '
- do i = 1, sze
- u_0(i,1) = psi_l_coef_bi_ortho(i,1)
- enddo
- double precision :: wall0,wall1
- call wall_time(wall0)
- call H_tc_s2_dagger_u_0_with_pure_three_omp(v_0_ref,s_0_ref, u_0,N_st,sze)
- call wall_time(wall1)
- print*,'time for omp',wall1 - wall0
- call wall_time(wall0)
- call H_tc_s2_dagger_u_0_with_pure_three(v_0_new, s_0_new, u_0, N_st, sze)
- call wall_time(wall1)
- print*,'time serial ',wall1 - wall0
- accu_e = 0.d0
- accu_s = 0.d0
- do i = 1, sze
- accu_e += dabs(v_0_ref(i,1) - v_0_new(i,1))
- accu_s += dabs(s_0_ref(i,1) - s_0_new(i,1))
- enddo
- print*,'accu_e = ',accu_e
- print*,'accu_s = ',accu_s
-
-end
-
-
-subroutine routine_test_s2_davidson
- implicit none
- double precision, allocatable :: H_jj(:),vec_tmp(:,:), energies(:) , s2(:)
- integer :: i,istate
- logical :: converged
- external H_tc_s2_dagger_u_0_opt
- external H_tc_s2_u_0_opt
- allocate(H_jj(N_det),vec_tmp(N_det,n_states_diag),energies(n_states_diag), s2(n_states_diag))
- do i = 1, N_det
- call htilde_mu_mat_bi_ortho_tot_slow(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(1:N_det,istate) = psi_l_coef_bi_ortho(1:N_det,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- do istate = 1, N_states
- leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
- enddo
- integer :: n_it_max
- n_it_max = 1
- call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_dagger_u_0_opt)
- double precision, allocatable :: v_0_new(:,:),s_0_new(:,:)
- integer :: sze,N_st
- logical :: do_right
- sze = N_det
- N_st = 1
- do_right = .False.
- allocate(s_0_new(N_det,1),v_0_new(N_det,1))
- call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
- double precision :: accu_e_0, accu_s_0
- accu_e_0 = 0.d0
- accu_s_0 = 0.d0
- do i = 1, sze
- accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
- accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
- enddo
- print*,'energies = ',energies
- print*,'s2 = ',s2
- print*,'accu_e_0',accu_e_0
- print*,'accu_s_0',accu_s_0
-
- ! Preparing the right-eigenvector
- print*,'Computing the right-eigenvector '
- vec_tmp = 0.d0
- do istate = 1, N_states
- vec_tmp(1:N_det,istate) = psi_r_coef_bi_ortho(1:N_det,istate)
- enddo
- do istate = N_states+1, n_states_diag
- vec_tmp(istate,istate) = 1.d0
- enddo
- do istate = 1, N_states
- leigvec_tc_bi_orth(1:N_det,istate) = vec_tmp(1:N_det,istate)
- enddo
- n_it_max = 1
- call davidson_hs2_nonsym_b1space(vec_tmp, H_jj, s2, energies, N_det, n_states, n_states_diag, n_it_max, converged, H_tc_s2_u_0_opt)
- sze = N_det
- N_st = 1
- do_right = .True.
- v_0_new = 0.d0
- s_0_new = 0.d0
- call H_tc_s2_u_0_nstates_openmp(v_0_new,s_0_new,vec_tmp,N_st,sze, do_right)
- accu_e_0 = 0.d0
- accu_s_0 = 0.d0
- do i = 1, sze
- accu_e_0 += v_0_new(i,1) * vec_tmp(i,1)
- accu_s_0 += s_0_new(i,1) * vec_tmp(i,1)
- enddo
- print*,'energies = ',energies
- print*,'s2 = ',s2
- print*,'accu_e_0',accu_e_0
- print*,'accu_s_0',accu_s_0
-
-end
From 2a8b9e544b8c9f47ce55dd8f0c4e7df5b0a67ea1 Mon Sep 17 00:00:00 2001
From: Abdallah Ammar
Date: Tue, 7 May 2024 01:56:14 +0200
Subject: [PATCH 126/140] working on aos debug
---
plugins/local/non_h_ints_mu/deb_aos.irp.f | 16 +-
src/ao_basis/aos_in_r.irp.f | 508 ++++++++++++----------
2 files changed, 285 insertions(+), 239 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/deb_aos.irp.f b/plugins/local/non_h_ints_mu/deb_aos.irp.f
index c9bc9c9a..a84e1b91 100644
--- a/plugins/local/non_h_ints_mu/deb_aos.irp.f
+++ b/plugins/local/non_h_ints_mu/deb_aos.irp.f
@@ -31,12 +31,14 @@ subroutine print_aos()
integer :: i, ipoint
double precision :: r(3)
double precision :: ao_val, ao_der(3), ao_lap
+ double precision :: mo_val, mo_der(3), mo_lap
PROVIDE final_grid_points aos_in_r_array aos_grad_in_r_array aos_lapl_in_r_array
+ write(1000, *) n_points_final_grid
do ipoint = 1, n_points_final_grid
r(:) = final_grid_points(:,ipoint)
- print*, r
+ write(1000, '(3(f15.7, 3X))') r
enddo
do ipoint = 1, n_points_final_grid
@@ -45,7 +47,17 @@ subroutine print_aos()
ao_val = aos_in_r_array (i,ipoint)
ao_der(:) = aos_grad_in_r_array(i,ipoint,:)
ao_lap = aos_lapl_in_r_array(1,i,ipoint) + aos_lapl_in_r_array(2,i,ipoint) + aos_lapl_in_r_array(3,i,ipoint)
- write(*, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ write(1010, '(5(f15.7, 3X))') ao_val, ao_der, ao_lap
+ enddo
+ enddo
+
+ do ipoint = 1, n_points_final_grid
+ r(:) = final_grid_points(:,ipoint)
+ do i = 1, mo_num
+ mo_val = mos_in_r_array (i,ipoint)
+ mo_der(:) = mos_grad_in_r_array(i,ipoint,:)
+ mo_lap = mos_lapl_in_r_array(i,ipoint,1) + mos_lapl_in_r_array(i,ipoint,2) + mos_lapl_in_r_array(i,ipoint,3)
+ write(2010, '(5(f15.7, 3X))') mo_val, mo_der, mo_lap
enddo
enddo
diff --git a/src/ao_basis/aos_in_r.irp.f b/src/ao_basis/aos_in_r.irp.f
index 1b1595a3..053c86a2 100644
--- a/src/ao_basis/aos_in_r.irp.f
+++ b/src/ao_basis/aos_in_r.irp.f
@@ -1,67 +1,76 @@
-double precision function ao_value(i,r)
- implicit none
- BEGIN_DOC
-! Returns the value of the i-th ao at point $\textbf{r}$
- END_DOC
- double precision, intent(in) :: r(3)
- integer, intent(in) :: i
- integer :: m,num_ao
- double precision :: center_ao(3)
- double precision :: beta
- 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)
+! ---
- 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
- ao_value = accu * dx * dy * dz
+double precision function ao_value(i, r)
+
+ BEGIN_DOC
+ ! Returns the value of the i-th ao at point $\textbf{r}$
+ END_DOC
+
+ implicit none
+ integer, intent(in) :: i
+ double precision, intent(in) :: r(3)
+
+ integer :: m, num_ao
+ integer :: power_ao(3)
+ double precision :: center_ao(3)
+ double precision :: beta
+ 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)
+
+ 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
+ ao_value = accu * dx * dy * dz
end
-double precision function primitive_value(i,j,r)
- implicit none
- BEGIN_DOC
-! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r}
-! **without the coefficient**
- END_DOC
- double precision, intent(in) :: r(3)
- integer, intent(in) :: i,j
+double precision function primitive_value(i, j, r)
- integer :: m,num_ao
- double precision :: center_ao(3)
- double precision :: beta
- 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)
+ BEGIN_DOC
+ ! Returns the value of the j-th primitive of the i-th |AO| at point $\textbf{r}
+ ! **without the coefficient**
+ END_DOC
- accu = 0.d0
- m=j
- beta = ao_expo_ordered_transp(m,i)
- accu += dexp(-beta*r2)
- primitive_value = accu * dx * dy * dz
+ implicit none
+ integer, intent(in) :: i, j
+ double precision, intent(in) :: r(3)
+
+ integer :: m, num_ao
+ integer :: power_ao(3)
+ double precision :: center_ao(3)
+ double precision :: beta
+ 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)
+
+ accu = 0.d0
+ m = j
+ beta = ao_expo_ordered_transp(m,i)
+ accu += dexp(-beta*r2)
+ primitive_value = accu * dx * dy * dz
end
@@ -104,9 +113,9 @@ subroutine give_all_aos_at_r(r, tmp_array)
dz2 = dz**p_ao(3)
tmp_array(k) = 0.d0
- do l = 1,ao_prim_num(k)
+ do l = 1, ao_prim_num(k)
beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- if(dabs(beta*r2).gt.40.d0) cycle
+ if(beta*r2.gt.50.d0) cycle
tmp_array(k) += ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
enddo
@@ -120,207 +129,232 @@ end
! ---
-subroutine give_all_aos_and_grad_at_r(r,aos_array,aos_grad_array)
- implicit none
- BEGIN_DOC
-! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
-!
-! output :
-!
-! * aos_array(i) = ao(i) evaluated at ro
-! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$
-!
- END_DOC
- double precision, intent(in) :: r(3)
- double precision, intent(out) :: aos_array(ao_num)
- double precision, intent(out) :: aos_grad_array(3,ao_num)
+subroutine give_all_aos_and_grad_at_r(r, aos_array, aos_grad_array)
- integer :: power_ao(3)
- integer :: i,j,k,l,m
- double precision :: dx,dy,dz,r2
- double precision :: dx2,dy2,dz2
- double precision :: dx1,dy1,dz1
- double precision :: center_ao(3)
- double precision :: beta,accu_1,accu_2,contrib
- do i = 1, nucl_num
- center_ao(1:3) = nucl_coord(i,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
- do j = 1,Nucl_N_Aos(i)
- k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
- aos_array(k) = 0.d0
- aos_grad_array(1,k) = 0.d0
- aos_grad_array(2,k) = 0.d0
- aos_grad_array(3,k) = 0.d0
- power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
- dx2 = dx**power_ao(1)
- dy2 = dy**power_ao(2)
- dz2 = dz**power_ao(3)
- if(power_ao(1) .ne. 0)then
- dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
- else
- dx1 = 0.d0
- endif
- if(power_ao(2) .ne. 0)then
- dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
- else
- dy1 = 0.d0
- endif
- if(power_ao(3) .ne. 0)then
- dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
- else
- dz1 = 0.d0
- endif
- accu_1 = 0.d0
- accu_2 = 0.d0
- do l = 1,ao_prim_num(k)
- beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- contrib = 0.d0
- if(beta*r2.gt.50.d0)cycle
- contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
- accu_1 += contrib
- accu_2 += contrib * beta
- enddo
- aos_array(k) = accu_1 * dx2 * dy2 * dz2
- aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
- aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
- aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ BEGIN_DOC
+ !
+ ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
+ !
+ ! output :
+ !
+ ! * aos_array(i) = ao(i) evaluated at ro
+ ! * aos_grad_array(1,i) = gradient X of the ao(i) evaluated at $\textbf{r}$
+ !
+ END_DOC
+
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: aos_array(ao_num)
+ double precision, intent(out) :: aos_grad_array(3,ao_num)
+
+ integer :: power_ao(3)
+ integer :: i, j, k, l, m
+ double precision :: dx, dy, dz, r2
+ double precision :: dx1, dy1, dz1
+ double precision :: dx2, dy2, dz2
+ double precision :: center_ao(3)
+ double precision :: beta, accu_1, accu_2, contrib
+
+ do i = 1, nucl_num
+
+ center_ao(1:3) = nucl_coord(i,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
+
+ do j = 1, Nucl_N_Aos(i)
+
+ k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
+
+ aos_array(k) = 0.d0
+ aos_grad_array(1,k) = 0.d0
+ aos_grad_array(2,k) = 0.d0
+ aos_grad_array(3,k) = 0.d0
+
+ power_ao(1:3) = ao_power_ordered_transp_per_nucl(1:3,j,i)
+ dx2 = dx**power_ao(1)
+ dy2 = dy**power_ao(2)
+ dz2 = dz**power_ao(3)
+
+ dx1 = 0.d0
+ if(power_ao(1) .ne. 0) then
+ dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
+ endif
+
+ dy1 = 0.d0
+ if(power_ao(2) .ne. 0) then
+ dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
+ endif
+
+ dz1 = 0.d0
+ if(power_ao(3) .ne. 0) then
+ dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
+ endif
+
+ accu_1 = 0.d0
+ accu_2 = 0.d0
+ do l = 1, ao_prim_num(k)
+ beta = ao_expo_ordered_transp_per_nucl(l,j,i)
+ if(beta*r2.gt.50.d0) cycle
+ contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
+ accu_1 += contrib
+ accu_2 += contrib * beta
+ enddo
+
+ aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
+ aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
+ aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ enddo
enddo
- enddo
+
end
+! ---
-subroutine give_all_aos_and_grad_and_lapl_at_r(r,aos_array,aos_grad_array,aos_lapl_array)
- implicit none
- BEGIN_DOC
-! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
-!
-! output :
-!
-! * aos_array(i) = ao(i) evaluated at $\textbf{r}$
-! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$
- END_DOC
- double precision, intent(in) :: r(3)
- double precision, intent(out) :: aos_array(ao_num)
- double precision, intent(out) :: aos_grad_array(3,ao_num)
- double precision, intent(out) :: aos_lapl_array(3,ao_num)
+subroutine give_all_aos_and_grad_and_lapl_at_r(r, aos_array, aos_grad_array, aos_lapl_array)
- integer :: power_ao(3)
- integer :: i,j,k,l,m
- double precision :: dx,dy,dz,r2
- double precision :: dx2,dy2,dz2
- double precision :: dx1,dy1,dz1
- double precision :: dx3,dy3,dz3
- double precision :: dx4,dy4,dz4
- double precision :: dx5,dy5,dz5
- double precision :: center_ao(3)
- double precision :: beta,accu_1,accu_2,accu_3,contrib
- do i = 1, nucl_num
- center_ao(1:3) = nucl_coord(i,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
- do j = 1,Nucl_N_Aos(i)
- k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
- aos_array(k) = 0.d0
- aos_grad_array(1,k) = 0.d0
- aos_grad_array(2,k) = 0.d0
- aos_grad_array(3,k) = 0.d0
+ BEGIN_DOC
+ !
+ ! input : r(1) ==> r(1) = x, r(2) = y, r(3) = z
+ !
+ ! output :
+ !
+ ! * aos_array(i) = ao(i) evaluated at $\textbf{r}$
+ ! * aos_grad_array(1,i) = $\nabla_x$ of the ao(i) evaluated at $\textbf{r}$
+ !
+ END_DOC
- aos_lapl_array(1,k) = 0.d0
- aos_lapl_array(2,k) = 0.d0
- aos_lapl_array(3,k) = 0.d0
+ implicit none
+ double precision, intent(in) :: r(3)
+ double precision, intent(out) :: aos_array(ao_num)
+ double precision, intent(out) :: aos_grad_array(3,ao_num)
+ double precision, intent(out) :: aos_lapl_array(3,ao_num)
- power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
- dx2 = dx**power_ao(1)
- dy2 = dy**power_ao(2)
- dz2 = dz**power_ao(3)
- if(power_ao(1) .ne. 0)then
- dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
- else
- dx1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(1) .ge. 2)then
- dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2)
- else
- dx3 = 0.d0
- endif
- if(power_ao(1) .ge. 1)then
- dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1))
- else
- dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1))
- endif
+ integer :: power_ao(3)
+ integer :: i, j, k, l, m
+ double precision :: dx, dy, dz, r2
+ double precision :: dx1, dy1, dz1
+ double precision :: dx2, dy2, dz2
+ double precision :: dx3, dy3, dz3
+ double precision :: dx4, dy4, dz4
+ double precision :: dx5, dy5, dz5
+ double precision :: center_ao(3)
+ double precision :: beta, accu_1, accu_2, accu_3, contrib
- dx5 = dx**(power_ao(1)+2)
+ do i = 1, nucl_num
- if(power_ao(2) .ne. 0)then
- dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
- else
- dy1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(2) .ge. 2)then
- dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2)
- else
- dy3 = 0.d0
- endif
+ center_ao(1:3) = nucl_coord(i,1:3)
- if(power_ao(2) .ge. 1)then
- dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2))
- else
- dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2))
- endif
+ 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
+
+ do j = 1, Nucl_N_Aos(i)
- dy5 = dy**(power_ao(2)+2)
+ k = Nucl_Aos_transposed(j,i) ! index of the ao in the ordered format
+ aos_array(k) = 0.d0
+ aos_grad_array(1,k) = 0.d0
+ aos_grad_array(2,k) = 0.d0
+ aos_grad_array(3,k) = 0.d0
+ aos_lapl_array(1,k) = 0.d0
+ aos_lapl_array(2,k) = 0.d0
+ aos_lapl_array(3,k) = 0.d0
+
+ power_ao(1:3)= ao_power_ordered_transp_per_nucl(1:3,j,i)
+ dx2 = dx**power_ao(1)
+ dy2 = dy**power_ao(2)
+ dz2 = dz**power_ao(3)
- if(power_ao(3) .ne. 0)then
- dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
- else
- dz1 = 0.d0
- endif
- ! For the Laplacian
- if(power_ao(3) .ge. 2)then
- dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2)
- else
- dz3 = 0.d0
- endif
+ ! ---
- if(power_ao(3) .ge. 1)then
- dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3))
- else
- dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3))
- endif
+ dx1 = 0.d0
+ if(power_ao(1) .ne. 0) then
+ dx1 = dble(power_ao(1)) * dx**(power_ao(1)-1)
+ endif
- dz5 = dz**(power_ao(3)+2)
+ dx3 = 0.d0
+ if(power_ao(1) .ge. 2) then
+ dx3 = dble(power_ao(1)) * dble((power_ao(1)-1)) * dx**(power_ao(1)-2)
+ endif
+ if(power_ao(1) .ge. 1) then
+ dx4 = dble((2 * power_ao(1) + 1)) * dx**(power_ao(1))
+ else
+ dx4 = dble((power_ao(1) + 1)) * dx**(power_ao(1))
+ endif
+
+ dx5 = dx**(power_ao(1)+2)
+
+ ! ---
+
+ dy1 = 0.d0
+ if(power_ao(2) .ne. 0) then
+ dy1 = dble(power_ao(2)) * dy**(power_ao(2)-1)
+ endif
- accu_1 = 0.d0
- accu_2 = 0.d0
- accu_3 = 0.d0
- do l = 1,ao_prim_num(k)
- beta = ao_expo_ordered_transp_per_nucl(l,j,i)
- contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
- accu_1 += contrib
- accu_2 += contrib * beta
- accu_3 += contrib * beta**2
- enddo
- aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ dy3 = 0.d0
+ if(power_ao(2) .ge. 2) then
+ dy3 = dble(power_ao(2)) * dble((power_ao(2)-1)) * dy**(power_ao(2)-2)
+ endif
+
+ if(power_ao(2) .ge. 1) then
+ dy4 = dble((2 * power_ao(2) + 1)) * dy**(power_ao(2))
+ else
+ dy4 = dble((power_ao(2) + 1)) * dy**(power_ao(2))
+ endif
+
+ dy5 = dy**(power_ao(2)+2)
- aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2- 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
- aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2- 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
- aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1- 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ ! ---
+
+ dz1 = 0.d0
+ if(power_ao(3) .ne. 0) then
+ dz1 = dble(power_ao(3)) * dz**(power_ao(3)-1)
+ endif
- aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2- 2.d0 * dx4 * dy2 * dz2* accu_2 +4.d0 * dx5 *dy2 * dz2* accu_3
- aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2- 2.d0 * dx2 * dy4 * dz2* accu_2 +4.d0 * dx2 *dy5 * dz2* accu_3
- aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3- 2.d0 * dx2 * dy2 * dz4* accu_2 +4.d0 * dx2 *dy2 * dz5* accu_3
+ dz3 = 0.d0
+ if(power_ao(3) .ge. 2) then
+ dz3 = dble(power_ao(3)) * dble((power_ao(3)-1)) * dz**(power_ao(3)-2)
+ endif
+
+ if(power_ao(3) .ge. 1) then
+ dz4 = dble((2 * power_ao(3) + 1)) * dz**(power_ao(3))
+ else
+ dz4 = dble((power_ao(3) + 1)) * dz**(power_ao(3))
+ endif
+
+ dz5 = dz**(power_ao(3)+2)
+
+ ! ---
+
+ accu_1 = 0.d0
+ accu_2 = 0.d0
+ accu_3 = 0.d0
+ do l = 1,ao_prim_num(k)
+ beta = ao_expo_ordered_transp_per_nucl(l,j,i)
+ if(beta*r2.gt.50.d0) cycle
+ contrib = ao_coef_normalized_ordered_transp_per_nucl(l,j,i) * dexp(-beta*r2)
+ accu_1 += contrib
+ accu_2 += contrib * beta
+ accu_3 += contrib * beta**2
+ enddo
+ aos_array(k) = accu_1 * dx2 * dy2 * dz2
+ aos_grad_array(1,k) = accu_1 * dx1 * dy2 * dz2 - 2.d0 * dx2 * dx * dy2 * dz2 * accu_2
+ aos_grad_array(2,k) = accu_1 * dx2 * dy1 * dz2 - 2.d0 * dx2 * dy2 * dy * dz2 * accu_2
+ aos_grad_array(3,k) = accu_1 * dx2 * dy2 * dz1 - 2.d0 * dx2 * dy2 * dz2 * dz * accu_2
+ aos_lapl_array(1,k) = accu_1 * dx3 * dy2 * dz2 - 2.d0 * dx4 * dy2 * dz2 * accu_2 + 4.d0 * dx5 * dy2 * dz2 * accu_3
+ aos_lapl_array(2,k) = accu_1 * dx2 * dy3 * dz2 - 2.d0 * dx2 * dy4 * dz2 * accu_2 + 4.d0 * dx2 * dy5 * dz2 * accu_3
+ aos_lapl_array(3,k) = accu_1 * dx2 * dy2 * dz3 - 2.d0 * dx2 * dy2 * dz4 * accu_2 + 4.d0 * dx2 * dy2 * dz5 * accu_3
+ enddo
enddo
- enddo
+
end
+! ---
From 17ae4d8fe2f103bac46205380ae0e6a33736de71 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 7 May 2024 18:27:09 +0200
Subject: [PATCH 127/140] added tc_progs
---
.../local/cipsi_tc_bi_ortho/selection.irp.f | 4 +-
..._bi_ortho.irp.f => diagonalize_tc_h.irp.f} | 0
plugins/local/tc_bi_ortho/test_natorb.irp.f | 64 -------
.../local/tc_bi_ortho/test_normal_order.irp.f | 173 ------------------
plugins/local/tc_bi_ortho/test_tc_fock.irp.f | 171 -----------------
plugins/local/tc_progs/NEED | 1 +
.../print_he_tc_energy.irp.f | 0
.../print_tc_dump.irp.f | 0
.../print_tc_energy.irp.f | 0
.../print_tc_spin_dens.irp.f | 0
.../print_tc_var.irp.f | 0
.../print_tc_wf.irp.f | 0
.../save_bitcpsileft_for_qmcchem.irp.f | 0
.../save_tc_bi_ortho_nat.irp.f | 0
.../select_dets_bi_ortho.irp.f | 0
.../tc_bi_ortho_prop.irp.f | 0
.../{tc_bi_ortho => tc_progs}/tc_som.irp.f | 0
.../test_tc_two_rdm.irp.f | 0
18 files changed, 3 insertions(+), 410 deletions(-)
rename plugins/local/tc_bi_ortho/{tc_bi_ortho.irp.f => diagonalize_tc_h.irp.f} (100%)
delete mode 100644 plugins/local/tc_bi_ortho/test_natorb.irp.f
delete mode 100644 plugins/local/tc_bi_ortho/test_normal_order.irp.f
delete mode 100644 plugins/local/tc_bi_ortho/test_tc_fock.irp.f
create mode 100644 plugins/local/tc_progs/NEED
rename plugins/local/{tc_bi_ortho => tc_progs}/print_he_tc_energy.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_dump.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_energy.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_spin_dens.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_var.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/print_tc_wf.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/save_bitcpsileft_for_qmcchem.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/save_tc_bi_ortho_nat.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/select_dets_bi_ortho.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/tc_bi_ortho_prop.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/tc_som.irp.f (100%)
rename plugins/local/{tc_bi_ortho => tc_progs}/test_tc_two_rdm.irp.f (100%)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 12163e06..0b4345d5 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -892,8 +892,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
psi_h_alpha = 0.d0
alpha_h_psi = 0.d0
do iii = 1, N_det_selectors
- call htilde_mu_mat_bi_ortho_tot_slow(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_bi_ortho_tot_slow(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
+ call htilde_mu_mat_opt_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
+ call htilde_mu_mat_opt_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
if(degree == 0)then
print*,'problem !!!'
diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/tc_bi_ortho.irp.f
rename to plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f
diff --git a/plugins/local/tc_bi_ortho/test_natorb.irp.f b/plugins/local/tc_bi_ortho/test_natorb.irp.f
deleted file mode 100644
index 5b8801f7..00000000
--- a/plugins/local/tc_bi_ortho/test_natorb.irp.f
+++ /dev/null
@@ -1,64 +0,0 @@
-
-! ---
-
-program test_natorb
-
- 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
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call routine()
- ! call test()
-
-end
-
-! ---
-
-subroutine routine()
-
- implicit none
- double precision, allocatable :: fock_diag(:),eigval(:),leigvec(:,:),reigvec(:,:),mat_ref(:,:)
- allocate(eigval(mo_num),leigvec(mo_num,mo_num),reigvec(mo_num,mo_num),fock_diag(mo_num),mat_ref(mo_num, mo_num))
- double precision, allocatable :: eigval_ref(:),leigvec_ref(:,:),reigvec_ref(:,:)
- allocate(eigval_ref(mo_num),leigvec_ref(mo_num,mo_num),reigvec_ref(mo_num,mo_num))
-
- double precision :: thr_deg
- integer :: i,n_real,j
- print*,'fock_matrix'
- do i = 1, mo_num
- fock_diag(i) = Fock_matrix_mo(i,i)
- print*,i,fock_diag(i)
- enddo
- thr_deg = 1.d-6
- mat_ref = -one_e_dm_mo
- print*,'diagonalization by block'
- call diag_mat_per_fock_degen(fock_diag,mat_ref,mo_num,thr_deg,leigvec,reigvec,eigval)
- call non_hrmt_bieig( mo_num, mat_ref&
- , leigvec_ref, reigvec_ref&
- , n_real, eigval_ref)
- print*,'TEST ***********************************'
- double precision :: accu_l, accu_r
- do i = 1, mo_num
- accu_l = 0.d0
- accu_r = 0.d0
- do j = 1, mo_num
- accu_r += reigvec_ref(j,i) * reigvec(j,i)
- accu_l += leigvec_ref(j,i) * leigvec(j,i)
- enddo
- print*,i
- write(*,'(I3,X,100(F16.10,X))')i,eigval(i),eigval_ref(i),accu_l,accu_r
- enddo
-end
diff --git a/plugins/local/tc_bi_ortho/test_normal_order.irp.f b/plugins/local/tc_bi_ortho/test_normal_order.irp.f
deleted file mode 100644
index 7b4c558f..00000000
--- a/plugins/local/tc_bi_ortho/test_normal_order.irp.f
+++ /dev/null
@@ -1,173 +0,0 @@
-
-! ---
-
-program test_normal_order
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- call provide_all_three_ints_bi_ortho()
- 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,hthree_tmp
- 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_alpha_num+1, mo_num
- do h2 = 1, elec_beta_num
- do p2 = elec_beta_num+1, mo_num
- hthree = 0.d0
-
- det_i = ref_bitmask
- s1 = 1
- s2 = 2
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,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_tmp *= phase
- hthree += 0.5d0 * hthree_tmp
- det_i = ref_bitmask
- s1 = 2
- s2 = 1
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_opt_bi_ortho(det_i,HF_bitmask,N_int,hmono,htwoe,hthree_tmp,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_tmp *= phase
- hthree += 0.5d0 * hthree_tmp
-
-
-! normal = normal_two_body_bi_orth_ab(p2,h2,p1,h1)
- call give_aba_contraction(N_int, h1, h2, p1, p2, Ne, occ, normal)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
-! print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! call three_comp_two_e_elem(det_i,h1,h2,p1,p2,s1,s2,normal)
-! normal = eff_2_e_from_3_e_ab(p2,p1,h2,h1)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
- enddo
-print*,'accu opposite spin = ',accu
-stop
-
-! p2=6
-! p1=5
-! h2=2
-! h1=1
-
-s1 = 1
-s2 = 1
-accu = 0.d0
-do h1 = 1, elec_alpha_num
- do p1 = elec_alpha_num+1, mo_num
- do p2 = p1+1, mo_num
- do h2 = h1+1, elec_alpha_num
- det_i = ref_bitmask
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_opt_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)
- integer :: hh1, pp1, hh2, pp2, ss1, ss2
- call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
- hthree *= phase
- normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
-! normal = eff_2_e_from_3_e_aa(p2,p1,h2,h1)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
- print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! print*,hthree,normal,dabs(hthree-normal)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
-enddo
-print*,'accu same spin alpha = ',accu
-
-
-s1 = 2
-s2 = 2
-accu = 0.d0
-do h1 = 1, elec_beta_num
- do p1 = elec_beta_num+1, mo_num
- do p2 = p1+1, mo_num
- do h2 = h1+1, elec_beta_num
- det_i = ref_bitmask
- call do_single_excitation(det_i,h1,p1,s1,i_ok)
- if(i_ok.ne.1)cycle
- call do_single_excitation(det_i,h2,p2,s2,i_ok)
- if(i_ok.ne.1)cycle
- call htilde_mu_mat_opt_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)
- call decode_exc(exc, 2, hh1, pp1, hh2, pp2, ss1, ss2)
- hthree *= phase
-! normal = normal_two_body_bi_orth_aa_bb(p2,h2,p1,h1)
- normal = eff_2_e_from_3_e_bb(p2,p1,h2,h1)
- if(dabs(hthree).lt.1.d-10)cycle
- if(dabs(hthree-normal).gt.1.d-10)then
- print*,pp2,pp1,hh2,hh1
- print*,p2,p1,h2,h1
- print*,hthree,normal,dabs(hthree-normal)
- stop
- endif
-! print*,hthree,normal,dabs(hthree-normal)
- accu += dabs(hthree-normal)
- enddo
- enddo
- enddo
-enddo
-print*,'accu same spin beta = ',accu
-
-
-end
-
-
diff --git a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f b/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
deleted file mode 100644
index b33b2e93..00000000
--- a/plugins/local/tc_bi_ortho/test_tc_fock.irp.f
+++ /dev/null
@@ -1,171 +0,0 @@
-
-! ---
-
-program test_tc_fock
-
- BEGIN_DOC
- ! TODO : Put the documentation of the program here
- END_DOC
-
- implicit none
-
- print *, 'Hello world'
-
- my_grid_becke = .True.
- PROVIDE tc_grid1_a tc_grid1_r
- my_n_pt_r_grid = tc_grid1_r
- my_n_pt_a_grid = tc_grid1_a
- touch my_grid_becke my_n_pt_r_grid my_n_pt_a_grid
-
- read_wf = .True.
- touch read_wf
-
- !call routine_1
- !call routine_2
-! call routine_3()
-
- call routine_tot
-
-end
-
-! ---
-
-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, ref, new
- integer(bit_kind), allocatable :: det_i(:,:)
-
- allocate(det_i(N_int,2))
-
- err_tot = 0.d0
-
- do s1 = 1, 2
-
- 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_num_tab(s1)
- do a = elec_num_tab(s1)+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_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
- if(dabs(hthree).lt.1.d-10)cycle
- ref = hthree
- if(s1 == 1)then
- new = fock_a_tot_3e_bi_orth(a,i)
- else if(s1 == 2)then
- new = fock_b_tot_3e_bi_orth(a,i)
- endif
- err_ai = dabs(dabs(ref) - dabs(new))
- if(err_ai .gt. 1d-7) then
- print*,'s1 = ',s1
- print*, ' warning on', i, a
- print*, ref,new,err_ai
- endif
- print*, ref,new,err_ai
- err_tot += err_ai
-
- write(22, *) htilde_ij
- enddo
- enddo
- enddo
-
- print *, ' err_tot = ', err_tot
-
- deallocate(det_i)
-
-end subroutine routine_3
-
-! ---
-subroutine routine_tot()
-
- use bitmasks ! you need to include the bitmasks_module.f90 features
-
- implicit none
- integer :: i, a, i_ok, s1,other_spin(2)
- double precision :: hmono, htwoe, hthree, htilde_ij
- double precision :: err_ai, err_tot, ref, new
- integer(bit_kind), allocatable :: det_i(:,:)
-
- allocate(det_i(N_int,2))
- other_spin(1) = 2
- other_spin(2) = 1
-
- err_tot = 0.d0
-
-! do s1 = 1, 2
- s1 = 2
- 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_num_tab(s1)
-! do a = elec_num_tab(s1)+1, mo_num ! virtual
- do i = 1, elec_beta_num
- do a = elec_beta_num+1, mo_num! virtual
- print*,i,a
-
- 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 htilde_mu_mat_opt_bi_ortho(det_i, ref_bitmask, N_int, hmono, htwoe, hthree, htilde_ij)
- print*,htilde_ij
-! if(dabs(htilde_ij).lt.1.d-10)cycle
- print*, ' excited det'
- call debug_det(det_i, N_int)
-
- if(s1 == 1)then
- new = Fock_matrix_tc_mo_alpha(a,i)
- else
- new = Fock_matrix_tc_mo_beta(a,i)
- endif
- ref = htilde_ij
-! if(s1 == 1)then
-! new = fock_a_tot_3e_bi_orth(a,i)
-! else if(s1 == 2)then
-! new = fock_b_tot_3e_bi_orth(a,i)
-! endif
- err_ai = dabs(dabs(ref) - dabs(new))
- if(err_ai .gt. 1d-7) then
- print*,'---------'
- print*,'s1 = ',s1
- print*, ' warning on', i, a
- print*, ref,new,err_ai
- print*,hmono, htwoe, hthree
- print*,'---------'
- endif
- print*, ref,new,err_ai
- err_tot += err_ai
-
- write(22, *) htilde_ij
- enddo
- enddo
-! enddo
-
- print *, ' err_tot = ', err_tot
-
- deallocate(det_i)
-
-end subroutine routine_3
diff --git a/plugins/local/tc_progs/NEED b/plugins/local/tc_progs/NEED
new file mode 100644
index 00000000..9deb3db4
--- /dev/null
+++ b/plugins/local/tc_progs/NEED
@@ -0,0 +1 @@
+tc_bi_ortho
diff --git a/plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f b/plugins/local/tc_progs/print_he_tc_energy.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_he_tc_energy.irp.f
rename to plugins/local/tc_progs/print_he_tc_energy.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_dump.irp.f b/plugins/local/tc_progs/print_tc_dump.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_dump.irp.f
rename to plugins/local/tc_progs/print_tc_dump.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_energy.irp.f b/plugins/local/tc_progs/print_tc_energy.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_energy.irp.f
rename to plugins/local/tc_progs/print_tc_energy.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f b/plugins/local/tc_progs/print_tc_spin_dens.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_spin_dens.irp.f
rename to plugins/local/tc_progs/print_tc_spin_dens.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_var.irp.f b/plugins/local/tc_progs/print_tc_var.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_var.irp.f
rename to plugins/local/tc_progs/print_tc_var.irp.f
diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_progs/print_tc_wf.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/print_tc_wf.irp.f
rename to plugins/local/tc_progs/print_tc_wf.irp.f
diff --git a/plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f b/plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/save_bitcpsileft_for_qmcchem.irp.f
rename to plugins/local/tc_progs/save_bitcpsileft_for_qmcchem.irp.f
diff --git a/plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f b/plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/save_tc_bi_ortho_nat.irp.f
rename to plugins/local/tc_progs/save_tc_bi_ortho_nat.irp.f
diff --git a/plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f b/plugins/local/tc_progs/select_dets_bi_ortho.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/select_dets_bi_ortho.irp.f
rename to plugins/local/tc_progs/select_dets_bi_ortho.irp.f
diff --git a/plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f b/plugins/local/tc_progs/tc_bi_ortho_prop.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/tc_bi_ortho_prop.irp.f
rename to plugins/local/tc_progs/tc_bi_ortho_prop.irp.f
diff --git a/plugins/local/tc_bi_ortho/tc_som.irp.f b/plugins/local/tc_progs/tc_som.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/tc_som.irp.f
rename to plugins/local/tc_progs/tc_som.irp.f
diff --git a/plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f b/plugins/local/tc_progs/test_tc_two_rdm.irp.f
similarity index 100%
rename from plugins/local/tc_bi_ortho/test_tc_two_rdm.irp.f
rename to plugins/local/tc_progs/test_tc_two_rdm.irp.f
From b7787f5e6dce198bee06eb92f69b9904a7448bea Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 7 May 2024 19:43:05 +0200
Subject: [PATCH 128/140] trying to speed up the PT2 in TC by transposing the
array of tc integrals
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 8 +-
.../cipsi_tc_bi_ortho/get_d0_transp.irp.f | 140 +++++++++++
.../local/cipsi_tc_bi_ortho/get_d2_good.irp.f | 3 -
.../cipsi_tc_bi_ortho/get_d2_transp.irp.f | 235 ++++++++++++++++++
plugins/local/cipsi_tc_bi_ortho/pt2.irp.f | 1 +
.../local/cipsi_tc_bi_ortho/selection.irp.f | 94 +------
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 3 +
plugins/local/fci_tc_bi/pt2_tc.irp.f | 2 +
.../local/tc_bi_ortho/e_corr_bi_ortho.irp.f | 1 -
plugins/local/tc_keywords/EZFIO.cfg | 11 +-
10 files changed, 404 insertions(+), 94 deletions(-)
create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 1e127fac..71269fdc 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -259,15 +259,21 @@ BEGIN_PROVIDER [ double precision, mo_bi_ortho_tc_two_e_transp, (mo_num, mo_num,
END_DOC
integer :: i,j,k,l
+ print*,'Providing mo_bi_ortho_tc_two_e_transp'
+ double precision :: t0,t1
+ call wall_time(t0)
do i = 1, mo_num
do j = 1, mo_num
do k = 1, mo_num
do l = 1, mo_num
- mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e_transp(k,l,i,j)
+ mo_bi_ortho_tc_two_e_transp(i,j,k,l) = mo_bi_ortho_tc_two_e(k,l,i,j)
enddo
enddo
enddo
enddo
+ call wall_time(t1)
+
+ print *, ' WALL TIME for PROVIDING mo_bi_ortho_tc_two_e_transp (min)', (t1-t0)/60.d0
END_PROVIDER
! ---
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
new file mode 100644
index 00000000..56238e13
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
@@ -0,0 +1,140 @@
+subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices/conjg should be okay for complex
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ integer(bit_kind) :: det(N_int, 2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+
+ integer :: i, j, k, s, h1, h2, p1, p2, puti, putj, mm
+ double precision :: phase
+ double precision :: hij,hji
+ double precision, external :: get_phase_bi
+ logical :: ok
+
+ integer, parameter :: bant=1
+ double precision, allocatable :: hij_cache1(:), hij_cache2(:)
+ allocate (hij_cache1(mo_num),hij_cache2(mo_num))
+ double precision, allocatable :: hji_cache1(:), hji_cache2(:)
+ allocate (hji_cache1(mo_num),hji_cache2(mo_num))
+! print*,'in get_d0_new'
+! call debug_det(gen,N_int)
+! print*,'coefs',coefs(1,:)
+
+ if(sp == 3) then ! AB
+ h1 = p(1,1)
+ h2 = p(1,2)
+ do p1=1, mo_num
+ if(bannedOrb(p1, 1)) cycle
+! call get_mo_two_e_integrals_complex(p1,h2,h1,mo_num,hij_cache1,mo_integrals_map)
+ do mm = 1, mo_num
+ hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,p1,h2,h1)
+ hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,p1,h2,h1)
+ enddo
+ !!!!!!!!!!
+ do p2=1, mo_num
+ if(bannedOrb(p2,2)) cycle
+ if(banned(p1, p2, bant)) cycle ! rentable?
+ if(p1 == h1 .or. p2 == h2) then
+ call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
+ ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
+! call i_h_j_complex(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
+ else
+ phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ hij = hij_cache1(p2) * phase
+ end if
+ if (hij == (0.d0,0.d0)) cycle
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT
+ enddo
+ end do
+ !!!!!!!!!!
+ do p2=1, mo_num
+ if(bannedOrb(p2,2)) cycle
+ if(banned(p1, p2, bant)) cycle ! rentable?
+ if(p1 == h1 .or. p2 == h2) then
+ call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
+ ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
+! call i_h_j_complex(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
+ else
+ phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ hji = hji_cache1(p2) * phase
+ end if
+ if (hji == (0.d0,0.d0)) cycle
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT
+ enddo
+ end do
+ end do
+
+ else ! AA BB
+ p1 = p(1,sp)
+ p2 = p(2,sp)
+ do puti=1, mo_num
+ if(bannedOrb(puti, sp)) cycle
+! call get_mo_two_e_integrals_complex(puti,p2,p1,mo_num,hij_cache1,mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(puti,p1,p2,mo_num,hij_cache2,mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache1(mm) = mo_bi_ortho_tc_two_e(mm,puti,p2,p1)
+ hij_cache2(mm) = mo_bi_ortho_tc_two_e(mm,puti,p1,p2)
+ hji_cache1(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p2,p1)
+ hji_cache2(mm) = mo_bi_ortho_tc_two_e_transp(mm,puti,p1,p2)
+ enddo
+ !!!!!!!!!!
+ do putj=puti+1, mo_num
+ if(bannedOrb(putj, sp)) cycle
+ if(banned(puti, putj, bant)) cycle ! rentable?
+ if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
+ call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
+ !call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
+! call i_h_j_complex(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
+ if (hij == 0.d0) cycle
+ else
+! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
+! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
+ hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
+ if (hij == 0.d0) cycle
+ hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
+ end if
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ enddo
+ end do
+
+ !!!!!!!!!!
+ do putj=puti+1, mo_num
+ if(bannedOrb(putj, sp)) cycle
+ if(banned(puti, putj, bant)) cycle ! rentable?
+ if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
+ call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
+ if (hji == 0.d0) cycle
+ else
+! hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj))
+ hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2 ) - mo_bi_ortho_tc_two_e_transp( puti, putj, p2, p1))
+ if (hji == 0.d0) cycle
+ hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
+ end if
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end do
+ end do
+ end if
+
+ deallocate(hij_cache1,hij_cache2)
+end
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
index d01ed433..86922ae9 100644
--- a/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_good.irp.f
@@ -25,9 +25,6 @@ subroutine get_d2_new(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h,
integer :: bant
bant = 1
-! print*, 'in get_d2_new'
-! call debug_det(gen,N_int)
-! print*,'coefs',coefs(1,:)
tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
new file mode 100644
index 00000000..b2a7ea31
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d2_transp.irp.f
@@ -0,0 +1,235 @@
+
+subroutine get_d2_new_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices/conjg should be correct for complex
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+
+ double precision, external :: get_phase_bi
+
+ integer :: i, j, k, tip, ma, mi, puti, putj
+ integer :: h1, h2, p1, p2, i1, i2
+ double precision :: phase
+ double precision :: hij,hji
+
+ integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/))
+ integer, parameter :: turn2(2) = (/2, 1/)
+ integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+
+ integer :: bant
+ bant = 1
+
+ tip = p(0,1) * p(0,2) ! number of alpha particles times number of beta particles
+
+ ma = sp !1:(alpha,alpha); 2:(b,b); 3:(a,b)
+ if(p(0,1) > p(0,2)) ma = 1 ! more alpha particles than beta particles
+ if(p(0,1) < p(0,2)) ma = 2 ! fewer alpha particles than beta particles
+ mi = mod(ma, 2) + 1
+
+ if(sp == 3) then ! if one alpha and one beta xhole
+ !(where xholes refer to the ionizations from the generator, not the holes occupied in the ionized generator)
+ if(ma == 2) bant = 2 ! if more beta particles than alpha particles
+
+ if(tip == 3) then ! if 3 of one particle spin and 1 of the other particle spin
+ puti = p(1, mi)
+ if(bannedOrb(puti, mi)) return
+ h1 = h(1, ma)
+ h2 = h(2, ma)
+
+ !!
+ do i = 1, 3 ! loop over all 3 combinations of 2 particles with spin ma
+ putj = p(i, ma)
+ if(banned(putj,puti,bant)) cycle
+ i1 = turn3(1,i)
+ i2 = turn3(2,i)
+ p1 = p(i1, ma)
+ p2 = p(i2, ma)
+
+ ! |G> = |psi_{gen,i}>
+ ! |G'> = a_{x1} a_{x2} |G>
+ ! |alpha> = a_{puti}^{\dagger} a_{putj}^{\dagger} |G'>
+ ! |alpha> = t_{x1,x2}^{puti,putj} |G>
+ ! hij =
+ ! |alpha> = t_{p1,p2}^{h1,h2}|psi_{selectors,i}>
+ !todo: = ( - ) * phase
+ ! += dconjg(c_i) *
+ ! = ( - ) * phase
+ ! += * c_i
+
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+
+! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e( h1, h2, p2, p1)
+! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2) - mo_bi_ortho_tc_two_e_transp( h1, h2, p2, p1)
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp( p1, p2, h2, h1)
+ hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e( p1, p2, h2, h1)
+ if (hij == 0.d0.or.hji==0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+
+ if(ma == 1) then ! if particle spins are (alpha,alpha,alpha,beta), then puti is beta and putj is alpha
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
+ mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
+ enddo
+ else ! if particle spins are (beta,beta,beta,alpha), then puti is alpha and putj is beta
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end if
+ end do
+ else ! if 2 alpha and 2 beta particles
+ h1 = h(1,1)
+ h2 = h(1,2)
+ !!
+ do j = 1,2 ! loop over all 4 combinations of one alpha and one beta particle
+ putj = p(j, 2)
+ if(bannedOrb(putj, 2)) cycle
+ p2 = p(turn2(j), 2)
+ do i = 1,2
+ puti = p(i, 1)
+ if(banned(puti,putj,bant) .or. bannedOrb(puti,1)) cycle
+ p1 = p(turn2(i), 1)
+ ! hij =
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+! hij = mo_bi_ortho_tc_two_e(h1, h2, p1, p2 )
+! hji = mo_bi_ortho_tc_two_e_transp(h1, h2, p1, p2 )
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2 )
+ hji = mo_bi_ortho_tc_two_e( p1, p2, h1, h2)
+ if (hij /= 0.d0.or.hji==0.d0) then
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ endif
+ end do
+ end do
+ end if
+
+ else ! if holes are (a,a) or (b,b)
+ if(tip == 0) then ! if particles are (a,a,a,a) or (b,b,b,b)
+ h1 = h(1, ma)
+ h2 = h(2, ma)
+ !!
+ do i=1,3
+ puti = p(i, ma)
+ if(bannedOrb(puti,ma)) cycle
+ do j=i+1,4
+ putj = p(j, ma)
+ if(bannedOrb(putj,ma)) cycle
+ if(banned(puti,putj,1)) cycle
+
+ i1 = turn2d(1, i, j)
+ i2 = turn2d(2, i, j)
+ p1 = p(i1, ma)
+ p2 = p(i2, ma)
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e_transp(p1, p2, h2,h1 )
+ hji = mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p1, p2, h2,h1 )
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) +coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) +coefs(k,1) * hji
+ enddo
+ end do
+ end do
+ else if(tip == 3) then ! if particles are (a,a,a,b) (ma=1,mi=2) or (a,b,b,b) (ma=2,mi=1)
+ h1 = h(1, mi)
+ h2 = h(1, ma)
+ p1 = p(1, mi)
+ !!
+ do i=1,3
+ puti = p(turn3(1,i), ma)
+ if(bannedOrb(puti,ma)) cycle
+ putj = p(turn3(2,i), ma)
+ if(bannedOrb(putj,ma)) cycle
+ if(banned(puti,putj,1)) cycle
+ p2 = p(i, ma)
+
+! hij = mo_bi_ortho_tc_two_e(p1, p2, h1, h2)
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = mo_bi_ortho_tc_two_e_transp(p1, p2 ,h1, h2)
+ hji = mo_bi_ortho_tc_two_e(p1, p2,h1, h2 )
+ if (hij == 0.d0) cycle
+
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ if (puti < putj) then
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ else
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, putj, puti) = mat_r(k, putj, puti) + coefs(k,2) * hij
+ mat_l(k, putj, puti) = mat_l(k, putj, puti) + coefs(k,1) * hji
+ enddo
+ endif
+ end do
+ else ! tip == 4 (a,a,b,b)
+ puti = p(1, sp)
+ putj = p(2, sp)
+ if(.not. banned(puti,putj,1)) then
+ p1 = p(1, mi)
+ p2 = p(2, mi)
+ h1 = h(1, mi)
+ h2 = h(2, mi)
+ !!
+! hij = (mo_bi_ortho_tc_two_e(p1, p2, h1, h2) - mo_bi_ortho_tc_two_e(p2,p1, h1, h2))
+!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!
+ ! take the transpose of what's written above because later use the complex conjugate
+ hij = (mo_bi_ortho_tc_two_e_transp(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e_transp(p2,p1,h1, h2))
+ hji = (mo_bi_ortho_tc_two_e(p1, p2,h1, h2) - mo_bi_ortho_tc_two_e(p2,p1,h1, h2))
+ if (hij /= 0.d0.or.hji==0.d0) then
+ ! take conjugate to get contribution to instead of
+! hij = dconjg(hij) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
+ phase = get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2, N_int)
+ hij = hij * phase
+ hji = hji* phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
+ mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
+ enddo
+ end if
+ end if
+ end if
+ end if
+end
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
index 833cc0ea..ada19c6b 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
@@ -67,6 +67,7 @@ subroutine tc_pt2
call pt2_alloc(pt2_data_err, N_states)
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
+ call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
end
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 0b4345d5..0f785ba2 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -636,10 +636,7 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
negMask(i,2) = not(mask(i,2))
end do
-! print*,'in selection '
do i = 1, N_sel
-! call debug_det(det(1,1,i),N_int)
-! print*,i,dabs(psi_selectors_coef_transp_tc(1,2,i) * psi_selectors_coef_transp_tc(1,1,i))
if(interesting(i) < 0) then
stop 'prefetch interesting(i) and det(i)'
endif
@@ -691,11 +688,19 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
call get_mask_phase(psi_det_sorted_tc(1,1,interesting(i)), phasemask,N_int)
if(nt == 4) then
- call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ if(transpose_two_e_int)then
+ call get_d2_new_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
+ call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
elseif(nt == 3) then
call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
else
+ if(transpose_two_e_int)then
+ call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
endif
elseif(nt == 4) then
call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int)
@@ -887,79 +892,11 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
call diag_htilde_mu_mat_fock_bi_ortho(N_int, det, hmono, htwoe, hthree, hii)
do istate = 1,N_states
delta_E = E0(istate) - Hii + E_shift
- double precision :: alpha_h_psi_tmp, psi_h_alpha_tmp, error
- if(debug_tc_pt2 == 1)then !! Using the old version
- psi_h_alpha = 0.d0
- alpha_h_psi = 0.d0
- do iii = 1, N_det_selectors
- call htilde_mu_mat_opt_bi_ortho_tot(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_opt_bi_ortho_tot(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- call get_excitation_degree(psi_selectors(1,1,iii), det,degree,N_int)
- if(degree == 0)then
- print*,'problem !!!'
- print*,'a determinant is already in the wave function !!'
- print*,'it corresponds to the selector number ',iii
- call debug_det(det,N_int)
- stop
- endif
-! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
-! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- psi_h_alpha += i_h_alpha * psi_selectors_coef_tc(iii,2,1) ! left function
- alpha_h_psi += alpha_h_i * psi_selectors_coef_tc(iii,1,1) ! right function
- enddo
- else if(debug_tc_pt2 == 2)then !! debugging the new version
-! psi_h_alpha_tmp = 0.d0
-! alpha_h_psi_tmp = 0.d0
-! do iii = 1, N_det_selectors ! old version
-! call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
-! call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
-! psi_h_alpha_tmp += i_h_alpha * psi_selectors_coef_tc(iii,1,1) ! left function
-! alpha_h_psi_tmp += alpha_h_i * psi_selectors_coef_tc(iii,2,1) ! right function
-! enddo
- psi_h_alpha_tmp = mat_l(istate, p1, p2) ! new version
- alpha_h_psi_tmp = mat_r(istate, p1, p2) ! new version
- psi_h_alpha = 0.d0
- alpha_h_psi = 0.d0
- do iii = 1, N_det ! old version
- call htilde_mu_mat_opt_bi_ortho_no_3e(psi_det(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_det(1,1,iii), N_int, alpha_h_i)
- psi_h_alpha += i_h_alpha * psi_l_coef_bi_ortho(iii,1) ! left function
- alpha_h_psi += alpha_h_i * psi_r_coef_bi_ortho(iii,1) ! right function
- enddo
- if(dabs(psi_h_alpha*alpha_h_psi/delta_E).gt.1.d-10)then
- error = dabs(psi_h_alpha * alpha_h_psi - psi_h_alpha_tmp * alpha_h_psi_tmp)/dabs(psi_h_alpha * alpha_h_psi)
- if(error.gt.1.d-2)then
- call debug_det(det, N_int)
- print*,'error =',error,psi_h_alpha * alpha_h_psi/delta_E,psi_h_alpha_tmp * alpha_h_psi_tmp/delta_E
- print*,psi_h_alpha , alpha_h_psi
- print*,psi_h_alpha_tmp , alpha_h_psi_tmp
- print*,'selectors '
- do iii = 1, N_det_selectors ! old version
- print*,'iii',iii,psi_selectors_coef_tc(iii,1,1),psi_selectors_coef_tc(iii,2,1)
- call htilde_mu_mat_opt_bi_ortho_no_3e(psi_selectors(1,1,iii), det, N_int, i_h_alpha)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det, psi_selectors(1,1,iii), N_int, alpha_h_i)
- print*,i_h_alpha,alpha_h_i
- call debug_det(psi_selectors(1,1,iii),N_int)
- enddo
-! print*,'psi_det '
-! do iii = 1, N_det! old version
-! print*,'iii',iii,psi_l_coef_bi_ortho(iii,1),psi_r_coef_bi_ortho(iii,1)
-! call debug_det(psi_det(1,1,iii),N_int)
-! enddo
- stop
- endif
- endif
- else
- psi_h_alpha = mat_l(istate, p1, p2)
- alpha_h_psi = mat_r(istate, p1, p2)
- endif
+ psi_h_alpha = mat_l(istate, p1, p2)
+ alpha_h_psi = mat_r(istate, p1, p2)
val = 4.d0 * psi_h_alpha * alpha_h_psi
tmp = dsqrt(delta_E * delta_E + val)
-! if (delta_E < 0.d0) then
-! tmp = -tmp
-! endif
e_pert(istate) = 0.25 * val / delta_E
-! e_pert(istate) = 0.5d0 * (tmp - delta_E)
if(dsqrt(tmp).gt.1.d-4.and.dabs(psi_h_alpha).gt.1.d-4)then
coef(istate) = e_pert(istate) / psi_h_alpha
else
@@ -976,15 +913,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d
if(e_pert(istate).gt.0.d0)e_pert(istate)=0.d0
endif
-! if(selection_tc == 1 )then
-! if(e_pert(istate).lt.0.d0)then
-! e_pert(istate) = 0.d0
-! endif
-! else if(selection_tc == -1)then
-! if(e_pert(istate).gt.0.d0)then
-! e_pert(istate) = 0.d0
-! endif
-! endif
enddo
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index 99a8de7e..bb5a89a1 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -88,6 +88,9 @@ subroutine run_stochastic_cipsi
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
+ if(transpose_two_e_int)then
+ provide mo_bi_ortho_tc_two_e_transp
+ endif
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
diff --git a/plugins/local/fci_tc_bi/pt2_tc.irp.f b/plugins/local/fci_tc_bi/pt2_tc.irp.f
index 390042bf..3c07e367 100644
--- a/plugins/local/fci_tc_bi/pt2_tc.irp.f
+++ b/plugins/local/fci_tc_bi/pt2_tc.irp.f
@@ -13,6 +13,8 @@ program tc_pt2_prog
pruning = -1.d0
touch pruning
+ read_wf = .True.
+ touch read_wf
! pt2_relative_error = 0.01d0
! touch pt2_relative_error
diff --git a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
index 4abdc25b..5a3971c5 100644
--- a/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
+++ b/plugins/local/tc_bi_ortho/e_corr_bi_ortho.irp.f
@@ -27,7 +27,6 @@
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
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 1e89eaa4..39968ec8 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -184,12 +184,6 @@ doc: Read/Write normal_two_body_bi_orth from/to disk [ Write | Read | None ]
interface: ezfio,provider,ocaml
default: None
-[debug_tc_pt2]
-type: integer
-doc: If :: 1 then you compute the TC-PT2 the old way, :: 2 then you check with the new version but without three-body
-interface: ezfio,provider,ocaml
-default: -1
-
[only_spin_tc_right]
type: logical
doc: If |true|, only the right part of WF is used to compute spin dens
@@ -268,3 +262,8 @@ doc: Thresholds on the Imag part of TC energy
interface: ezfio,provider,ocaml
default: 1.e-7
+[transpose_two_e_int]
+type: logical
+doc: If |true|, you duplicate the two-electron TC integrals with the transpose matrix. Acceleates the PT2.
+interface: ezfio,provider,ocaml
+default: False
From 18fd70f1b88ee4a412a351a92a98f4b1ef1ee3d0 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 7 May 2024 20:18:24 +0200
Subject: [PATCH 129/140] added get_d1_transp.irp.f
---
.../cipsi_tc_bi_ortho/get_d1_transp.irp.f | 350 ++++++++++++++++++
.../local/cipsi_tc_bi_ortho/selection.irp.f | 6 +-
2 files changed, 355 insertions(+), 1 deletion(-)
create mode 100644 plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
new file mode 100644
index 00000000..3c6cbf60
--- /dev/null
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
@@ -0,0 +1,350 @@
+subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, coefs)
+ !todo: indices should be okay for complex?
+ use bitmasks
+ implicit none
+
+ integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2)
+ integer(bit_kind), intent(in) :: phasemask(N_int,2)
+ logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num,2)
+ integer(bit_kind) :: det(N_int, 2)
+ double precision, intent(in) :: coefs(N_states,2)
+ double precision, intent(inout) :: mat_l(N_states, mo_num, mo_num)
+ double precision, intent(inout) :: mat_r(N_states, mo_num, mo_num)
+ integer, intent(in) :: h(0:2,2), p(0:4,2), sp
+ double precision, external :: get_phase_bi
+ double precision, external :: mo_two_e_integral_complex
+ logical :: ok
+
+ logical, allocatable :: lbanned(:,:)
+ integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
+ integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
+
+ integer, parameter :: turn2(2) = (/2,1/)
+ integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/))
+
+ integer :: bant
+ double precision, allocatable :: hij_cache(:,:)
+ double precision :: hij, tmp_rowij(N_states, mo_num), tmp_rowij2(N_states, mo_num),phase
+ double precision, allocatable :: hji_cache(:,:)
+ double precision :: hji, tmp_rowji(N_states, mo_num), tmp_rowji2(N_states, mo_num)
+! PROVIDE mo_integrals_map N_int
+! print*,'in get_d1_new'
+! call debug_det(gen,N_int)
+! print*,'coefs',coefs(1,:)
+
+ allocate (lbanned(mo_num, 2))
+ allocate (hij_cache(mo_num,2))
+ allocate (hji_cache(mo_num,2))
+ lbanned = bannedOrb
+
+ do i=1, p(0,1)
+ lbanned(p(i,1), 1) = .true.
+ end do
+ do i=1, p(0,2)
+ lbanned(p(i,2), 2) = .true.
+ end do
+
+ ma = 1
+ if(p(0,2) >= 2) ma = 2
+ mi = turn2(ma)
+
+ bant = 1
+
+ if(sp == 3) then
+ !move MA
+ if(ma == 2) bant = 2
+ puti = p(1,mi)
+ hfix = h(1,ma)
+ p1 = p(1,ma)
+ p2 = p(2,ma)
+ if(.not. bannedOrb(puti, mi)) then
+! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ enddo
+ !!
+ tmp_rowij = 0.d0
+ tmp_rowji = 0.d0
+ do putj=1, hfix-1
+ if(lbanned(putj, ma)) cycle
+ if(banned(putj, puti,bant)) cycle
+ hij = hij_cache(putj,1) - hij_cache(putj,2)
+ hji = hji_cache(putj,1) - hji_cache(putj,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
+ tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
+ enddo
+ endif
+ end do
+ do putj=hfix+1, mo_num
+ if(lbanned(putj, ma)) cycle
+ if(banned(putj, puti,bant)) cycle
+ hij = hij_cache(putj,2) - hij_cache(putj,1)
+ hji = hji_cache(putj,2) - hji_cache(putj,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,putj) = tmp_rowij(k,putj) + hij * coefs(k,2)
+ tmp_rowji(k,putj) = tmp_rowji(k,putj) + hji * coefs(k,1)
+ enddo
+ endif
+ end do
+
+ if(ma == 1) then
+ mat_r(1:N_states,1:mo_num,puti) = mat_r(1:N_states,1:mo_num,puti) + tmp_rowij(1:N_states,1:mo_num)
+ mat_l(1:N_states,1:mo_num,puti) = mat_l(1:N_states,1:mo_num,puti) + tmp_rowji(1:N_states,1:mo_num)
+ else
+ do l=1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,puti,l) = mat_r(k,puti,l) + tmp_rowij(k,l)
+ mat_l(k,puti,l) = mat_l(k,puti,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ end if
+
+ end if
+
+ !MOVE MI
+ pfix = p(1,mi)
+ tmp_rowij = 0.d0
+ tmp_rowij2 = 0.d0
+ tmp_rowji = 0.d0
+ tmp_rowji2 = 0.d0
+! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p1)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p2)
+ enddo
+ putj = p1
+ !!
+ do puti=1,mo_num !HOT
+ if(lbanned(puti,mi)) cycle
+ !p1 fixed
+ putj = p1
+ if(.not. banned(putj,puti,bant)) then
+ hij = hij_cache(puti,2)
+ hji = hji_cache(puti,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
+ tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+!
+ putj = p2
+ if(.not. banned(putj,puti,bant)) then
+ hij = hij_cache(puti,1)
+ hji = hji_cache(puti,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ do k=1,N_states
+ tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
+ tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+ end do
+
+ if(mi == 1) then
+ mat_r(:,:,p1) = mat_r(:,:,p1) + tmp_rowij(:,:)
+ mat_r(:,:,p2) = mat_r(:,:,p2) + tmp_rowij2(:,:)
+ mat_l(:,:,p1) = mat_l(:,:,p1) + tmp_rowji(:,:)
+ mat_l(:,:,p2) = mat_l(:,:,p2) + tmp_rowji2(:,:)
+ else
+ do l=1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij(k,l)
+ mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij2(k,l)
+ mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji(k,l)
+ mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji2(k,l)
+ enddo
+ enddo
+ end if
+
+ else ! sp /= 3
+
+ if(p(0,ma) == 3) then
+ do i=1,3
+ hfix = h(1,ma)
+ puti = p(i, ma)
+ p1 = p(turn3(1,i), ma)
+ p2 = p(turn3(2,i), ma)
+! call get_mo_two_e_integrals_complex(hfix,p1,p2,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,p1,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,p2)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ enddo
+ !!
+ tmp_rowij = 0.d0
+ tmp_rowji = 0.d0
+ do putj=1,hfix-1
+ if(banned(putj,puti,1)) cycle
+ if(lbanned(putj,ma)) cycle
+ hij = hij_cache(putj,1) - hij_cache(putj,2)
+ hji = hji_cache(putj,1) - hji_cache(putj,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
+ tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
+ endif
+ end do
+ do putj=hfix+1,mo_num
+ if(banned(putj,puti,1)) cycle
+ if(lbanned(putj,ma)) cycle
+ hij = hij_cache(putj,2) - hij_cache(putj,1)
+ hji = hji_cache(putj,2) - hji_cache(putj,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ tmp_rowij(:,putj) = tmp_rowij(:,putj) + hij * coefs(:,2)
+ tmp_rowji(:,putj) = tmp_rowji(:,putj) + hji * coefs(:,1)
+ endif
+ end do
+
+ mat_r(:, :puti-1, puti) = mat_r(:, :puti-1, puti) + tmp_rowij(:,:puti-1)
+ mat_l(:, :puti-1, puti) = mat_l(:, :puti-1, puti) + tmp_rowji(:,:puti-1)
+ do l=puti,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k, puti, l) = mat_r(k, puti,l) + tmp_rowij(k,l)
+ mat_l(k, puti, l) = mat_l(k, puti,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ end do
+ else
+ hfix = h(1,mi)
+ pfix = p(1,mi)
+ p1 = p(1,ma)
+ p2 = p(2,ma)
+ tmp_rowij = 0.d0
+ tmp_rowij2 = 0.d0
+ tmp_rowji = 0.d0
+ tmp_rowji2 = 0.d0
+! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
+! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
+ do mm = 1, mo_num
+ hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,p1,pfix)
+ hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
+ hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,pfix)
+ hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,pfix)
+ enddo
+ putj = p2
+ !!
+ do puti=1,mo_num
+ if(lbanned(puti,ma)) cycle
+ putj = p2
+ if(.not. banned(puti,putj,1)) then
+ hij = hij_cache(puti,1)
+ hji = hji_cache(puti,1)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ tmp_rowij(k,puti) = tmp_rowij(k,puti) + hij * coefs(k,2)
+ tmp_rowji(k,puti) = tmp_rowji(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+
+ putj = p1
+ if(.not. banned(puti,putj,1)) then
+ hij = hij_cache(puti,2)
+ hji = hji_cache(puti,2)
+ if (hij /= 0.d0.and.hji/=0.d0) then
+ phase = get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2, N_int)
+ hij = hij * phase
+ hji = hji * phase
+ do k=1,N_states
+ tmp_rowij2(k,puti) = tmp_rowij2(k,puti) + hij * coefs(k,2)
+ tmp_rowji2(k,puti) = tmp_rowji2(k,puti) + hji * coefs(k,1)
+ enddo
+ endif
+ end if
+ end do
+ mat_r(:,:p2-1,p2) = mat_r(:,:p2-1,p2) + tmp_rowij(:,:p2-1)
+ mat_l(:,:p2-1,p2) = mat_l(:,:p2-1,p2) + tmp_rowji(:,:p2-1)
+ do l=p2,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p2,l) = mat_r(k,p2,l) + tmp_rowij(k,l)
+ mat_l(k,p2,l) = mat_l(k,p2,l) + tmp_rowji(k,l)
+ enddo
+ enddo
+ mat_r(:,:p1-1,p1) = mat_r(:,:p1-1,p1) + tmp_rowij2(:,:p1-1)
+ mat_l(:,:p1-1,p1) = mat_l(:,:p1-1,p1) + tmp_rowji2(:,:p1-1)
+ do l=p1,mo_num
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ mat_r(k,p1,l) = mat_r(k,p1,l) + tmp_rowij2(k,l)
+ mat_l(k,p1,l) = mat_l(k,p1,l) + tmp_rowji2(k,l)
+ enddo
+ enddo
+ end if
+ end if
+ deallocate(lbanned,hij_cache, hji_cache)
+
+ !! MONO
+ if(sp == 3) then
+ s1 = 1
+ s2 = 2
+ else
+ s1 = sp
+ s2 = sp
+ end if
+
+ do i1=1,p(0,s1)
+ ib = 1
+ if(s1 == s2) ib = i1+1
+ do i2=ib,p(0,s2)
+ p1 = p(i1,s1)
+ p2 = p(i2,s2)
+ if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle
+ call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int)
+ ! gen is a selector; mask is ionized generator; det is alpha
+ ! hij is contribution to
+! call i_h_j_complex(gen, det, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
+ !DIR$ LOOP COUNT AVG(4)
+ do k=1,N_states
+ ! take conjugate to get contribution to instead of
+! mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,1) * dconjg(hij)
+ mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij
+ mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji
+ enddo
+ end do
+ end do
+end
+
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 0f785ba2..17d34f43 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -694,7 +694,11 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
endif
elseif(nt == 3) then
- call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ if(transpose_two_e_int)then
+ call get_d1_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ else
+ call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ endif
else
if(transpose_two_e_int)then
call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
From 687259c25feb8ec568b31b89b760d2e08d07ad3a Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 7 May 2024 20:32:48 +0200
Subject: [PATCH 130/140] working on the matrix elements both
---
.../local/bi_ort_ints/total_twoe_pot.irp.f | 20 +++
plugins/local/slater_tc/slater_tc_opt.irp.f | 42 ++++++
.../slater_tc/slater_tc_opt_double.irp.f | 60 ++++++++
.../slater_tc/slater_tc_opt_single.irp.f | 142 ++++++++++++++++++
4 files changed, 264 insertions(+)
diff --git a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
index 71269fdc..e27fdb7f 100644
--- a/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
+++ b/plugins/local/bi_ort_ints/total_twoe_pot.irp.f
@@ -332,3 +332,23 @@ END_PROVIDER
! ---
+ BEGIN_PROVIDER [double precision, tc_2e_3idx_coulomb_integrals_transp , (mo_num,mo_num,mo_num)]
+&BEGIN_PROVIDER [double precision, tc_2e_3idx_exchange_integrals_transp, (mo_num,mo_num,mo_num)]
+
+ BEGIN_DOC
+ ! tc_2e_3idx_coulomb_integrals_transp (j,k,i) =
+ ! tc_2e_3idx_exchange_integrals_transp(j,k,i) =
+ END_DOC
+ implicit none
+ integer :: i, j, k
+
+ do i = 1, mo_num
+ do k = 1, mo_num
+ do j = 1, mo_num
+ tc_2e_3idx_coulomb_integrals_transp(j, k,i) = mo_bi_ortho_tc_two_e_transp(j ,k ,j ,i )
+ tc_2e_3idx_exchange_integrals_transp(j,k,i) = mo_bi_ortho_tc_two_e_transp(k ,j ,j ,i )
+ enddo
+ enddo
+ enddo
+
+END_PROVIDER
diff --git a/plugins/local/slater_tc/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f
index 59efc943..9ed2b389 100644
--- a/plugins/local/slater_tc/slater_tc_opt.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt.irp.f
@@ -181,3 +181,45 @@ end
! ---
+subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(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
+ !!
+ ! Returns the detail of the matrix element WITHOUT ANY CONTRIBUTION FROM THE THREE ELECTRON TERMS
+ !! WARNING !!
+ !
+ ! Non hermitian !!
+ !
+ END_DOC
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: htot
+ integer :: degree
+
+ htot = 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_fock_bi_ortho_no_3e(Nint, key_i,htot)
+ else if (degree == 1) then
+ call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , htot)
+ else if(degree == 2) then
+ call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, htot)
+ endif
+
+ if(degree==0) then
+ htot += nuclear_repulsion
+ endif
+
+end
+
+! ---
+
diff --git a/plugins/local/slater_tc/slater_tc_opt_double.irp.f b/plugins/local/slater_tc/slater_tc_opt_double.irp.f
index 4067473c..181ae11d 100644
--- a/plugins/local/slater_tc/slater_tc_opt_double.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_double.irp.f
@@ -505,3 +505,63 @@ subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_j, key_i, htot)
end
+subroutine double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
+
+ BEGIN_DOC
+ ! and 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) :: hji,hij
+ double precision :: hmono, htwoe_ji, htwoe_ij
+ 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
+
+
+ call get_excitation_degree(key_i, key_j, degree, Nint)
+
+ hmono = 0.d0
+ htwoe_ji = 0.d0
+ htwoe_ij = 0.d0
+ hji = 0.d0
+ hij = 0.d0
+
+ if(degree.ne.2)then
+ return
+ endif
+ integer :: degree_i,degree_j
+ call get_excitation_degree(ref_bitmask,key_i,degree_i,N_int)
+ call get_excitation_degree(ref_bitmask,key_j,degree_j,N_int)
+ 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
+ htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
+ htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
+ else
+ ! same spin two-body
+ ! direct terms
+ htwoe_ji = mo_bi_ortho_tc_two_e(p2,p1,h2,h1)
+ htwoe_ij = mo_bi_ortho_tc_two_e_transp(p2,p1,h2,h1)
+ ! exchange terms
+ htwoe_ji -= mo_bi_ortho_tc_two_e(p1,p2,h2,h1)
+ htwoe_ij -= mo_bi_ortho_tc_two_e_transp(p1,p2,h2,h1)
+ endif
+ htwoe_ji *= phase
+ hji = htwoe_ji
+ htwoe_ij *= phase
+ hij = htwoe_ij
+
+end
diff --git a/plugins/local/slater_tc/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
index e57cb05c..3f4e17e2 100644
--- a/plugins/local/slater_tc/slater_tc_opt_single.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
@@ -618,3 +618,145 @@ subroutine get_single_excitation_from_fock_tc_no_3e(Nint, key_i, key_j, h, p, sp
end
+
+subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
+
+ BEGIN_DOC
+ ! and 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) :: hji,hij
+
+ double precision :: hmono, htwoe
+ 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)
+
+ other_spin(1) = 2
+ other_spin(2) = 1
+
+ hmono = 0.d0
+ htwoe = 0.d0
+ hji = 0.d0
+ hji = 0.d0
+ call get_excitation_degree(key_i, key_j, degree, Nint)
+ if(degree.ne.1)then
+ return
+ endif
+ call bitstring_to_list_ab(key_i, occ, Ne, Nint)
+
+ call get_single_excitation(key_i, key_j, exc, phase, Nint)
+ call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
+ call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hji,hij)
+
+end
+
+! ---
+
+subroutine get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h, p, spin, phase, hji,hij)
+
+ use bitmasks
+
+ implicit none
+ integer, intent(in) :: Nint
+ integer, intent(in) :: h, p, spin
+ double precision, intent(in) :: phase
+ integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
+ double precision, intent(out) :: hji,hij
+ double precision :: hmono_ji,htwoe_ji
+ double precision :: hmono_ij,htwoe_ij
+
+ integer(bit_kind) :: differences(Nint,2)
+ integer(bit_kind) :: hole(Nint,2)
+ integer(bit_kind) :: partcl(Nint,2)
+ integer :: occ_hole(Nint*bit_kind_size,2)
+ integer :: occ_partcl(Nint*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ double precision :: buffer_c_ji(mo_num), buffer_x_ji(mo_num)
+ double precision :: buffer_c_ij(mo_num), buffer_x_ij(mo_num)
+
+ do i = 1, mo_num
+ buffer_c_ji(i) = tc_2e_3idx_coulomb_integrals(i,p,h)
+ buffer_x_ji(i) = tc_2e_3idx_exchange_integrals(i,p,h)
+ buffer_c_ij(i) = tc_2e_3idx_coulomb_integrals_transp(i,p,h)
+ buffer_x_ij(i) = tc_2e_3idx_exchange_integrals_transp(i,p,h)
+ enddo
+
+ do i = 1, Nint
+ differences(i,1) = xor(key_i(i,1),ref_closed_shell_bitmask(i,1))
+ differences(i,2) = xor(key_i(i,2),ref_closed_shell_bitmask(i,2))
+ hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+ hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+ partcl(i,1) = iand(differences(i,1),key_i(i,1))
+ partcl(i,2) = iand(differences(i,2),key_i(i,2))
+ enddo
+
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, Nint)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, Nint)
+ hmono_ji = mo_bi_ortho_tc_one_e(p,h)
+ htwoe_ji = fock_op_2_e_tc_closed_shell(p,h)
+ hmono_ij = mo_bi_ortho_tc_one_e(h,p)
+ htwoe_ij = fock_op_2_e_tc_closed_shell(h,p)
+
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+ i = occ_hole(i0,1)
+ htwoe_ji -= buffer_c_ji(i)
+ htwoe_ij -= buffer_c_ij(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+ i = occ_hole(i0,2)
+ htwoe_ji -= buffer_c_ji(i)
+ htwoe_ij -= buffer_c_ij(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+ i = occ_hole(i0,spin)
+ htwoe_ji += buffer_x_ji(i)
+ htwoe_ij += buffer_x_ij(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+ i = occ_partcl(i0,1)
+ htwoe_ji += buffer_c_ji(i)
+ htwoe_ij += buffer_c_ij(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+ i = occ_partcl(i0,2)
+ htwoe_ji += buffer_c_ji(i)
+ htwoe_ij += buffer_c_ij(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+ i = occ_partcl(i0,spin)
+ htwoe_ji -= buffer_x_ji(i)
+ htwoe_ij -= buffer_x_ij(i)
+ enddo
+ htwoe_ji = htwoe_ji * phase
+ hmono_ji = hmono_ji * phase
+ hji = htwoe_ji + hmono_ji
+
+ htwoe_ij = htwoe_ij * phase
+ hmono_ij = hmono_ij * phase
+ hij = htwoe_ij + hmono_ij
+
+end
+
From 42fdb3c4350c0452a7169614ff9dba4e0e381f62 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 7 May 2024 20:52:10 +0200
Subject: [PATCH 131/140] it works with new routines for pt2 tc
---
.../cipsi_tc_bi_ortho/get_d0_transp.irp.f | 54 ++++---------------
.../cipsi_tc_bi_ortho/get_d1_transp.irp.f | 4 +-
plugins/local/slater_tc/slater_tc_opt.irp.f | 17 +++---
.../slater_tc/slater_tc_opt_single.irp.f | 4 +-
4 files changed, 25 insertions(+), 54 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
index 56238e13..f149e7c6 100644
--- a/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d0_transp.irp.f
@@ -45,33 +45,16 @@ subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
! call i_h_j_complex(det, gen, N_int, hij)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
else
phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
hij = hij_cache1(p2) * phase
+ hji = hji_cache1(p2) * phase
end if
- if (hij == (0.d0,0.d0)) cycle
+ if (hij == 0.d0.or.hji == 0.d0) cycle
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, p1, p2) = mat_r(k, p1, p2) + coefs(k,2) * hij ! HOTSPOT
- enddo
- end do
- !!!!!!!!!!
- do p2=1, mo_num
- if(bannedOrb(p2,2)) cycle
- if(banned(p1, p2, bant)) cycle ! rentable?
- if(p1 == h1 .or. p2 == h2) then
- call apply_particles(mask, 1,p1,2,p2, det, ok, N_int)
- ! call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
-! call i_h_j_complex(det, gen, N_int, hij)
- call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
- else
- phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2, N_int)
- hji = hji_cache1(p2) * phase
- end if
- if (hji == (0.d0,0.d0)) cycle
- !DIR$ LOOP COUNT AVG(4)
- do k=1,N_states
mat_l(k, p1, p2) = mat_l(k, p1, p2) + coefs(k,1) * hji ! HOTSPOT
enddo
end do
@@ -98,40 +81,25 @@ subroutine get_d0_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
!call i_h_j_complex(gen, det, N_int, hij) ! need to take conjugate of this
! call i_h_j_complex(det, gen, N_int, hij)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det,gen,N_int, hij)
- if (hij == 0.d0) cycle
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det,gen,N_int, hij,hji)
+ if (hij == 0.d0.or.hji == 0.d0) cycle
else
! hij = (mo_two_e_integral_complex(p1, p2, puti, putj) - mo_two_e_integral_complex(p2, p1, puti, putj))
! hij = (mo_bi_ortho_tc_two_e(p1, p2, puti, putj) - mo_bi_ortho_tc_two_e(p2, p1, puti, putj))
hij = (mo_bi_ortho_tc_two_e(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e(puti, putj, p2, p1))
- if (hij == 0.d0) cycle
- hij = (hij) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
+ hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2) - mo_bi_ortho_tc_two_e_transp(puti, putj, p2, p1))
+ if (hij == 0.d0.or.hji == 0.d0) cycle
+ phase = get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
+ hij = (hij) * phase
+ hji = (hji) * phase
end if
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
mat_r(k, puti, putj) = mat_r(k, puti, putj) + coefs(k,2) * hij
- enddo
- end do
-
- !!!!!!!!!!
- do putj=puti+1, mo_num
- if(bannedOrb(putj, sp)) cycle
- if(banned(puti, putj, bant)) cycle ! rentable?
- if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then
- call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int)
- call htilde_mu_mat_opt_bi_ortho_no_3e(gen,det,N_int, hji)
- if (hji == 0.d0) cycle
- else
-! hji = (mo_bi_ortho_tc_two_e( p1, p2, puti, putj) - mo_bi_ortho_tc_two_e( p2, p1, puti, putj))
- hji = (mo_bi_ortho_tc_two_e_transp(puti, putj, p1, p2 ) - mo_bi_ortho_tc_two_e_transp( puti, putj, p2, p1))
- if (hji == 0.d0) cycle
- hji = (hji) * get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2, N_int)
- end if
- !DIR$ LOOP COUNT AVG(4)
- do k=1,N_states
mat_l(k, puti, putj) = mat_l(k, puti, putj) + coefs(k,1) * hji
enddo
end do
+
end do
end if
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
index 3c6cbf60..84a1ce24 100644
--- a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
@@ -335,8 +335,8 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
! gen is a selector; mask is ionized generator; det is alpha
! hij is contribution to
! call i_h_j_complex(gen, det, N_int, hij)
- call htilde_mu_mat_opt_bi_ortho_no_3e(det, gen, N_int, hij)
- call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
+ call htilde_mu_mat_opt_bi_ortho_no_3e_both(det, gen, N_int, hij,hji)
+! call htilde_mu_mat_opt_bi_ortho_no_3e(gen, det, N_int, hji)
!DIR$ LOOP COUNT AVG(4)
do k=1,N_states
! take conjugate to get contribution to instead of
diff --git a/plugins/local/slater_tc/slater_tc_opt.irp.f b/plugins/local/slater_tc/slater_tc_opt.irp.f
index 9ed2b389..5651a299 100644
--- a/plugins/local/slater_tc/slater_tc_opt.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt.irp.f
@@ -181,7 +181,7 @@ end
! ---
-subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, htot)
+subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, hji,hij)
BEGIN_DOC
!
@@ -199,24 +199,27 @@ subroutine htilde_mu_mat_opt_bi_ortho_no_3e_both(key_j, key_i, Nint, htot)
implicit none
integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2)
- double precision, intent(out) :: htot
+ double precision, intent(out) :: hji,hij
integer :: degree
- htot = 0.d0
+ hji = 0.d0
+ hij = 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_fock_bi_ortho_no_3e(Nint, key_i,htot)
+ call diag_htilde_mu_mat_fock_bi_ortho_no_3e(Nint, key_i,hji)
+ hij = hji
else if (degree == 1) then
- call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , htot)
+ call single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint,key_j, key_i , hji,hij)
else if(degree == 2) then
- call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, htot)
+ call double_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hji,hij)
endif
if(degree==0) then
- htot += nuclear_repulsion
+ hji += nuclear_repulsion
+ hij += nuclear_repulsion
endif
end
diff --git a/plugins/local/slater_tc/slater_tc_opt_single.irp.f b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
index 3f4e17e2..47bcbe34 100644
--- a/plugins/local/slater_tc/slater_tc_opt_single.irp.f
+++ b/plugins/local/slater_tc/slater_tc_opt_single.irp.f
@@ -652,7 +652,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hj
hmono = 0.d0
htwoe = 0.d0
hji = 0.d0
- hji = 0.d0
+ hij = 0.d0
call get_excitation_degree(key_i, key_j, degree, Nint)
if(degree.ne.1)then
return
@@ -661,7 +661,7 @@ subroutine single_htilde_mu_mat_fock_bi_ortho_no_3e_both(Nint, key_j, key_i, hj
call get_single_excitation(key_i, key_j, exc, phase, Nint)
call decode_exc(exc,1,h1,p1,h2,p2,s1,s2)
- call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hmono, htwoe, hji,hij)
+ call get_single_excitation_from_fock_tc_no_3e_both(Nint, key_i, key_j, h1, p1, s1, phase, hji,hij)
end
From a38bf00975365cc755fc7c8c24e9e74c02cd2a00 Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 8 May 2024 17:26:48 +0200
Subject: [PATCH 132/140] updated default keywords in tc_keywords and
ao_twoe_e_ints
---
.../cipsi_tc_bi_ortho/get_d1_transp.irp.f | 34 ++++++++++++-------
plugins/local/cipsi_tc_bi_ortho/pt2.irp.f | 3 ++
.../local/cipsi_tc_bi_ortho/selection.irp.f | 6 ++--
.../cipsi_tc_bi_ortho/stochastic_cipsi.irp.f | 2 +-
.../local/tc_bi_ortho/diagonalize_tc_h.irp.f | 34 +++++++++----------
plugins/local/tc_keywords/EZFIO.cfg | 4 +--
src/ao_two_e_ints/EZFIO.cfg | 6 ++--
7 files changed, 49 insertions(+), 40 deletions(-)
diff --git a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
index 84a1ce24..a3d7b076 100644
--- a/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/get_d1_transp.irp.f
@@ -16,7 +16,7 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
logical :: ok
logical, allocatable :: lbanned(:,:)
- integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j
+ integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, istate
integer :: hfix, pfix, h1, h2, p1, p2, ib, k, l, mm
integer, parameter :: turn2(2) = (/2,1/)
@@ -65,10 +65,12 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ do istate = 1,N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ enddo
enddo
!!
- tmp_rowij = 0.d0
- tmp_rowji = 0.d0
do putj=1, hfix-1
if(lbanned(putj, ma)) cycle
if(banned(putj, puti,bant)) cycle
@@ -119,13 +121,15 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
!MOVE MI
pfix = p(1,mi)
- tmp_rowij = 0.d0
- tmp_rowij2 = 0.d0
- tmp_rowji = 0.d0
- tmp_rowji2 = 0.d0
! call get_mo_two_e_integrals_complex(hfix,pfix,p1,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,pfix,p2,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
+ do istate = 1,N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowij2(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ tmp_rowji2(istate,mm) = 0.d0
+ enddo
hij_cache(mm,1) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p1)
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,pfix,p2)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,pfix,p1)
@@ -200,10 +204,12 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,p1)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,p2)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,p1)
+ do istate = 1, N_states
+ tmp_rowij(istate,mm) = 0.d0
+ tmp_rowji(istate,mm) = 0.d0
+ enddo
enddo
!!
- tmp_rowij = 0.d0
- tmp_rowji = 0.d0
do putj=1,hfix-1
if(banned(putj,puti,1)) cycle
if(lbanned(putj,ma)) cycle
@@ -246,10 +252,6 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
pfix = p(1,mi)
p1 = p(1,ma)
p2 = p(2,ma)
- tmp_rowij = 0.d0
- tmp_rowij2 = 0.d0
- tmp_rowji = 0.d0
- tmp_rowji2 = 0.d0
! call get_mo_two_e_integrals_complex(hfix,p1,pfix,mo_num,hij_cache(1,1),mo_integrals_map,mo_integrals_map_2)
! call get_mo_two_e_integrals_complex(hfix,p2,pfix,mo_num,hij_cache(1,2),mo_integrals_map,mo_integrals_map_2)
do mm = 1, mo_num
@@ -257,6 +259,12 @@ subroutine get_d1_transp(gen, phasemask, bannedOrb, banned, mat_l, mat_r, mask,
hij_cache(mm,2) = mo_bi_ortho_tc_two_e(mm,hfix,p2,pfix)
hji_cache(mm,1) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p1,pfix)
hji_cache(mm,2) = mo_bi_ortho_tc_two_e_transp(mm,hfix,p2,pfix)
+ do istate = 1,N_states
+ tmp_rowij (istate,mm) = 0.d0
+ tmp_rowij2(istate,mm) = 0.d0
+ tmp_rowji (istate,mm) = 0.d0
+ tmp_rowji2(istate,mm) = 0.d0
+ enddo
enddo
putj = p2
!!
diff --git a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
index ada19c6b..22381991 100644
--- a/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/pt2.irp.f
@@ -65,6 +65,9 @@ subroutine tc_pt2
call pt2_dealloc(pt2_data_err)
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
+ if(transpose_two_e_int)then
+ provide mo_bi_ortho_tc_two_e_transp tc_2e_3idx_coulomb_integrals_transp
+ endif
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,0) ! Stochastic PT2 and selection
call diagonalize_CI_tc_bi_ortho(ndet, E_tc,norm,pt2_data,print_pt2)
call print_summary_tc(psi_energy_with_nucl_rep, pt2_data, pt2_data_err, N_det, N_configuration, N_states, psi_s2)
diff --git a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
index 17d34f43..72ccf9c4 100644
--- a/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/selection.irp.f
@@ -691,19 +691,19 @@ subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, intere
if(transpose_two_e_int)then
call get_d2_new_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
else
- call get_d2_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ call get_d2_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
endif
elseif(nt == 3) then
if(transpose_two_e_int)then
call get_d1_transp(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
else
- call get_d1_new(det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ call get_d1_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
endif
else
if(transpose_two_e_int)then
call get_d0_transp (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
else
- call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
+ call get_d0_new (det(1,1,i), phasemask, bannedOrb, banned, mat_l, mat_r, mask, h, p, sp, psi_selectors_coef_transp_tc(1, 1, interesting(i)))
endif
endif
elseif(nt == 4) then
diff --git a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
index bb5a89a1..e363830d 100644
--- a/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
+++ b/plugins/local/cipsi_tc_bi_ortho/stochastic_cipsi.irp.f
@@ -89,7 +89,7 @@ subroutine run_stochastic_cipsi
call pt2_alloc(pt2_data, N_states)
call pt2_alloc(pt2_data_err, N_states)
if(transpose_two_e_int)then
- provide mo_bi_ortho_tc_two_e_transp
+ provide mo_bi_ortho_tc_two_e_transp tc_2e_3idx_coulomb_integrals_transp
endif
call ZMQ_pt2(E_tc, pt2_data, pt2_data_err, relative_error,to_select) ! Stochastic PT2 and selection
! stop
diff --git a/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f b/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f
index 398e96db..03388898 100644
--- a/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f
+++ b/plugins/local/tc_bi_ortho/diagonalize_tc_h.irp.f
@@ -35,8 +35,8 @@ program tc_bi_ortho
print*, ' nb of det = ', N_det
call routine_diag()
- call write_tc_energy()
- call save_tc_bi_ortho_wavefunction()
+! call write_tc_energy()
+! call save_tc_bi_ortho_wavefunction()
end
@@ -76,28 +76,26 @@ subroutine routine_diag()
PROVIDE noL_2e
endif
- PROVIDE htilde_matrix_elmt_bi_ortho
- return
if(N_states .eq. 1) then
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_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
- print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
- print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
- print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
- print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
+! 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_bi_orth_proj_abs = ',e_corr_bi_orth_proj_abs
+! print*,'e_corr_single_bi_orth = ',e_corr_single_bi_orth
+! print*,'e_corr_double_bi_orth = ',e_corr_double_bi_orth
+! print*,'e_corr_single_bi_orth_abs = ',e_corr_single_bi_orth_abs
+! print*,'e_corr_double_bi_orth_abs = ',e_corr_double_bi_orth_abs
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),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
+ write(*,'(I6,X,(100(F12.7,X)))')i,leigvec_tc_bi_orth(i,1),reigvec_tc_bi_orth(i,1),leigvec_tc_bi_orth(i,1)*reigvec_tc_bi_orth(i,1)
enddo
else
diff --git a/plugins/local/tc_keywords/EZFIO.cfg b/plugins/local/tc_keywords/EZFIO.cfg
index 39968ec8..d764224a 100644
--- a/plugins/local/tc_keywords/EZFIO.cfg
+++ b/plugins/local/tc_keywords/EZFIO.cfg
@@ -14,7 +14,7 @@ default: False
type: logical
doc: If |true|, three-body terms are included
interface: ezfio,provider,ocaml
-default: True
+default: False
[three_e_3_idx_term]
type: logical
@@ -50,7 +50,7 @@ default: False
type: logical
doc: If |true|, standard normal-ordering for L (to be used with three_body_h_tc |false|)
interface: ezfio,provider,ocaml
-default: False
+default: True
[core_tc_op]
type: logical
diff --git a/src/ao_two_e_ints/EZFIO.cfg b/src/ao_two_e_ints/EZFIO.cfg
index ff932b0c..c2e083a3 100644
--- a/src/ao_two_e_ints/EZFIO.cfg
+++ b/src/ao_two_e_ints/EZFIO.cfg
@@ -25,16 +25,16 @@ default: 1.e-12
[do_direct_integrals]
type: logical
-doc: Compute integrals on the fly (very slow, only for debugging)
+doc: Compute integrals on the fly (Useful only for Cholesky decomposition)
interface: ezfio,provider,ocaml
-default: False
+default: True
ezfio_name: direct
[do_ao_cholesky]
type: logical
doc: Perform Cholesky decomposition of AO integrals
interface: ezfio,provider,ocaml
-default: False
+default: True
[io_ao_two_e_integrals_erf]
type: Disk_access
From 2af293fd291481896cd5114df6f653ca0f04f797 Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 8 May 2024 17:38:54 +0200
Subject: [PATCH 133/140] minor modifs in BH jastrows
---
.../local/non_h_ints_mu/jast_deriv_utils_vect.irp.f | 13 ++++++++-----
1 file changed, 8 insertions(+), 5 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index db06e835..09bb6528 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -340,8 +340,8 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
endif
tmp1 = double_p(mpA) * f1A_power(mpA-1) * f2A_power(npA) + double_p(npA) * f1A_power(npA-1) * f2A_power(mpA)
- tmp1 = tmp1 * g12_power(opA)
- tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA))
+ tmp1 = tmp1 * g12_power(opA) * tmp
+ tmp2 = double_p(opA) * g12_power(opA-1) * (f1A_power(mpA) * f2A_power(npA) + f1A_power(npA) * f2A_power(mpA)) * tmp
!tmp1 = 0.d0
!if(mpA .gt. 0) then
@@ -356,9 +356,12 @@ subroutine grad1_j12_r1_seq(r1, n_grid2, gradx, grady, gradz)
! tmp2 = tmp2 + dble(opA) * g12**dble(opA-1) * (f1A**dble(mpA) * f2A**dble(npA) + f1A**dble(npA) * f2A**dble(mpA))
!endif
- gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
- grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
- gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
+! gradx(jpoint) = gradx(jpoint) + tmp * (tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1))
+! grady(jpoint) = grady(jpoint) + tmp * (tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2))
+! gradz(jpoint) = gradz(jpoint) + tmp * (tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3))
+ gradx(jpoint) = gradx(jpoint) + tmp1 * grad1_f1A(1) + tmp2 * grad1_g12(1)
+ grady(jpoint) = grady(jpoint) + tmp1 * grad1_f1A(2) + tmp2 * grad1_g12(2)
+ gradz(jpoint) = gradz(jpoint) + tmp1 * grad1_f1A(3) + tmp2 * grad1_g12(3)
enddo ! p
enddo ! i_nucl
enddo ! jpoint
From 812e75982b96959485b8f7ccd333ef3a1b1b570b Mon Sep 17 00:00:00 2001
From: eginer
Date: Fri, 10 May 2024 17:23:51 +0200
Subject: [PATCH 134/140] minor modifs in
plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
---
.../non_h_ints_mu/jast_deriv_utils_vect.irp.f | 17 +++++++++--------
1 file changed, 9 insertions(+), 8 deletions(-)
diff --git a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
index 09bb6528..2c41b535 100644
--- a/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
+++ b/plugins/local/non_h_ints_mu/jast_deriv_utils_vect.irp.f
@@ -867,19 +867,20 @@ subroutine jBH_elem_fct_grad(alpha, r1, r2, fct, grad1_fct)
+ (r1(2) - r2(2)) * (r1(2) - r2(2)) &
+ (r1(3) - r2(3)) * (r1(3) - r2(3)) )
- tmp1 = 1.d0 / (1.d0 + alpha * dist)
- fct = alpha * dist * tmp1
-
- if(dist .lt. 1d-10) then
- grad1_fct(1) = 0.d0
- grad1_fct(2) = 0.d0
- grad1_fct(3) = 0.d0
- else
+ if(dist .ge. 1d-10) then
+ tmp1 = 1.d0 / (1.d0 + alpha * dist)
+
+ fct = alpha * dist * tmp1
tmp2 = alpha * tmp1 * tmp1 / dist
grad1_fct(1) = tmp2 * (r1(1) - r2(1))
grad1_fct(2) = tmp2 * (r1(2) - r2(2))
grad1_fct(3) = tmp2 * (r1(3) - r2(3))
+ else
+ grad1_fct(1) = 0.d0
+ grad1_fct(2) = 0.d0
+ grad1_fct(3) = 0.d0
+ fct = 0.d0
endif
return
From 8eea5d7f7f142103998d8bfa1b3bcc630935f69b Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 15 May 2024 15:41:35 +0200
Subject: [PATCH 135/140] fixed a bug in cholesk_ao_transp
---
.../tuto_plugins/tuto_I/test_cholesky.irp.f | 53 +++++++++++++++++++
src/ao_two_e_ints/cholesky.irp.f | 2 +-
2 files changed, 54 insertions(+), 1 deletion(-)
create mode 100644 plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f
diff --git a/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f b/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f
new file mode 100644
index 00000000..d09d100a
--- /dev/null
+++ b/plugins/local/tuto_plugins/tuto_I/test_cholesky.irp.f
@@ -0,0 +1,53 @@
+program my_program_to_print_stuffs
+ implicit none
+ BEGIN_DOC
+! TODO : Put the documentation of the program here
+ END_DOC
+ integer :: i,j,k,l,m
+ double precision :: integral, accu, accu_tot, integral_cholesky
+ double precision :: get_ao_two_e_integral, get_two_e_integral ! declaration of the functions
+ print*,'AO integrals, physicist notations : '
+ accu_tot = 0.D0
+ do i = 1, ao_num
+ do j = 1, ao_num
+ do k = 1, ao_num
+ do l = 1, ao_num
+ integral = get_ao_two_e_integral(i, j, k, l, ao_integrals_map)
+ integral_cholesky = 0.D0
+ do m = 1, cholesky_ao_num
+ integral_cholesky += cholesky_ao_transp(m,i,k) * cholesky_ao_transp(m,j,l)
+ enddo
+ accu = dabs(integral_cholesky-integral)
+ accu_tot += accu
+ if(accu.gt.1.d-10)then
+ print*,i,j,k,l
+ print*,accu, integral, integral_cholesky
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ print*,'accu_tot',accu_tot
+
+ print*,'MO integrals, physicist notations : '
+ do i = 1, mo_num
+ do j = 1, mo_num
+ do k = 1, mo_num
+ do l = 1, mo_num
+ integral = get_two_e_integral(i, j, k, l, mo_integrals_map)
+ accu = 0.D0
+ integral_cholesky = 0.D0
+ do m = 1, cholesky_mo_num
+ integral_cholesky += cholesky_mo_transp(m,i,k) * cholesky_mo_transp(m,j,l)
+ enddo
+ accu = dabs(integral_cholesky-integral)
+ accu_tot += accu
+ if(accu.gt.1.d-10)then
+ print*,i,j,k,l
+ print*,accu, integral, integral_cholesky
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+end
diff --git a/src/ao_two_e_ints/cholesky.irp.f b/src/ao_two_e_ints/cholesky.irp.f
index 33304026..5fbd166c 100644
--- a/src/ao_two_e_ints/cholesky.irp.f
+++ b/src/ao_two_e_ints/cholesky.irp.f
@@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, cholesky_ao_transp, (cholesky_ao_num, ao_num,
integer :: i,j,k
do j=1,ao_num
do i=1,ao_num
- do k=1,ao_num
+ do k=1,cholesky_ao_num
cholesky_ao_transp(k,i,j) = cholesky_ao(i,j,k)
enddo
enddo
From c6a61639445229eca3ecb2e32556ddef646064d6 Mon Sep 17 00:00:00 2001
From: eginer
Date: Thu, 16 May 2024 17:57:00 +0200
Subject: [PATCH 136/140] added f_hf with cholesky by default
---
src/dft_utils_in_r/mo_in_r.irp.f | 2 +-
src/mu_of_r/f_cholesky.irp.f | 221 +++++++++++++++++++++++++++
src/mu_of_r/mu_of_r_conditions.irp.f | 46 +++++-
3 files changed, 264 insertions(+), 5 deletions(-)
create mode 100644 src/mu_of_r/f_cholesky.irp.f
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..ad931402 100644
--- a/src/dft_utils_in_r/mo_in_r.irp.f
+++ b/src/dft_utils_in_r/mo_in_r.irp.f
@@ -48,7 +48,7 @@
integer :: i,j
do i = 1, n_points_final_grid
do j = 1, mo_num
- mos_in_r_array_transp(i,j) = mos_in_r_array(j,i)
+ mos_in_r_array_transp(i,j) = mos_in_r_array_omp(j,i)
enddo
enddo
END_PROVIDER
diff --git a/src/mu_of_r/f_cholesky.irp.f b/src/mu_of_r/f_cholesky.irp.f
new file mode 100644
index 00000000..1ad4ce36
--- /dev/null
+++ b/src/mu_of_r/f_cholesky.irp.f
@@ -0,0 +1,221 @@
+BEGIN_PROVIDER [integer, list_couple_orb_r1, (2,n_couple_orb_r1)]
+ implicit none
+ integer :: ii,i,mm,m,itmp
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ list_couple_orb_r1(1,itmp) = i
+ list_couple_orb_r1(2,itmp) = m
+ enddo
+ enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer, list_couple_orb_r2, (2,n_couple_orb_r2)]
+ implicit none
+ integer :: ii,i,mm,m,itmp
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ list_couple_orb_r2(1,itmp) = i
+ list_couple_orb_r2(2,itmp) = m
+ enddo
+ enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer, n_couple_orb_r1]
+ implicit none
+ BEGIN_DOC
+ ! number of couples of alpha occupied times any basis orbital
+ END_DOC
+ n_couple_orb_r1 = n_occ_val_orb_for_hf(1) * n_basis_orb
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, n_couple_orb_r2]
+ implicit none
+ BEGIN_DOC
+ ! number of couples of beta occupied times any basis orbital
+ END_DOC
+ n_couple_orb_r2 = n_occ_val_orb_for_hf(2) * n_basis_orb
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mos_times_cholesky_r1, (cholesky_mo_num,n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! V1_AR = \sum_{I}V_AI Phi_IR where "R" specifies the index of the grid point and A the number of cholesky point
+ !
+ ! here Phi_IR is phi_i(R)xphi_b(R) for r1 and V_AI = (ib|A) chollesky vector
+ END_DOC
+ double precision, allocatable :: mos_ib_r1(:,:),mo_chol_r1(:,:)
+ double precision, allocatable :: test(:,:)
+ double precision :: mo_i_r1,mo_b_r1
+ integer :: ii,i,mm,m,itmp,ipoint,ll
+ allocate(mos_ib_r1(n_couple_orb_r1,n_points_final_grid))
+ allocate(mo_chol_r1(cholesky_mo_num,n_couple_orb_r1))
+
+ do ipoint = 1, n_points_final_grid
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ mo_i_r1 = mos_in_r_array_omp(i,ipoint)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ mo_b_r1 = mos_in_r_array_omp(m,ipoint)
+ itmp += 1
+ mos_ib_r1(itmp,ipoint) = mo_i_r1 * mo_b_r1
+ enddo
+ enddo
+ enddo
+
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ do ll = 1, cholesky_mo_num
+ mo_chol_r1(ll,itmp) = cholesky_mo_transp(ll,m,i)
+ enddo
+ enddo
+ enddo
+
+ call get_AB_prod(mo_chol_r1,cholesky_mo_num,n_couple_orb_r1,mos_ib_r1,n_points_final_grid,mos_times_cholesky_r1)
+ allocate(test(cholesky_mo_num,n_points_final_grid))
+ test = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do itmp = 1, n_couple_orb_r1
+ i = list_couple_orb_r1(1,itmp)
+ m = list_couple_orb_r1(2,itmp)
+ mo_i_r1 = mos_in_r_array_omp(i,ipoint)
+ mo_b_r1 = mos_in_r_array_omp(m,ipoint)
+ do mm = 1, cholesky_mo_num
+ test(mm,ipoint) += mo_i_r1 * mo_b_r1 * mo_chol_r1(mm,itmp)
+ enddo
+ enddo
+ enddo
+ double precision :: accu
+ accu = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do mm = 1, cholesky_mo_num
+ accu += dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint) )
+ if(dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint)).gt.1.d-10)then
+ print*,'problem ! ',dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint)) &
+ , mos_times_cholesky_r1(mm,ipoint) , test(mm,ipoint)
+ endif
+ enddo
+ enddo
+ print*,'accu = ',accu
+
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mos_times_cholesky_r2, (cholesky_mo_num,n_points_final_grid)]
+ implicit none
+ BEGIN_DOC
+ ! V1_AR = \sum_{I}V_AI Phi_IR where "R" specifies the index of the grid point and A the number of cholesky point
+ !
+ ! here Phi_IR is phi_i(R)xphi_b(R) for r2 and V_AI = (ib|A) chollesky vector
+ END_DOC
+ double precision, allocatable :: mos_ib_r2(:,:),mo_chol_r2(:,:)
+ double precision, allocatable :: test(:,:)
+ double precision :: mo_i_r2,mo_b_r2
+ integer :: ii,i,mm,m,itmp,ipoint,ll
+ allocate(mos_ib_r2(n_couple_orb_r2,n_points_final_grid))
+ allocate(mo_chol_r2(cholesky_mo_num,n_couple_orb_r2))
+
+ do ipoint = 1, n_points_final_grid
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ mo_i_r2 = mos_in_r_array_omp(i,ipoint)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ mo_b_r2 = mos_in_r_array_omp(m,ipoint)
+ itmp += 1
+ mos_ib_r2(itmp,ipoint) = mo_i_r2 * mo_b_r2
+ enddo
+ enddo
+ enddo
+
+ itmp = 0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ do mm = 1, n_basis_orb ! electron 1
+ m = list_basis(mm)
+ itmp += 1
+ do ll = 1, cholesky_mo_num
+ mo_chol_r2(ll,itmp) = cholesky_mo_transp(ll,m,i)
+ enddo
+ enddo
+ enddo
+
+ call get_AB_prod(mo_chol_r2,cholesky_mo_num,n_couple_orb_r2,mos_ib_r2,n_points_final_grid,mos_times_cholesky_r2)
+ allocate(test(cholesky_mo_num,n_points_final_grid))
+ test = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do itmp = 1, n_couple_orb_r2
+ i = list_couple_orb_r2(1,itmp)
+ m = list_couple_orb_r2(2,itmp)
+ mo_i_r2 = mos_in_r_array_omp(i,ipoint)
+ mo_b_r2 = mos_in_r_array_omp(m,ipoint)
+ do mm = 1, cholesky_mo_num
+ test(mm,ipoint) += mo_i_r2 * mo_b_r2 * mo_chol_r2(mm,itmp)
+ enddo
+ enddo
+ enddo
+ double precision :: accu
+ accu = 0.d0
+ do ipoint = 1, n_points_final_grid
+ do mm = 1, cholesky_mo_num
+ accu += dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint) )
+ if(dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint)).gt.1.d-10)then
+ print*,'problem ! ',dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint)) &
+ , mos_times_cholesky_r2(mm,ipoint) , test(mm,ipoint)
+ endif
+ enddo
+ enddo
+ print*,'accu = ',accu
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ double precision, f_hf_cholesky, (n_points_final_grid)]
+ implicit none
+ integer :: ipoint
+ !!f(R) = \sum_{I} \sum_{J} Phi_I(R) Phi_J(R) V_IJ
+ !! = \sum_{I}\sum_{J}\sum_A Phi_I(R) Phi_J(R) V_AI V_AJ
+ !! = \sum_A \sum_{I}Phi_I(R)V_AI \sum_{J}V_AJ Phi_J(R)
+ !! = \sum_A V_AR G_AR
+ !! V_AR = \sum_{I}Phi_IR V_AI = \sum_{I}Phi^t_RI V_AI
+ double precision :: u_dot_v
+ do ipoint = 1, n_points_final_grid
+ f_hf_cholesky(ipoint) = 2.D0 * u_dot_v(mos_times_cholesky_r2(1,ipoint),mos_times_cholesky_r1(1,ipoint),cholesky_mo_num)
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, on_top_hf_grid, (n_points_final_grid)]
+ implicit none
+ integer :: ipoint,i,ii
+ double precision :: dm_a, dm_b
+ do ipoint = 1, n_points_final_grid
+ dm_a = 0.d0
+ do ii = 1, n_occ_val_orb_for_hf(1)
+ i = list_valence_orb_for_hf(ii,1)
+ dm_a += mos_in_r_array_omp(i,ipoint)*mos_in_r_array_omp(i,ipoint)
+ enddo
+ dm_b = 0.d0
+ do ii = 1, n_occ_val_orb_for_hf(2)
+ i = list_valence_orb_for_hf(ii,2)
+ dm_b += mos_in_r_array_omp(i,ipoint)*mos_in_r_array_omp(i,ipoint)
+ enddo
+ on_top_hf_grid(ipoint) = 2.D0 * dm_a*dm_b
+ enddo
+END_PROVIDER
+
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 6b49b9df..5b4d4b83 100644
--- a/src/mu_of_r/mu_of_r_conditions.irp.f
+++ b/src/mu_of_r/mu_of_r_conditions.irp.f
@@ -61,7 +61,7 @@
END_DOC
integer :: ipoint
double precision :: wall0,wall1,f_hf,on_top,w_hf,sqpi
- PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
+ PROVIDE f_hf_cholesky on_top_hf_grid
print*,'providing mu_of_r_hf ...'
call wall_time(wall0)
sqpi = dsqrt(dacos(-1.d0))
@@ -69,10 +69,10 @@
!$OMP PARALLEL DO &
!$OMP DEFAULT (NONE) &
!$OMP PRIVATE (ipoint,f_hf,on_top,w_hf) &
- !$OMP ShARED (n_points_final_grid,mu_of_r_hf,f_psi_hf_ab,on_top_hf_mu_r,sqpi)
+ !$OMP ShARED (n_points_final_grid,mu_of_r_hf,f_hf_cholesky,on_top_hf_grid,sqpi)
do ipoint = 1, n_points_final_grid
- f_hf = f_psi_hf_ab(ipoint)
- on_top = on_top_hf_mu_r(ipoint)
+ f_hf = f_hf_cholesky(ipoint)
+ on_top = on_top_hf_grid(ipoint)
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
@@ -85,6 +85,44 @@
print*,'Time to provide mu_of_r_hf = ',wall1-wall0
END_PROVIDER
+ BEGIN_PROVIDER [double precision, mu_of_r_hf_old, (n_points_final_grid) ]
+ implicit none
+ BEGIN_DOC
+ ! mu(r) computed with a HF wave function (assumes that HF MOs are stored in the EZFIO)
+ !
+ ! corresponds to Eq. (37) of J. Chem. Phys. 149, 194301 (2018) but for \Psi^B = HF^B
+ !
+ ! !!!!!! WARNING !!!!!! if no_core_density == .True. then all contributions from the core orbitals
+ !
+ ! in the two-body density matrix are excluded
+ END_DOC
+ integer :: ipoint
+ double precision :: wall0,wall1,f_hf,on_top,w_hf,sqpi
+ PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals
+ print*,'providing mu_of_r_hf_old ...'
+ call wall_time(wall0)
+ sqpi = dsqrt(dacos(-1.d0))
+ provide f_psi_hf_ab
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,f_hf,on_top,w_hf) &
+ !$OMP ShARED (n_points_final_grid,mu_of_r_hf_old,f_psi_hf_ab,on_top_hf_mu_r,sqpi)
+ do ipoint = 1, n_points_final_grid
+ f_hf = f_psi_hf_ab(ipoint)
+ on_top = on_top_hf_mu_r(ipoint)
+ 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_of_r_hf_old(ipoint) = w_hf * sqpi * 0.5d0
+ enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide mu_of_r_hf_old = ',wall1-wall0
+ END_PROVIDER
+
+
BEGIN_PROVIDER [double precision, mu_of_r_psi_cas, (n_points_final_grid,N_states) ]
implicit none
BEGIN_DOC
From ce042fbd787a21a600830596fa3caa5f7aa2cdb1 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 21 May 2024 12:01:28 +0200
Subject: [PATCH 137/140] basis set correction with cholesky works for hf
---
.../local/basis_correction/51.basis_c.bats | 8 --
.../{01.convert.bats => convert_bats_old} | 0
src/hartree_fock/10.hf.bats | 13 --
src/mu_of_r/basis_def.irp.f | 45 +++++++
.../{f_cholesky.irp.f => f_hf_cholesky.irp.f} | 121 +++++++++---------
5 files changed, 104 insertions(+), 83 deletions(-)
rename src/ezfio_files/{01.convert.bats => convert_bats_old} (100%)
rename src/mu_of_r/{f_cholesky.irp.f => f_hf_cholesky.irp.f} (67%)
diff --git a/plugins/local/basis_correction/51.basis_c.bats b/plugins/local/basis_correction/51.basis_c.bats
index 914b482b..1e20bae3 100644
--- a/plugins/local/basis_correction/51.basis_c.bats
+++ b/plugins/local/basis_correction/51.basis_c.bats
@@ -37,14 +37,6 @@ function run_sd() {
eq $energy1 $1 $thresh
}
-@test "O2 CAS" {
- qp set_file o2_cas.gms.ezfio
- qp set_mo_class -c "[1-2]" -a "[3-10]" -d "[11-46]"
- run -149.72435425 3.e-4 10000
- qp set_mo_class -c "[1-2]" -a "[3-10]" -v "[11-46]"
- run_md -0.1160222327 1.e-6
-}
-
@test "LiF RHF" {
qp set_file lif.ezfio
diff --git a/src/ezfio_files/01.convert.bats b/src/ezfio_files/convert_bats_old
similarity index 100%
rename from src/ezfio_files/01.convert.bats
rename to src/ezfio_files/convert_bats_old
diff --git a/src/hartree_fock/10.hf.bats b/src/hartree_fock/10.hf.bats
index b496a089..214dfa86 100644
--- a/src/hartree_fock/10.hf.bats
+++ b/src/hartree_fock/10.hf.bats
@@ -115,9 +115,6 @@ rm -rf $EZFIO
run hco.ezfio -113.1841002944744
}
-@test "HBO" { # 0.805600 1.4543s
- run hbo.ezfio -100.018582259096
-}
@test "H2S" { # 1.655600 4.21402s
run h2s.ezfio -398.6944130421982
@@ -127,9 +124,6 @@ rm -rf $EZFIO
run h3coh.ezfio -114.9865030596373
}
-@test "H2O" { # 1.811100 1.84387s
- run h2o.ezfio -0.760270218692179E+02
-}
@test "H2O2" { # 2.217000 8.50267s
run h2o2.ezfio -150.7806608469964
@@ -187,13 +181,6 @@ rm -rf $EZFIO
run oh.ezfio -75.42025413469165
}
-@test "[Cu(NH3)4]2+" { # 59.610100 4.18766m
- [[ -n $TRAVIS ]] && skip
- qp set_file cu_nh3_4_2plus.ezfio
- qp set scf_utils thresh_scf 1.e-10
- run cu_nh3_4_2plus.ezfio -1862.97590358903
-}
-
@test "SO2" { # 71.894900 3.22567m
[[ -n $TRAVIS ]] && skip
run so2.ezfio -41.55800401346361
diff --git a/src/mu_of_r/basis_def.irp.f b/src/mu_of_r/basis_def.irp.f
index fff9f581..e433f4d8 100644
--- a/src/mu_of_r/basis_def.irp.f
+++ b/src/mu_of_r/basis_def.irp.f
@@ -114,3 +114,48 @@ BEGIN_PROVIDER [double precision, basis_mos_in_r_array, (n_basis_orb,n_points_fi
enddo
enddo
END_PROVIDER
+
+! BEGIN_PROVIDER [integer, n_docc_val_orb_for_cas]
+!&BEGIN_PROVIDER [integer, n_max_docc_val_orb_for_cas]
+! implicit none
+! BEGIN_DOC
+! ! Number of DOUBLY OCCUPIED VALENCE ORBITALS for the CAS wave function
+! !
+! ! This determines the size of the space \mathcal{A} of Eqs. (15-16) of Phys.Chem.Lett.2019, 10, 2931 2937
+! END_DOC
+! integer :: i
+! n_docc_val_orb_for_cas = 0
+! ! You browse the BETA ELECTRONS and check if its not a CORE ORBITAL
+! do i = 1, elec_beta_num
+! if( trim(mo_class(i))=="Inactive" &
+! .or. trim(mo_class(i))=="Active" &
+! .or. trim(mo_class(i))=="Virtual" )then
+! n_docc_val_orb_for_cas +=1
+! endif
+! enddo
+! n_max_docc_val_orb_for_cas = maxval(n_docc_val_orb_for_cas)
+!
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [integer, list_doc_valence_orb_for_cas, (n_max_docc_val_orb_for_cas)]
+! implicit none
+! BEGIN_DOC
+! ! List of OCCUPIED valence orbitals for each spin to build the f_{HF}(r_1,r_2) function
+! !
+! ! This corresponds to ALL OCCUPIED orbitals in the HF wave function, except those defined as "core"
+! !
+! ! This determines the space \mathcal{A} of Eqs. (15-16) of Phys.Chem.Lett.2019, 10, 2931 2937
+! END_DOC
+! j = 0
+! ! You browse the BETA ELECTRONS and check if its not a CORE ORBITAL
+! do i = 1, elec_beta_num
+! if( trim(mo_class(i))=="Inactive" &
+! .or. trim(mo_class(i))=="Active" &
+! .or. trim(mo_class(i))=="Virtual" )then
+! j +=1
+! list_doc_valence_orb_for_cas(j) = i
+! endif
+! enddo
+!
+!END_PROVIDER
+
diff --git a/src/mu_of_r/f_cholesky.irp.f b/src/mu_of_r/f_hf_cholesky.irp.f
similarity index 67%
rename from src/mu_of_r/f_cholesky.irp.f
rename to src/mu_of_r/f_hf_cholesky.irp.f
index 1ad4ce36..84097f09 100644
--- a/src/mu_of_r/f_cholesky.irp.f
+++ b/src/mu_of_r/f_hf_cholesky.irp.f
@@ -1,4 +1,4 @@
-BEGIN_PROVIDER [integer, list_couple_orb_r1, (2,n_couple_orb_r1)]
+BEGIN_PROVIDER [integer, list_couple_hf_orb_r1, (2,n_couple_orb_r1)]
implicit none
integer :: ii,i,mm,m,itmp
itmp = 0
@@ -7,14 +7,14 @@ BEGIN_PROVIDER [integer, list_couple_orb_r1, (2,n_couple_orb_r1)]
do mm = 1, n_basis_orb ! electron 1
m = list_basis(mm)
itmp += 1
- list_couple_orb_r1(1,itmp) = i
- list_couple_orb_r1(2,itmp) = m
+ list_couple_hf_orb_r1(1,itmp) = i
+ list_couple_hf_orb_r1(2,itmp) = m
enddo
enddo
END_PROVIDER
-BEGIN_PROVIDER [integer, list_couple_orb_r2, (2,n_couple_orb_r2)]
+BEGIN_PROVIDER [integer, list_couple_hf_orb_r2, (2,n_couple_orb_r2)]
implicit none
integer :: ii,i,mm,m,itmp
itmp = 0
@@ -23,8 +23,8 @@ BEGIN_PROVIDER [integer, list_couple_orb_r2, (2,n_couple_orb_r2)]
do mm = 1, n_basis_orb ! electron 1
m = list_basis(mm)
itmp += 1
- list_couple_orb_r2(1,itmp) = i
- list_couple_orb_r2(2,itmp) = m
+ list_couple_hf_orb_r2(1,itmp) = i
+ list_couple_hf_orb_r2(2,itmp) = m
enddo
enddo
END_PROVIDER
@@ -87,31 +87,6 @@ BEGIN_PROVIDER [ double precision, mos_times_cholesky_r1, (cholesky_mo_num,n_poi
enddo
call get_AB_prod(mo_chol_r1,cholesky_mo_num,n_couple_orb_r1,mos_ib_r1,n_points_final_grid,mos_times_cholesky_r1)
- allocate(test(cholesky_mo_num,n_points_final_grid))
- test = 0.d0
- do ipoint = 1, n_points_final_grid
- do itmp = 1, n_couple_orb_r1
- i = list_couple_orb_r1(1,itmp)
- m = list_couple_orb_r1(2,itmp)
- mo_i_r1 = mos_in_r_array_omp(i,ipoint)
- mo_b_r1 = mos_in_r_array_omp(m,ipoint)
- do mm = 1, cholesky_mo_num
- test(mm,ipoint) += mo_i_r1 * mo_b_r1 * mo_chol_r1(mm,itmp)
- enddo
- enddo
- enddo
- double precision :: accu
- accu = 0.d0
- do ipoint = 1, n_points_final_grid
- do mm = 1, cholesky_mo_num
- accu += dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint) )
- if(dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint)).gt.1.d-10)then
- print*,'problem ! ',dabs(mos_times_cholesky_r1(mm,ipoint) - test(mm,ipoint)) &
- , mos_times_cholesky_r1(mm,ipoint) , test(mm,ipoint)
- endif
- enddo
- enddo
- print*,'accu = ',accu
END_PROVIDER
@@ -157,53 +132,72 @@ BEGIN_PROVIDER [ double precision, mos_times_cholesky_r2, (cholesky_mo_num,n_poi
enddo
call get_AB_prod(mo_chol_r2,cholesky_mo_num,n_couple_orb_r2,mos_ib_r2,n_points_final_grid,mos_times_cholesky_r2)
- allocate(test(cholesky_mo_num,n_points_final_grid))
- test = 0.d0
- do ipoint = 1, n_points_final_grid
- do itmp = 1, n_couple_orb_r2
- i = list_couple_orb_r2(1,itmp)
- m = list_couple_orb_r2(2,itmp)
- mo_i_r2 = mos_in_r_array_omp(i,ipoint)
- mo_b_r2 = mos_in_r_array_omp(m,ipoint)
- do mm = 1, cholesky_mo_num
- test(mm,ipoint) += mo_i_r2 * mo_b_r2 * mo_chol_r2(mm,itmp)
- enddo
- enddo
- enddo
- double precision :: accu
- accu = 0.d0
- do ipoint = 1, n_points_final_grid
- do mm = 1, cholesky_mo_num
- accu += dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint) )
- if(dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint)).gt.1.d-10)then
- print*,'problem ! ',dabs(mos_times_cholesky_r2(mm,ipoint) - test(mm,ipoint)) &
- , mos_times_cholesky_r2(mm,ipoint) , test(mm,ipoint)
- endif
- enddo
- enddo
- print*,'accu = ',accu
END_PROVIDER
BEGIN_PROVIDER [ double precision, f_hf_cholesky, (n_points_final_grid)]
implicit none
- integer :: ipoint
+ integer :: ipoint,m,k
!!f(R) = \sum_{I} \sum_{J} Phi_I(R) Phi_J(R) V_IJ
!! = \sum_{I}\sum_{J}\sum_A Phi_I(R) Phi_J(R) V_AI V_AJ
!! = \sum_A \sum_{I}Phi_I(R)V_AI \sum_{J}V_AJ Phi_J(R)
!! = \sum_A V_AR G_AR
!! V_AR = \sum_{I}Phi_IR V_AI = \sum_{I}Phi^t_RI V_AI
- double precision :: u_dot_v
- do ipoint = 1, n_points_final_grid
- f_hf_cholesky(ipoint) = 2.D0 * u_dot_v(mos_times_cholesky_r2(1,ipoint),mos_times_cholesky_r1(1,ipoint),cholesky_mo_num)
- enddo
+ double precision :: u_dot_v,wall0,wall1
+ if(elec_alpha_num == elec_beta_num)then
+ provide mos_times_cholesky_r1
+ print*,'providing f_hf_cholesky ...'
+ call wall_time(wall0)
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,m) &
+ !$OMP ShARED (mos_times_cholesky_r1,cholesky_mo_num,f_hf_cholesky,n_points_final_grid)
+ do ipoint = 1, n_points_final_grid
+ f_hf_cholesky(ipoint) = 0.d0
+ do m = 1, cholesky_mo_num
+ f_hf_cholesky(ipoint) = f_hf_cholesky(ipoint) + &
+ mos_times_cholesky_r1(m,ipoint) * mos_times_cholesky_r1(m,ipoint)
+ enddo
+ f_hf_cholesky(ipoint) *= 2.D0
+ enddo
+ !$OMP END PARALLEL DO
+
+ call wall_time(wall1)
+ print*,'Time to provide f_hf_cholesky = ',wall1-wall0
+ free mos_times_cholesky_r1
+ else
+ provide mos_times_cholesky_r2 mos_times_cholesky_r1
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,m) &
+ !$OMP ShARED (mos_times_cholesky_r2,mos_times_cholesky_r1,cholesky_mo_num,f_hf_cholesky,n_points_final_grid)
+ do ipoint = 1, n_points_final_grid
+ f_hf_cholesky(ipoint) = 0.D0
+ do m = 1, cholesky_mo_num
+ f_hf_cholesky(ipoint) = f_hf_cholesky(ipoint) + &
+ mos_times_cholesky_r2(m,ipoint)*mos_times_cholesky_r1(m,ipoint)
+ enddo
+ f_hf_cholesky(ipoint) *= 2.D0
+ enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide f_hf_cholesky = ',wall1-wall0
+ free mos_times_cholesky_r2 mos_times_cholesky_r1
+ endif
END_PROVIDER
BEGIN_PROVIDER [ double precision, on_top_hf_grid, (n_points_final_grid)]
implicit none
integer :: ipoint,i,ii
- double precision :: dm_a, dm_b
+ double precision :: dm_a, dm_b,wall0,wall1
+ print*,'providing on_top_hf_grid ...'
+ provide mos_in_r_array_omp
+ call wall_time(wall0)
+ !$OMP PARALLEL DO &
+ !$OMP DEFAULT (NONE) &
+ !$OMP PRIVATE (ipoint,dm_a,dm_b,ii,i) &
+ !$OMP ShARED (n_points_final_grid,n_occ_val_orb_for_hf,mos_in_r_array_omp,list_valence_orb_for_hf,on_top_hf_grid)
do ipoint = 1, n_points_final_grid
dm_a = 0.d0
do ii = 1, n_occ_val_orb_for_hf(1)
@@ -217,5 +211,8 @@ BEGIN_PROVIDER [ double precision, on_top_hf_grid, (n_points_final_grid)]
enddo
on_top_hf_grid(ipoint) = 2.D0 * dm_a*dm_b
enddo
+ !$OMP END PARALLEL DO
+ call wall_time(wall1)
+ print*,'Time to provide on_top_hf_grid = ',wall1-wall0
END_PROVIDER
From 112f113ccb3f363262930b53e21aed010a29f746 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 21 May 2024 12:26:30 +0200
Subject: [PATCH 138/140] fixed forgotten stuffs in normal_order_old/NEED
---
plugins/local/normal_order_old/NEED | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/plugins/local/normal_order_old/NEED b/plugins/local/normal_order_old/NEED
index 8b137891..e8c8c478 100644
--- a/plugins/local/normal_order_old/NEED
+++ b/plugins/local/normal_order_old/NEED
@@ -1 +1 @@
-
+tc_scf
From 6fb0f2a58e803ea02a03fe01b4ce9daa6b2fba91 Mon Sep 17 00:00:00 2001
From: eginer
Date: Tue, 21 May 2024 12:53:55 +0200
Subject: [PATCH 139/140] modified scripts/get_fci_tc_conv.sh according to new
printing
---
plugins/local/tc_bi_ortho/print_tc_wf.irp.f | 2 +-
scripts/get_fci_tc_conv.sh | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
index 2b88bc5b..4d9f7c48 100644
--- a/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
+++ b/plugins/local/tc_bi_ortho/print_tc_wf.irp.f
@@ -37,7 +37,7 @@ subroutine write_l_r_wf
integer :: i
print*,'Writing the left-right wf'
do i = 1, N_det
- write(i_unit_output,*)i, psi_coef_sorted_tc(i,1)/psi_coef_sorted_tc(i,1) &
+ write(i_unit_output,'(I8,X,10(F16.10,X))')i, psi_coef_sorted_tc(i,1),psi_coef_sorted_tc(i,1)/psi_coef_sorted_tc(1,1)&
, psi_l_coef_sorted_bi_ortho_left(i)/psi_l_coef_sorted_bi_ortho_left(1) &
, psi_r_coef_sorted_bi_ortho_right(i)/psi_r_coef_sorted_bi_ortho_right(1)
enddo
diff --git a/scripts/get_fci_tc_conv.sh b/scripts/get_fci_tc_conv.sh
index 643f3ac0..f0c99baf 100755
--- a/scripts/get_fci_tc_conv.sh
+++ b/scripts/get_fci_tc_conv.sh
@@ -1,2 +1,2 @@
file=$1
-grep "Ndet,E,E+PT2,E+RPT2,|PT2|=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
+grep "Ndet,E,E+PT2,pt2_minus,pt2_plus,pt2_abs=" $file | cut -d "=" -f 2 > ${file}.conv_fci_tc
From 3600c3c5ca92c6c62a0bbbb6cc1d01ec595e148c Mon Sep 17 00:00:00 2001
From: eginer
Date: Wed, 22 May 2024 17:02:26 +0200
Subject: [PATCH 140/140] removed stupid dead link for PYSCF_EOMCC.py
---
scripts/PYSCF_EOMCC.py | 1 -
1 file changed, 1 deletion(-)
delete mode 120000 scripts/PYSCF_EOMCC.py
diff --git a/scripts/PYSCF_EOMCC.py b/scripts/PYSCF_EOMCC.py
deleted file mode 120000
index 8ad341da..00000000
--- a/scripts/PYSCF_EOMCC.py
+++ /dev/null
@@ -1 +0,0 @@
-/home_lct/eginer/qp2/plugins/qp_plugins_lct/dev/fcidump_for_vbarb/PYSCF_EOMCC.py
\ No newline at end of file