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