From 80cf1472ca55e922f69cf0eb7982cd5d8419753d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 4 Apr 2016 17:28:49 +0200 Subject: [PATCH 01/32] added the two body dm alpha beta --- plugins/FOBOCI/dress_simple.irp.f | 4 +- plugins/FOBOCI/fobo_scf.irp.f | 2 +- src/AO_Basis/aos.irp.f | 18 +-- src/Determinants/two_body_dm_map.irp.f | 210 +++++++++++++++++++++++++ 4 files changed, 217 insertions(+), 17 deletions(-) create mode 100644 src/Determinants/two_body_dm_map.irp.f diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index 99566a8e..021aa422 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -279,9 +279,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do k = 1, N_states accu = 0.d0 do j =1, Ndet_generators + print*,'',eigvectors(j,i) , psi_coef_ref(j,k) accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo - if(dabs(accu).ge.0.8d0)then + print*,'accu = ',accu + if(dabs(accu).ge.0.72d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i endif diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8656b633..0b0902b0 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,6 +1,6 @@ program foboscf implicit none - call run_prepare +!call run_prepare no_oa_or_av_opt = .True. touch no_oa_or_av_opt call routine_fobo_scf diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index acc78912..9ccbb981 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -17,7 +17,7 @@ END_PROVIDER call ezfio_get_ao_basis_ao_prim_num_max(ao_prim_num_max) integer :: align_double ao_prim_num_max_align = align_double(ao_prim_num_max) - END_PROVIDER +END_PROVIDER BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ] &BEGIN_PROVIDER [ double precision, ao_coef_normalization_factor, (ao_num) ] @@ -109,6 +109,7 @@ END_PROVIDER BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] &BEGIN_PROVIDER [ integer, ao_l_max ] +&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] implicit none BEGIN_DOC ! ao_l = l value of the AO: a+b+c in x^a y^b z^c @@ -116,6 +117,7 @@ END_PROVIDER integer :: i do i=1,ao_num ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) + ao_l_char(i) = l_to_charater(ao_l(i)) enddo ao_l_max = maxval(ao_l) END_PROVIDER @@ -143,20 +145,6 @@ integer function ao_power_index(nx,ny,nz) ao_power_index = ((l-nx)*(l-nx+1))/2 + nz + 1 end - BEGIN_PROVIDER [ integer, ao_l, (ao_num) ] -&BEGIN_PROVIDER [ integer, ao_l_max ] -&BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ] - implicit none - BEGIN_DOC -! ao_l = l value of the AO: a+b+c in x^a y^b z^c - END_DOC - integer :: i - do i=1,ao_num - ao_l(i) = ao_power(i,1) + ao_power(i,2) + ao_power(i,3) - ao_l_char(i) = l_to_charater(ao_l(i)) - enddo - ao_l_max = maxval(ao_l) -END_PROVIDER BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] BEGIN_DOC diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f new file mode 100644 index 00000000..eccb9741 --- /dev/null +++ b/src/Determinants/two_body_dm_map.irp.f @@ -0,0 +1,210 @@ + +use map_module + +BEGIN_PROVIDER [ type(map_type), two_body_dm_ab_map ] + implicit none + BEGIN_DOC + ! Map of the two body density matrix elements for the alpha/beta elements + END_DOC + integer(key_kind) :: key_max + integer(map_size_kind) :: sze + call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) + sze = key_max + call map_init(two_body_dm_ab_map,sze) + print*, 'two_body_dm_ab_map initialized' +END_PROVIDER + +subroutine insert_into_two_body_dm_ab_map(n_product,buffer_i, buffer_values, thr) + use map_module + implicit none + + BEGIN_DOC + ! Create new entry into two_body_dm_ab_map, or accumulate in an existing entry + END_DOC + + integer, intent(in) :: n_product + integer(key_kind), intent(inout) :: buffer_i(n_product) + real(integral_kind), intent(inout) :: buffer_values(n_product) + real(integral_kind), intent(in) :: thr + call map_update(two_body_dm_ab_map, buffer_i, buffer_values, n_product, thr) +end + +double precision function get_two_body_dm_ab_map_element(i,j,k,l,map) + use map_module + implicit none + BEGIN_DOC + ! Returns one value of the wo body density matrix \rho_{ijkl}^{\alpha \beta} defined as : + ! \rho_{ijkl}^{\alpha \beta } = <\Psi|a^{\dagger}_{i\alpha} a^{\dagger}_{j\beta} a_{k\beta} a_{l\alpha}|\Psi> + END_DOC + PROVIDE two_body_dm_ab_map + + integer, intent(in) :: i,j,k,l + integer(key_kind) :: idx + type(map_type), intent(inout) :: map + real(integral_kind) :: tmp + PROVIDE two_body_dm_in_map + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(two_body_dm_ab_map,idx,tmp) + get_two_body_dm_ab_map_element = dble(tmp) +end + +subroutine get_get_two_body_dm_ab_map_elements(j,k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple elements of the \rho_{ijkl}^{\alpha \beta }, all + ! i for j,k,l fixed. + END_DOC + integer, intent(in) :: j,k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE two_body_dm_in_map + + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(two_body_dm_ab_map, hash, out_val, sze) + else + call map_get_many(two_body_dm_ab_map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + +BEGIN_PROVIDER [ logical, two_body_dm_in_map ] + implicit none + + BEGIN_DOC + ! If True, the map of the two body density matrix alpha/beta is provided + END_DOC + + two_body_dm_in_map = .True. + call add_values_to_two_body_dm_map(full_ijkl_bitmask_4) +END_PROVIDER + +subroutine add_values_to_two_body_dm_map(mask_ijkl) + use bitmasks + use map_module + implicit none + + BEGIN_DOC + ! Adds values to the map of two_body_dm according to some bitmask + END_DOC + + integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) + integer :: degree + + PROVIDE mo_coef psi_coef psi_det + + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + double precision :: phase + double precision :: contrib + integer(key_kind),allocatable :: buffer_i(:) + double precision ,allocatable :: buffer_value(:) + integer :: size_buffer + integer :: n_elements + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,k,l,m + + size_buffer = min(mo_tot_num*mo_tot_num*mo_tot_num,16000000) + + allocate(buffer_i(size_buffer),buffer_value(size_buffer)) + + n_elements = 0 + do i = 1, N_det ! i == |I> + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + do j = i+1, N_det ! j == 2)cycle + call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) + contrib = psi_coef(i,1) * psi_coef(j,1) * phase + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ + + if(s1==s2)cycle ! Only the alpha/beta two body density matrix + ! * c_I * c_J + n_elements += 1 + buffer_value(n_elements) = contrib + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(h1,h2,p1,p2,buffer_i(n_elements)) + if (n_elements == size_buffer) then + call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_elements = 0 + endif + + else ! case of the SINGLE EXCITATIONS *************************************************** + + if(s1==1)then ! Mono alpha : + do k = 1, elec_beta_num + m = occ(k,2) + n_elements += 1 + buffer_value(n_elements) = contrib + ! * c_I * c_J + call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) + if (n_elements == size_buffer) then + call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_elements = 0 + endif + enddo + else ! Mono Beta : + do k = 1, elec_alpha_num + m = occ(k,1) + n_elements += 1 + buffer_value(n_elements) = contrib + ! * c_I * c_J + call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) + if (n_elements == size_buffer) then + call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_elements = 0 + endif + enddo + endif + + endif + enddo + enddo + print*,'n_elements = ',n_elements + call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + +end + +BEGIN_PROVIDER [double precision, two_body_dm_ab_diag, (mo_tot_num, mo_tot_num)] + implicit none + integer :: i,j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + double precision :: contrib + BEGIN_DOC + ! two_body_dm_ab_diag(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi> + + END_DOC + two_body_dm_ab_diag = 0.d0 + do i = 1, N_det ! i == |I> + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + contrib = psi_coef(i,1)**2 + do j = 1, elec_beta_num + k = occ(j,2) + do l = 1, elec_beta_num + m = occ(l,1) + two_body_dm_ab_diag(k,m) += contrib + enddo + enddo + enddo +END_PROVIDER + From 74f465be9007ee5cda993df720bd97fd28793e7a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 17 Apr 2016 22:25:25 +0200 Subject: [PATCH 02/32] two bod is ok --- src/Determinants/two_body_dm_map.irp.f | 153 +++++++++++++++++++------ src/MO_Basis/utils.irp.f | 23 ++++ 2 files changed, 141 insertions(+), 35 deletions(-) diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index eccb9741..f570e2bf 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -8,6 +8,7 @@ BEGIN_PROVIDER [ type(map_type), two_body_dm_ab_map ] END_DOC integer(key_kind) :: key_max integer(map_size_kind) :: sze + use map_module call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) sze = key_max call map_init(two_body_dm_ab_map,sze) @@ -129,51 +130,56 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) if(degree>2)cycle call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) - contrib = psi_coef(i,1) * psi_coef(j,1) * phase call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J + if(h1>p1)cycle + if(h2>p2)cycle +! if(s1.ne.1)cycle n_elements += 1 + contrib = psi_coef(i,1) * psi_coef(j,1) * phase buffer_value(n_elements) = contrib !DEC$ FORCEINLINE +! call mo_bielec_integrals_index(h1,p1,h2,p2,buffer_i(n_elements)) call mo_bielec_integrals_index(h1,h2,p1,p2,buffer_i(n_elements)) - if (n_elements == size_buffer) then - call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_elements = 0 - endif +! if (n_elements == size_buffer) then +! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& +! real(mo_integrals_threshold,integral_kind)) +! n_elements = 0 +! endif else ! case of the SINGLE EXCITATIONS *************************************************** + cycle - if(s1==1)then ! Mono alpha : - do k = 1, elec_beta_num - m = occ(k,2) - n_elements += 1 - buffer_value(n_elements) = contrib - ! * c_I * c_J - call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) - if (n_elements == size_buffer) then - call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_elements = 0 - endif - enddo - else ! Mono Beta : - do k = 1, elec_alpha_num - m = occ(k,1) - n_elements += 1 - buffer_value(n_elements) = contrib - ! * c_I * c_J - call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) - if (n_elements == size_buffer) then - call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_elements = 0 - endif - enddo - endif +! if(s1==1)then ! Mono alpha : +! do k = 1, elec_beta_num +! m = occ(k,2) +! n_elements += 1 +! buffer_value(n_elements) = contrib +! ! * c_I * c_J +! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) +! if (n_elements == size_buffer) then +! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& +! real(mo_integrals_threshold,integral_kind)) +! n_elements = 0 +! endif +! enddo +! else ! Mono Beta : +! do k = 1, elec_alpha_num +! m = occ(k,1) +! n_elements += 1 +! buffer_value(n_elements) = contrib +! ! * c_I * c_J +! call mo_bielec_integrals_index(h1,m,p1,m,buffer_i(n_elements)) +! if (n_elements == size_buffer) then +! call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& +! real(mo_integrals_threshold,integral_kind)) +! n_elements = 0 +! endif +! enddo +! endif endif enddo @@ -181,6 +187,9 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) print*,'n_elements = ',n_elements call insert_into_two_body_dm_ab_map(n_elements,buffer_i,buffer_value,& real(mo_integrals_threshold,integral_kind)) + call map_unique(two_body_dm_ab_map) + + deallocate(buffer_i,buffer_value) end @@ -192,8 +201,8 @@ BEGIN_PROVIDER [double precision, two_body_dm_ab_diag, (mo_tot_num, mo_tot_num)] double precision :: contrib BEGIN_DOC ! two_body_dm_ab_diag(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi> - END_DOC + two_body_dm_ab_diag = 0.d0 do i = 1, N_det ! i == |I> call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) @@ -202,9 +211,83 @@ BEGIN_PROVIDER [double precision, two_body_dm_ab_diag, (mo_tot_num, mo_tot_num)] k = occ(j,2) do l = 1, elec_beta_num m = occ(l,1) - two_body_dm_ab_diag(k,m) += contrib + two_body_dm_ab_diag(k,m) += 0.5d0 * contrib + two_body_dm_ab_diag(m,k) += 0.5d0 * contrib enddo enddo enddo END_PROVIDER +BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k,l,m + integer :: degree + PROVIDE mo_coef psi_coef psi_det + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + double precision :: phase + double precision :: contrib + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + two_body_dm_ab_big_array = 0.d0 + BEGIN_DOC +! The alpha-beta energy can be computed thanks to +! sum_{h1,p1,h2,p2} two_body_dm_ab_big_array(h1,p1,h2,p2) * (h1p1|h2p2) + END_DOC + + do i = 1, N_det ! i == |I> + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + do j = i+1, N_det ! j == 2)cycle + call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase + if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ + if(s1==s2)cycle ! Only the alpha/beta two body density matrix + ! * c_I * c_J + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + + else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** + if(s1==1)then ! Mono alpha : + do k = 1, elec_beta_num + m = occ(k,2) + ! * c_I * c_J + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + enddo + else ! Mono Beta : + do k = 1, elec_alpha_num + m = occ(k,1) + ! * c_I * c_J + call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + enddo + endif + + endif + enddo + enddo + print*,'Big array for density matrix provided !' + + + +END_PROVIDER + +subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contrib,h1,p1,h2,p2) + implicit none + integer, intent(in) :: h1,p1,h2,p2 + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4) + double precision :: contrib + big_array(h1,p1,h2,p2) += 1.d0 * contrib + big_array(p1,h1,h2,p2) += 1.d0 * contrib + big_array(h1,p1,p2,h2) += 1.d0 * contrib + big_array(p1,h1,p2,h2) += 1.d0 * contrib + +!big_array(h2,p2,h1,p1) += 1.d0 * contrib +!big_array(p2,h2,h1,p1) += 1.d0 * contrib +!if(p2.ne.h2)then +!big_array(h2,p2,p1,h1) += 1.d0 * contrib +!big_array(p2,h2,p1,h1) += 1.d0 * contrib +!endif + +end diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index aa2feead..0f338877 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -268,3 +268,26 @@ subroutine mo_sort_by_observable(observable,label) end +subroutine give_all_mos_at_r(r,mos_array) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_array(mo_tot_num) + call give_specific_mos_at_r(r,mos_array, mo_coef) +end + +subroutine give_specific_mos_at_r(r,mos_array, mo_coef_specific) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(in) :: mo_coef_specific(ao_num_align, mo_tot_num) + double precision, intent(out) :: mos_array(mo_tot_num) + double precision :: aos_array(ao_num),accu + integer :: i,j + call give_all_aos_at_r(r,aos_array) + do i = 1, mo_tot_num + accu = 0.d0 + do j = 1, ao_num + accu += mo_coef_specific(j,i) * aos_array(j) + enddo + mos_array(i) = accu + enddo +end From e432c470a1ff8f5dc3c8234d7c9bdd816c9cc55e Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 17 Apr 2016 23:30:04 +0200 Subject: [PATCH 03/32] begin DFT in qp --- plugins/DFT_Utils/EZFIO.cfg | 4 + plugins/DFT_Utils/NEEDED_CHILDREN_MODULES | 1 + plugins/DFT_Utils/grid_density.irp.f | 104 ++++++++++ plugins/DFT_Utils/integration_3d.irp.f | 64 ++++++ plugins/DFT_Utils/integration_radial.irp.f | 48 +++++ plugins/DFT_Utils/routines_roland.irp.f | 219 +++++++++++++++++++++ src/Determinants/two_body_dm_map.irp.f | 29 ++- 7 files changed, 467 insertions(+), 2 deletions(-) create mode 100644 plugins/DFT_Utils/EZFIO.cfg create mode 100644 plugins/DFT_Utils/NEEDED_CHILDREN_MODULES create mode 100644 plugins/DFT_Utils/grid_density.irp.f create mode 100644 plugins/DFT_Utils/integration_3d.irp.f create mode 100644 plugins/DFT_Utils/integration_radial.irp.f create mode 100644 plugins/DFT_Utils/routines_roland.irp.f diff --git a/plugins/DFT_Utils/EZFIO.cfg b/plugins/DFT_Utils/EZFIO.cfg new file mode 100644 index 00000000..21cc5b98 --- /dev/null +++ b/plugins/DFT_Utils/EZFIO.cfg @@ -0,0 +1,4 @@ +[energy] +type: double precision +doc: Calculated energy +interface: ezfio diff --git a/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES b/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..bff2467f --- /dev/null +++ b/plugins/DFT_Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f new file mode 100644 index 00000000..7cb93a91 --- /dev/null +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -0,0 +1,104 @@ +BEGIN_PROVIDER [integer, n_points_angular_grid] + implicit none + n_points_angular_grid = 18 +END_PROVIDER + +BEGIN_PROVIDER [integer, n_points_radial_grid] + implicit none + n_points_radial_grid = 10 +END_PROVIDER + + + BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ] +&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)] + implicit none + BEGIN_DOC +! weights and grid points for the integration on the angular variables on +! the unit sphere centered on (0,0,0) + END_DOC + call cal_quad(n_points_aangular_grid, angular_quadrature_points,weights_angular_points) + +END_PROVIDER + +BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)] + BEGIN_DOC +! points for integration over space + END_DOC + implicit none + integer :: i,j,k + double precision :: dr,x_ref,y_ref,z_ref + dr = 1.d0/dble(n_points_radial_grid-1) + do i = 1, nucl_num + x_ref = nucl_coord(i,1) + y_ref = nucl_coord(i,2) + z_ref = nucl_coord(i,3) + do j = 1, n_points_radial_grid + do k = 1, n_points_angular_grid + grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * dr + grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * dr + grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * dr + enddo + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (nucl_num,n_points_angular_grid,n_points_radial_grid) ] + BEGIN_DOC +! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) +! the "n" discrete variable represents the nucleis (j=1,nucl_num) + END_DOC + implicit none + integer :: i,j,k,l,m + double precision :: r(3) + double precision :: accu,cell_function_becke + double precision :: tmp_array(nucl_num) + do j = 1, nucl_num + do k = 1, n_points_radial_grid + do l = 1, n_points_angular_grid + r(1) = grid_points_per_atom(1,j,k,l) + r(2) = grid_points_per_atom(2,j,k,l) + r(3) = grid_points_per_atom(3,j,k,l) + accu = 0.d0 + do i = 1, nucl_num + tmp_array(i) = cell_function_becke(r,i) + accu += tmp_array(i) + enddo + accu = 1.d0/accu + do i = 1, nucl_num + weight_functions_at_grid_points(i,j,k,l) = tmp_array(i)*accu + enddo + enddo + enddo + enddo + + +END_PROVIDER + + BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] +&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] + implicit none + integer :: i,j,k,l,m + double precision :: contrib + double precision :: r(3) + double precision :: aos_array(ao_num) + do j = 1, nucl_num + do k = 1, n_points_radial_grid + do l = 1, n_points_angular_grid + r(1) = grid_points_per_atom(1,j,k,l) + r(2) = grid_points_per_atom(2,j,k,l) + r(3) = grid_points_per_atom(3,j,k,l) + call give_all_aos_at_r(r,aos_array) + one_body_dm_mo_alpha_at_grid_points(j,k,l) = 0.d0 + do i = 1, ao_num + do m = 1, ao_num + contrib = aos_array(i) * aos_array(m) + one_body_dm_mo_alpha_at_grid_points(j,k,l) += one_body_dm_ao_alpha(i,m) * contrib + one_body_dm_mo_beta_at_grid_points(j,k,l) += one_body_dm_ao_beta(i,m) * contrib + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f new file mode 100644 index 00000000..f4088302 --- /dev/null +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -0,0 +1,64 @@ +double precision function step_function_becke(x) + implicit none + double precision, intent(in) :: x + double precision :: f_function_becke + integer :: i,n_max_becke + + step_function_becke = f_function_becke(x) + n_max_becke = 2 + do i = 1, n_max_becke + step_function_becke = f_function_becke(step_function_becke) + enddo + step_function_becke = 0.5d0*(1.d0 - step_function_becke) +end + +double precision function f_function_becke(x) + implicit none + double precision, intent(in) :: x + f_function_becke = 1.5d0 * x - 0.5d0 * x*x*x +end + +double precision function cell_function_becke(r,atom_number) + implicit none + double precision, intent(in) :: r(3) + integer, intent(in) :: atom_number + BEGIN_DOC + ! atom_number :: atom on which the cell function of Becke (1988, JCP,88(4)) + ! r(1:3) :: x,y,z coordinantes of the current point + END_DOC + double precision :: mu_ij,nu_ij + double precision :: distance_i,distance_j,step_function_becke + integer :: j + distance_i = (r(1) - nucl_coord_transp(1,atom_number) ) * (r(1) - nucl_coord_transp(1,atom_number)) + distance_i += (r(2) - nucl_coord_transp(2,atom_number) ) * (r(2) - nucl_coord_transp(2,atom_number)) + distance_i += (r(3) - nucl_coord_transp(3,atom_number) ) * (r(3) - nucl_coord_transp(3,atom_number)) + distance_i = dsqrt(distance_i) + cell_function_becke = 1.d0 + do j = 1, nucl_num + if(j==atom_number)cycle + distance_j = (r(1) - nucl_coord_transp(1,j) ) * (r(1) - nucl_coord_transp(1,j)) + distance_j+= (r(2) - nucl_coord_transp(2,j) ) * (r(2) - nucl_coord_transp(2,j)) + distance_j+= (r(3) - nucl_coord_transp(3,j) ) * (r(3) - nucl_coord_transp(3,j)) + distance_j = dsqrt(distance_j) + mu_ij = (distance_i - distance_j)/nucl_dist(atom_number,j) + nu_ij = mu_ij + slater_bragg_type_inter_distance_ua(atom_number,j) * (1.d0 - mu_ij*mu_ij) + cell_function_becke *= step_function_becke(nu_ij) + enddo +end + +double precision function weight_function_becke(r,atom_number) + implicit none + double precision, intent(in) :: r(3) + integer, intent(in) :: atom_number + BEGIN_DOC + ! atom_number :: atom on which the weight function of Becke (1988, JCP,88(4)) + ! r(1:3) :: x,y,z coordinantes of the current point + END_DOC + double precision :: cell_function_becke,accu + integer :: j + accu = 0.d0 + do j = 1, nucl_num + accu += cell_function_becke(r,j) + enddo + weight_function_becke = cell_function_becke(r,atom_number)/accu +end diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f new file mode 100644 index 00000000..59874b8b --- /dev/null +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -0,0 +1,48 @@ + BEGIN_PROVIDER [ double precision, integral_density_alpha_knowles_becke_per_atom, (nucl_num)] +&BEGIN_PROVIDER [ double precision, integral_density_beta_knowles_becke_per_atom, (nucl_num)] + implicit none + double precision :: accu + integer :: i,j,k,l + integer :: m_param_knowles + double precision :: dx,x + integer :: n_pt_int_radial + double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) + double precision :: f_average_angular_alpha,f_average_angular_beta + double precision :: derivative_knowles_function,knowles_function + n_pt_int_radial = 10 + dx = 1.d0/dble(n_pt_int_radial-1) + x = 0.d0 + m_param_knowles = 3 + do j = 1, nucl_num + integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 + do i = 1, n_points_radial_grid + ! Angular integration + f_average_angular_alpha = 0.d0 + f_average_angular_beta = 0.d0 + do k = 1, n_points_angular_grid + f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + enddo + integral_density_alpha_knowles_becke_per_atom(j) += derivative_knowles_function(alpha,m_param_knowles,x) & + *knowles_function(alpha,m_param_knowles,x)**2 & + *f_average_angular_alpha + x += dx + enddo + integral_density_alpha_knowles_becke_per_atom(j) *= dx + enddo + +END_PROVIDER + + double precision function knowles_function(alpha,m,x) + implicit none + double precision, intent(in) :: alpha,x + integer, intent(in) :: m + knowles_function = -alpha * dlog(1.d0-x**m) + end + + double precision function derivative_knowles_function(alpha,m,x) + implicit none + double precision, intent(in) :: alpha,x + integer, intent(in) :: m + derivative_knowles_function = m x**(m-1) / (alpha * dlog(1.d0-x**m)) + end diff --git a/plugins/DFT_Utils/routines_roland.irp.f b/plugins/DFT_Utils/routines_roland.irp.f new file mode 100644 index 00000000..0f555902 --- /dev/null +++ b/plugins/DFT_Utils/routines_roland.irp.f @@ -0,0 +1,219 @@ + + subroutine cal_quad(n_quad, quad, weight) +! -------------------------------------------------------------------------------- +! +! Arguments : subroutine cal_quad +! Description: evaluates quadrature points an weights +! +! Authors : B. Lévy, P. Pernot +! Date : 15 Nov 2000 +! -------------------------------------------------------------------------------- + implicit none + integer, intent(in) :: n_quad + double precision, intent(out) :: weight(n_quad) + double precision, intent(out) :: quad(n_quad,3) + +! local: + double precision, parameter :: zero=0.d0, one= 1.d0 + + double precision, parameter :: p=0.707106781186547462d0 + double precision, parameter :: q=0.577350269189625842d0 + double precision, parameter :: r=0.301511344577763629d0 + double precision, parameter :: s=0.904534033733290888d0 + + double precision, parameter :: fourpi= 12.5663706143591725d0 + + double precision, parameter :: a6=0.166666666666666657d0 + double precision, parameter :: a18=0.333333333333333329d-01 + double precision, parameter :: b18=0.666666666666666657d-01 + double precision, parameter :: a26=0.476190476190476164d-01 + double precision, parameter :: b26=0.380952380952380987d-01 + double precision, parameter :: c26=0.321428571428571397d-01 + double precision, parameter :: a50=0.126984126984126984d-01 + double precision, parameter :: b50=0.225749559082892431d-01 + double precision, parameter :: c50=0.210937500000000014d-01 + double precision, parameter :: d50=0.201733355379188697d-01 + + double precision :: apt(3,6),bpt(3,12),cpt(3,8),dpt(3,24) + double precision :: awght,bwght,cwght,dwght + double precision :: s1, s2, s3 + integer :: idim, ipt, i1, i2, i3, is1, is2, is3 + integer :: iquad + +! begin: +! l_here ='cal_quad' +! call enter (l_here,3) + +! verifications: +! message = 'in '//trim(l_here)//', number of dimensions='//& +! trim(encode(dimensions_nb))//', must be 3' +! call ensure(message, dimensions_nb .eq. 3 ) + +! message = 'in '//trim(l_here)//', invalid number of quadrature points ='& +! //trim(encode(n_quad)) +! call ensure(message,(n_quad-2)*(n_quad-6)*(n_quad-18)*(n_quad-26)*(n_quad-50) .eq. 0) + +! initialize weights + awght = zero + bwght = zero + cwght = zero + dwght = zero + +! type A points : (+/-1,0,0) + awght=a6*fourpi + ipt= 1 + apt=0. + do idim = 1, 3 + apt(idim,ipt)=one + ipt=ipt+1 + apt(idim,ipt)=-one + ipt=ipt+1 + enddo + +! type B points : (+/-p,+/-p,0) with p= 1/sqrt(2) + if(n_quad.gt.6) then + + awght=a18*fourpi + bwght=b18*fourpi + + s1=p + s2=p + ipt= 1 + bpt=0. + do idim = 1, 3 + i1=idim+1 + if(i1.gt.3) i1=i1-3 + i2=idim+2 + if(i2.gt.3) i2=i2-3 + do is1= 1,2 + do is2= 1,2 + bpt(i1,ipt)=s1 + bpt(i2,ipt)=s2 + s2=-s2 + ipt=ipt+1 + enddo + s1=-s1 + enddo + enddo + endif + +! type C points : (+/-q,+/-q,+/-q) with q= 1/sqrt(3) + if(n_quad.gt.18) then + + awght=a26*fourpi + bwght=b26*fourpi + cwght=c26*fourpi + + s1=q + s2=q + s3=q + ipt= 1 + cpt=0. + do is1= 1,2 + do is2= 1,2 + do is3= 1,2 + cpt(1,ipt)=s1 + cpt(2,ipt)=s2 + cpt(3,ipt)=s3 + s3=-s3 + ipt=ipt+1 + enddo + s2=-s2 + enddo + s1=-s1 + enddo + endif + +! type D points : (+/-r,+/-r,+/-s) + if(n_quad.gt.26) then + + awght=a50*fourpi + bwght=b50*fourpi + cwght=c50*fourpi + dwght=d50*fourpi + + ipt= 1 + dpt=0. + do i1= 1, 3 + s1=s + s2=r + s3=r + i2=i1+1 + if(i2.gt.3) i2=i2-3 + i3=i1+2 + if(i3.gt.3) i3=i3-3 + do is1= 1,2 + do is2= 1,2 + do is3= 1,2 + dpt(i1,ipt)=s1 + dpt(i2,ipt)=s2 + dpt(i3,ipt)=s3 + s3=-s3 + ipt=ipt+1 + enddo + s2=-s2 + enddo + s1=-s1 + enddo + enddo + endif + +! fill the points and weights tables + iquad= 1 + do ipt= 1, 6 + do idim = 1, 3 + quad(iquad,idim)=apt(idim,ipt) + enddo + weight(iquad)=awght + iquad=iquad+1 + enddo + + if(n_quad.gt.6) then + do ipt= 1,12 + do idim = 1, 3 + quad(iquad,idim)=bpt(idim,ipt) + enddo + weight(iquad)=bwght + iquad=iquad+1 + enddo + endif + + if(n_quad.gt.18) then + do ipt= 1,8 + do idim = 1, 3 + quad(iquad,idim)=cpt(idim,ipt) + enddo + weight(iquad)=cwght + iquad=iquad+1 + enddo + endif + + if(n_quad.gt.26) then + do ipt= 1,24 + do idim = 1, 3 + quad(iquad,idim)=dpt(idim,ipt) + enddo + weight(iquad)=dwght + iquad=iquad+1 + enddo + endif + +! if (debug) then +! write(6,*) +! write(6,'(1X,a)') trim(l_here)//'-d : '//& +! '------------------------------------------------------' +! write(6,'(1X,a)') trim(l_here)//'-d : '//' I Weight Quad_points' +! write(6,'(1X,a)') trim(l_here)//'-d : '//& +! '----- ---------- -----------------------------------' +! do iquad= 1, n_quad +! write(6,'(1X,A,i5,4e12.3)') trim(l_here)//'-d : ',& +! iquad,weight(iquad),quad(iquad,1:3) +! enddo +! write(6,'(1X,a)') trim(l_here)//'-d : '//& +! '------------------------------------------------------' +! write(6,*) +! endif + +! call exit (l_here,3) + + end subroutine cal_quad diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index f570e2bf..38467040 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -268,8 +268,6 @@ BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array, (n_act_orb,n_act_orb enddo print*,'Big array for density matrix provided !' - - END_PROVIDER subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contrib,h1,p1,h2,p2) @@ -291,3 +289,30 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr !endif end + +double precision function compute_two_body_dm_ab(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num) + double precision :: contrib + compute_two_body_dm_ab = 0.d0 + call give_all_mos_at_r(r1,mos_array_r1) + call give_all_mos_at_r(r2,mos_array_r2) + do l = 1, n_act_orb ! p2 + contrib = mos_array_r2(l) + if(dabs(contrib).lt.1.d-6)cycle + do k = 1, n_act_orb ! h2 + contrib *= mos_array_r2(k) + if(dabs(contrib).lt.1.d-6)cycle + do j = 1, n_act_orb ! p1 + contrib *= mos_array_r1(j) + if(dabs(contrib).lt.1.d-6)cycle + do i = 1,n_act_orb ! h1 + compute_two_body_dm_ab += two_body_dm_ab_big_array(i,j,k,l) * mos_array_r1(i) * contrib + enddo + enddo + enddo + enddo + +end From 83f77b61c8cb6a3f169fb99706f70a153db8bb41 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 18 Apr 2016 20:49:49 +0200 Subject: [PATCH 04/32] Two body dm implemented --- plugins/Properties/EZFIO.cfg | 8 +- plugins/Properties/eval_ab_two_body_dm.irp.f | 80 ++++++++++++++++++++ plugins/Properties/iunit_two_bod.irp.f | 45 +++++++++++ plugins/Properties/test_two_body_dm.irp.f | 67 ++++++++++++++++ src/Determinants/two_body_dm_map.irp.f | 65 +++++++++++----- 5 files changed, 243 insertions(+), 22 deletions(-) create mode 100644 plugins/Properties/eval_ab_two_body_dm.irp.f create mode 100644 plugins/Properties/iunit_two_bod.irp.f create mode 100644 plugins/Properties/test_two_body_dm.irp.f diff --git a/plugins/Properties/EZFIO.cfg b/plugins/Properties/EZFIO.cfg index 02f42ad8..40ccd8b9 100644 --- a/plugins/Properties/EZFIO.cfg +++ b/plugins/Properties/EZFIO.cfg @@ -2,4 +2,10 @@ type: double precision doc: z point on which the integrated delta rho is calculated interface: ezfio,provider,ocaml -default: 3.9 \ No newline at end of file +default: 3.9 + +[threshld_two_bod_dm] +type: double precision +doc: threshold for the values of the alpha/beta two body dm evaluation +interface: ezfio,provider,ocaml +default: 0.000001 diff --git a/plugins/Properties/eval_ab_two_body_dm.irp.f b/plugins/Properties/eval_ab_two_body_dm.irp.f new file mode 100644 index 00000000..595b0087 --- /dev/null +++ b/plugins/Properties/eval_ab_two_body_dm.irp.f @@ -0,0 +1,80 @@ +program two_bod_ab_dm + implicit none + read_wf = .True. + touch read_wf + call routine + +end + +subroutine routine + implicit none + integer :: i,j,k,l + double precision :: dx1,dx2 + double precision :: interval_1,interval_2 + integer :: nx1,nx2 + double precision :: r1(3),r2(3) + double precision :: xmin_1,xmax_1,xmin_2,xmax_2 + double precision :: compute_extra_diag_two_body_dm_ab,two_bod_extra_diag + double precision :: compute_diag_two_body_dm_ab,two_bod_diag + + double precision,allocatable :: mos_array_r1(:),mos_array_r2(:) + double precision :: test_diag, test_extra_diag + double precision, allocatable :: x_array(:),y_array(:),z_diag_array(:),z_extra_diag_array(:),z_total_array(:) + allocate(mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num)) + + + + ! He triplet S + ! r1 = x + ! r2 = z + nx1 = 100 + nx2 = 100 + allocate(x_array(nx1),y_array(nx2),z_diag_array(nx1),z_extra_diag_array(nx1),z_total_array(nx1)) + xmin_1 = -2.d0 + xmax_1 = 2.d0 + xmin_2 = -2.d0 + xmax_2 = 2.d0 + interval_1 = xmax_1 - xmin_1 + interval_2 = xmax_2 - xmin_2 + dx1 = interval_1/dble(nx1) + dx2 = interval_2/dble(nx2) + r1 = 0.d0 + r2 = 0.d0 + + double precision :: x_tmp,y_tmp + x_tmp = xmin_1 + do i = 1, nx1 + x_array(i) = x_tmp + write(i_unit_x_two_body_dm_ab,'(10000(F16.10,X))')x_array(i) + x_tmp += dx1 + enddo + x_tmp = xmin_2 + do i = 1, nx1 + y_array(i) = x_tmp + write(i_unit_y_two_body_dm_ab,'(10000(F16.10,X))')x_array(i) + x_tmp += dx2 + enddo + + + ! initialization + r1(1) = xmin_1 + do i = 1, nx1 + r2(3) = xmin_2 + do j = 1, nx2 + two_bod_extra_diag = compute_extra_diag_two_body_dm_ab(r1,r2) + two_bod_diag = compute_diag_two_body_dm_ab(r1,r2) + z_diag_array(j) = two_bod_diag + z_extra_diag_array(j) = two_bod_extra_diag + z_total_array(j) = two_bod_extra_diag + two_bod_diag +! write(i_unit_two_body_dm_ab,'(100(F16.10,X))')r1(1),r2(3),two_bod_diag,two_bod_extra_diag,two_bod_diag+two_bod_extra_diag + r2(3) += dx2 + enddo + write(i_unit_z_two_body_diag_dm_ab,'(10000(F16.10,X))')z_diag_array(:) + write(i_unit_z_two_body_extra_diag_dm_ab,'(10000(F16.10,X))')z_extra_diag_array(:) + write(i_unit_z_two_body_total_dm_ab,'(10000(F16.10,X))')z_total_array(:) + r1(1) += dx1 + enddo + + deallocate(mos_array_r1,mos_array_r2) + +end diff --git a/plugins/Properties/iunit_two_bod.irp.f b/plugins/Properties/iunit_two_bod.irp.f new file mode 100644 index 00000000..e14d9893 --- /dev/null +++ b/plugins/Properties/iunit_two_bod.irp.f @@ -0,0 +1,45 @@ +BEGIN_PROVIDER [integer, i_unit_x_two_body_dm_ab] + implicit none + integer :: getUnitAndOpen + character*(128) :: file_name + file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_x') + i_unit_x_two_body_dm_ab = getUnitAndOpen(file_name,'w') + +END_PROVIDER + +BEGIN_PROVIDER [integer, i_unit_y_two_body_dm_ab] + implicit none + integer :: getUnitAndOpen + character*(128) :: file_name + file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_y') + i_unit_y_two_body_dm_ab = getUnitAndOpen(file_name,'w') + +END_PROVIDER + +BEGIN_PROVIDER [integer, i_unit_z_two_body_extra_diag_dm_ab] + implicit none + integer :: getUnitAndOpen + character*(128) :: file_name + file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_extra_diag') + i_unit_z_two_body_extra_diag_dm_ab = getUnitAndOpen(file_name,'w') + +END_PROVIDER + +BEGIN_PROVIDER [integer, i_unit_z_two_body_diag_dm_ab] + implicit none + integer :: getUnitAndOpen + character*(128) :: file_name + file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_diag') + i_unit_z_two_body_diag_dm_ab = getUnitAndOpen(file_name,'w') + +END_PROVIDER + +BEGIN_PROVIDER [integer, i_unit_z_two_body_total_dm_ab] + implicit none + integer :: getUnitAndOpen + character*(128) :: file_name + file_name = trim(trim(ezfio_filename)//'/properties/two_body_dm_total') + i_unit_z_two_body_total_dm_ab = getUnitAndOpen(file_name,'w') + +END_PROVIDER + diff --git a/plugins/Properties/test_two_body_dm.irp.f b/plugins/Properties/test_two_body_dm.irp.f new file mode 100644 index 00000000..6fc02abf --- /dev/null +++ b/plugins/Properties/test_two_body_dm.irp.f @@ -0,0 +1,67 @@ +program test_two_bod + implicit none + read_wf = .True. + touch read_wf + call routine +end +subroutine routine + implicit none + integer :: i,j,k,l + double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral_schwartz + accu = 0.d0 + + ! Diag part of the two body dm + do i = 1, n_act_orb + do j = 1, n_act_orb + accu += two_body_dm_ab_diag(i,j) * mo_bielec_integral_jj(i,j) + enddo + enddo + print*,'BI ELECTRONIC = ',accu + + double precision :: accu_extra_diag + accu_extra_diag = 0.d0 + do l = 1, n_act_orb ! p2 + do k = 1, n_act_orb ! h2 + do j = 1, n_act_orb ! p1 + do i = 1,n_act_orb ! h1 + accu_extra_diag += two_body_dm_ab_big_array(i,j,k,l) * get_mo_bielec_integral_schwartz(i,k,j,l,mo_integrals_map) + enddo + enddo + enddo + enddo + print*,'extra_diag = ',accu_extra_diag + double precision :: average_mono + call get_average(mo_mono_elec_integral,one_body_dm_mo,average_mono) + print*,'BI ELECTRONIC = ',accu+accu_extra_diag + print*,'MONO ELECTRONIC = ',average_mono + print*,'Total elec = ',accu+average_mono + accu_extra_diag + print*,'Total = ',accu+average_mono+nuclear_repulsion +accu_extra_diag + double precision :: e_0,hij + call u0_H_u_0(e_0,psi_coef,n_det,psi_det,N_int) + print*,' = ',e_0 + nuclear_repulsion + integer :: degree + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + double precision :: phase + integer :: n_elements + n_elements = 0 + accu = 0.d0 + do i = 1, N_det + do j = i+1, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + if(degree.gt.2)cycle +! if(degree.ne.1)cycle + call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + if(s1.eq.s2)cycle + n_elements += 1 + call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) + accu += 2.d0 * hij * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*,'n_elements = ',n_elements + print*,' Date: Thu, 21 Apr 2016 23:59:50 +0200 Subject: [PATCH 05/32] Integration for DFT seems to be ok, but need to improve the angular part --- config/ifort.cfg | 4 +- plugins/DFT_Utils/grid_density.irp.f | 106 +++++++++++------ plugins/DFT_Utils/integration_3d.irp.f | 2 +- plugins/DFT_Utils/integration_radial.irp.f | 110 ++++++++++++++---- .../test_integration_3d_density.irp.f | 24 ++++ plugins/Properties/eval_ab_two_body_dm.irp.f | 80 ------------- src/Determinants/two_body_dm_map.irp.f | 31 +++-- 7 files changed, 210 insertions(+), 147 deletions(-) create mode 100644 plugins/DFT_Utils/test_integration_3d_density.irp.f delete mode 100644 plugins/Properties/eval_ab_two_body_dm.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index 6e6dd389..a738a83c 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags @@ -50,7 +50,7 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz # -xSSE2 : Valgrind needs a very simple x86 executable # [DEBUG] -FC : -g -traceback +FC : -g -traceback -fpe0 FCFLAGS : -xSSE2 -C IRPF90_FLAGS : --openmp diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f index 7cb93a91..ac3b702f 100644 --- a/plugins/DFT_Utils/grid_density.irp.f +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -1,11 +1,11 @@ BEGIN_PROVIDER [integer, n_points_angular_grid] implicit none - n_points_angular_grid = 18 + n_points_angular_grid = 51 END_PROVIDER BEGIN_PROVIDER [integer, n_points_radial_grid] implicit none - n_points_radial_grid = 10 + n_points_radial_grid = 1000 END_PROVIDER @@ -16,7 +16,30 @@ END_PROVIDER ! weights and grid points for the integration on the angular variables on ! the unit sphere centered on (0,0,0) END_DOC - call cal_quad(n_points_aangular_grid, angular_quadrature_points,weights_angular_points) + call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) + +END_PROVIDER + +BEGIN_PROVIDER [integer , m_knowles] + implicit none + BEGIN_DOC +! value of the "m" parameter in the equation (7) of the paper of Knowles (JCP, 104, 1996) + END_DOC + m_knowles = 3 +END_PROVIDER + + BEGIN_PROVIDER [double precision, grid_points_radial, (n_points_radial_grid)] +&BEGIN_PROVIDER [double precision, dr_radial_integral] + + implicit none + BEGIN_DOC +! points in [0,1] to map the radial integral [0,\infty] + END_DOC + dr_radial_integral = 1.d0/dble(n_points_radial_grid-1) + integer :: i + do i = 1, n_points_radial_grid-1 + grid_points_radial(i) = (i-1) * dr_radial_integral + enddo END_PROVIDER @@ -27,46 +50,51 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid implicit none integer :: i,j,k double precision :: dr,x_ref,y_ref,z_ref - dr = 1.d0/dble(n_points_radial_grid-1) + double precision :: knowles_function do i = 1, nucl_num x_ref = nucl_coord(i,1) y_ref = nucl_coord(i,2) z_ref = nucl_coord(i,3) do j = 1, n_points_radial_grid - do k = 1, n_points_angular_grid - grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * dr - grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * dr - grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * dr + double precision :: x,r + x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] + r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration + do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom + grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r + grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r + grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r enddo enddo enddo END_PROVIDER -BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (nucl_num,n_points_angular_grid,n_points_radial_grid) ] +BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] BEGIN_DOC ! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) -! the "n" discrete variable represents the nucleis (j=1,nucl_num) +! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension +! and the points are labelled by the other dimensions END_DOC implicit none integer :: i,j,k,l,m double precision :: r(3) double precision :: accu,cell_function_becke double precision :: tmp_array(nucl_num) - do j = 1, nucl_num - do k = 1, n_points_radial_grid - do l = 1, n_points_angular_grid - r(1) = grid_points_per_atom(1,j,k,l) - r(2) = grid_points_per_atom(2,j,k,l) - r(3) = grid_points_per_atom(3,j,k,l) + ! run over all points in space + do j = 1, nucl_num ! that are referred to each atom + do k = 1, n_points_radial_grid !for each radial grid attached to the "jth" atom + do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom + r(1) = grid_points_per_atom(1,l,k,j) + r(2) = grid_points_per_atom(2,l,k,j) + r(3) = grid_points_per_atom(3,l,k,j) accu = 0.d0 - do i = 1, nucl_num - tmp_array(i) = cell_function_becke(r,i) + do i = 1, nucl_num ! For each of these points in space, ou need to evaluate the P_n(r) + ! function defined for each atom "i" by equation (13) and (21) with k == 3 + tmp_array(i) = cell_function_becke(r,i) ! P_n(r) + ! Then you compute the summ the P_n(r) function for each of the "r" points accu += tmp_array(i) enddo accu = 1.d0/accu - do i = 1, nucl_num - weight_functions_at_grid_points(i,j,k,l) = tmp_array(i)*accu - enddo + weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu enddo enddo enddo @@ -80,22 +108,34 @@ END_PROVIDER integer :: i,j,k,l,m double precision :: contrib double precision :: r(3) - double precision :: aos_array(ao_num) + double precision :: aos_array(ao_num),mos_array(mo_tot_num) do j = 1, nucl_num do k = 1, n_points_radial_grid do l = 1, n_points_angular_grid - r(1) = grid_points_per_atom(1,j,k,l) - r(2) = grid_points_per_atom(2,j,k,l) - r(3) = grid_points_per_atom(3,j,k,l) - call give_all_aos_at_r(r,aos_array) - one_body_dm_mo_alpha_at_grid_points(j,k,l) = 0.d0 - do i = 1, ao_num - do m = 1, ao_num - contrib = aos_array(i) * aos_array(m) - one_body_dm_mo_alpha_at_grid_points(j,k,l) += one_body_dm_ao_alpha(i,m) * contrib - one_body_dm_mo_beta_at_grid_points(j,k,l) += one_body_dm_ao_beta(i,m) * contrib - enddo + one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 + one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 + r(1) = grid_points_per_atom(1,l,k,j) + r(2) = grid_points_per_atom(2,l,k,j) + r(3) = grid_points_per_atom(3,l,k,j) + +! call give_all_aos_at_r(r,aos_array) +! do i = 1, ao_num +! do m = 1, ao_num +! contrib = aos_array(i) * aos_array(m) +! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib +! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib +! enddo +! enddo + + call give_all_mos_at_r(r,mos_array) + do i = 1, mo_tot_num + do m = 1, mo_tot_num + contrib = mos_array(i) * mos_array(m) + one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib + one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib + enddo enddo + enddo enddo enddo diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f index f4088302..e2c6d8d0 100644 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -5,7 +5,7 @@ double precision function step_function_becke(x) integer :: i,n_max_becke step_function_becke = f_function_becke(x) - n_max_becke = 2 + n_max_becke = 3 do i = 1, n_max_becke step_function_becke = f_function_becke(step_function_becke) enddo diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f index 59874b8b..3670db14 100644 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -3,46 +3,108 @@ implicit none double precision :: accu integer :: i,j,k,l - integer :: m_param_knowles - double precision :: dx,x - integer :: n_pt_int_radial + double precision :: x double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) double precision :: f_average_angular_alpha,f_average_angular_beta double precision :: derivative_knowles_function,knowles_function - n_pt_int_radial = 10 - dx = 1.d0/dble(n_pt_int_radial-1) - x = 0.d0 - m_param_knowles = 3 - do j = 1, nucl_num - integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 - do i = 1, n_points_radial_grid - ! Angular integration - f_average_angular_alpha = 0.d0 - f_average_angular_beta = 0.d0 - do k = 1, n_points_angular_grid - f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) - f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + + ! Run over all nuclei in order to perform the Voronoi partition + ! according ot equation (6) of the paper of Becke (JCP, (88), 1988) + ! Here the m index is referred to the w_m(r) weight functions of equation (22) + ! Run over all points of integrations : there are + ! n_points_radial_grid (i) * n_points_angular_grid (k) + do j = 1, nucl_num + integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 + integral_density_beta_knowles_becke_per_atom(j) = 0.d0 + do i = 1, n_points_radial_grid + ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" + f_average_angular_alpha = 0.d0 + f_average_angular_beta = 0.d0 + do k = 1, n_points_angular_grid + f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + enddo + ! + x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] + double precision :: contrib_integration +! print*,m_knowles + contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & + *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 + integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha + integral_density_beta_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_beta + enddo + integral_density_alpha_knowles_becke_per_atom(j) *= dr_radial_integral + integral_density_beta_knowles_becke_per_atom(j) *= dr_radial_integral enddo - integral_density_alpha_knowles_becke_per_atom(j) += derivative_knowles_function(alpha,m_param_knowles,x) & - *knowles_function(alpha,m_param_knowles,x)**2 & - *f_average_angular_alpha - x += dx - enddo - integral_density_alpha_knowles_becke_per_atom(j) *= dx - enddo END_PROVIDER double precision function knowles_function(alpha,m,x) implicit none + BEGIN_DOC +! function proposed by Knowles (JCP, 104, 1996) for distributing the radial points : +! the Log "m" function ( equation (7) in the paper ) + END_DOC double precision, intent(in) :: alpha,x integer, intent(in) :: m knowles_function = -alpha * dlog(1.d0-x**m) +!knowles_function = 1.d0 end double precision function derivative_knowles_function(alpha,m,x) implicit none + BEGIN_DOC +! derivative of the function proposed by Knowles (JCP, 104, 1996) for distributing the radial points + END_DOC double precision, intent(in) :: alpha,x integer, intent(in) :: m - derivative_knowles_function = m x**(m-1) / (alpha * dlog(1.d0-x**m)) + derivative_knowles_function = alpha * dble(m) * x**(m-1) / (1.d0 - x**m) end + + BEGIN_PROVIDER [double precision, alpha_knowles, (100)] + implicit none + integer :: i + BEGIN_DOC +! recommended values for the alpha parameters according to the paper of Knowles (JCP, 104, 1996) +! as a function of the nuclear charge + END_DOC + + ! H-He + alpha_knowles(1) = 5.d0 + alpha_knowles(2) = 5.d0 + + ! Li-Be + alpha_knowles(3) = 7.d0 + alpha_knowles(4) = 7.d0 + + ! B-Ne + do i = 5, 10 + alpha_knowles(i) = 5.d0 + enddo + + ! Na-Mg + do i = 11, 12 + alpha_knowles(i) = 7.d0 + enddo + + ! Al-Ar + do i = 13, 18 + alpha_knowles(i) = 5.d0 + enddo + + ! K-Ca + do i = 19, 20 + alpha_knowles(i) = 7.d0 + enddo + + ! Sc-Zn + do i = 21, 30 + alpha_knowles(i) = 5.d0 + enddo + + ! Ga-Kr + do i = 31, 36 + alpha_knowles(i) = 7.d0 + enddo + + END_PROVIDER diff --git a/plugins/DFT_Utils/test_integration_3d_density.irp.f b/plugins/DFT_Utils/test_integration_3d_density.irp.f new file mode 100644 index 00000000..93ce58f4 --- /dev/null +++ b/plugins/DFT_Utils/test_integration_3d_density.irp.f @@ -0,0 +1,24 @@ +program pouet + print*,'coucou' + read_wf = .True. + touch read_wf + print*,'m_knowles = ',m_knowles + call routine + +end +subroutine routine + implicit none + integer :: i + double precision :: accu(2) + accu = 0.d0 + do i = 1, nucl_num + accu(1) += integral_density_alpha_knowles_becke_per_atom(i) + accu(2) += integral_density_beta_knowles_becke_per_atom(i) + enddo + print*,'accu(1) = ',accu(1) + print*,'Nalpha = ',elec_alpha_num + print*,'accu(2) = ',accu(2) + print*,'Nalpha = ',elec_beta_num + + +end diff --git a/plugins/Properties/eval_ab_two_body_dm.irp.f b/plugins/Properties/eval_ab_two_body_dm.irp.f deleted file mode 100644 index 595b0087..00000000 --- a/plugins/Properties/eval_ab_two_body_dm.irp.f +++ /dev/null @@ -1,80 +0,0 @@ -program two_bod_ab_dm - implicit none - read_wf = .True. - touch read_wf - call routine - -end - -subroutine routine - implicit none - integer :: i,j,k,l - double precision :: dx1,dx2 - double precision :: interval_1,interval_2 - integer :: nx1,nx2 - double precision :: r1(3),r2(3) - double precision :: xmin_1,xmax_1,xmin_2,xmax_2 - double precision :: compute_extra_diag_two_body_dm_ab,two_bod_extra_diag - double precision :: compute_diag_two_body_dm_ab,two_bod_diag - - double precision,allocatable :: mos_array_r1(:),mos_array_r2(:) - double precision :: test_diag, test_extra_diag - double precision, allocatable :: x_array(:),y_array(:),z_diag_array(:),z_extra_diag_array(:),z_total_array(:) - allocate(mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num)) - - - - ! He triplet S - ! r1 = x - ! r2 = z - nx1 = 100 - nx2 = 100 - allocate(x_array(nx1),y_array(nx2),z_diag_array(nx1),z_extra_diag_array(nx1),z_total_array(nx1)) - xmin_1 = -2.d0 - xmax_1 = 2.d0 - xmin_2 = -2.d0 - xmax_2 = 2.d0 - interval_1 = xmax_1 - xmin_1 - interval_2 = xmax_2 - xmin_2 - dx1 = interval_1/dble(nx1) - dx2 = interval_2/dble(nx2) - r1 = 0.d0 - r2 = 0.d0 - - double precision :: x_tmp,y_tmp - x_tmp = xmin_1 - do i = 1, nx1 - x_array(i) = x_tmp - write(i_unit_x_two_body_dm_ab,'(10000(F16.10,X))')x_array(i) - x_tmp += dx1 - enddo - x_tmp = xmin_2 - do i = 1, nx1 - y_array(i) = x_tmp - write(i_unit_y_two_body_dm_ab,'(10000(F16.10,X))')x_array(i) - x_tmp += dx2 - enddo - - - ! initialization - r1(1) = xmin_1 - do i = 1, nx1 - r2(3) = xmin_2 - do j = 1, nx2 - two_bod_extra_diag = compute_extra_diag_two_body_dm_ab(r1,r2) - two_bod_diag = compute_diag_two_body_dm_ab(r1,r2) - z_diag_array(j) = two_bod_diag - z_extra_diag_array(j) = two_bod_extra_diag - z_total_array(j) = two_bod_extra_diag + two_bod_diag -! write(i_unit_two_body_dm_ab,'(100(F16.10,X))')r1(1),r2(3),two_bod_diag,two_bod_extra_diag,two_bod_diag+two_bod_extra_diag - r2(3) += dx2 - enddo - write(i_unit_z_two_body_diag_dm_ab,'(10000(F16.10,X))')z_diag_array(:) - write(i_unit_z_two_body_extra_diag_dm_ab,'(10000(F16.10,X))')z_extra_diag_array(:) - write(i_unit_z_two_body_total_dm_ab,'(10000(F16.10,X))')z_total_array(:) - r1(1) += dx1 - enddo - - deallocate(mos_array_r1,mos_array_r2) - -end diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index c89b1125..f88d6ea3 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -242,7 +242,24 @@ BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array, (n_act_orb,n_act_orb if(degree>2)cycle call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) +! if(i==3.or.j==3)then +! print*,'i,j = ',i,j +! call debug_det(psi_det(1,1,i),N_int) +! call debug_det(psi_det(1,1,j),N_int) +! print*,degree,s1,s2 +! print*,h1,p1,h2,p2 +! print*,phase +! pause +! endif contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase +! print*,'coucou' +! print*,'i,j = ',i,j +! print*,'contrib = ',contrib +! print*,h1,p1,h2,p2 +! print*,'s1,s2',s1,s2 +! call debug_det(psi_det(1,1,i),N_int) +! call debug_det(psi_det(1,1,j),N_int) +! pause if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J @@ -288,7 +305,7 @@ end double precision function compute_extra_diag_two_body_dm_ab(r1,r2) implicit none - double precision :: r1(3),r2(3) + double precision, intent(in) :: r1(3),r2(3) integer :: i,j,k,l double precision :: mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num) double precision :: contrib @@ -298,16 +315,16 @@ double precision function compute_extra_diag_two_body_dm_ab(r1,r2) call give_all_act_mos_at_r(r1,mos_array_r1) call give_all_act_mos_at_r(r2,mos_array_r2) do l = 1, n_act_orb ! p2 - contrib = mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle do k = 1, n_act_orb ! h2 -! contrib *= mos_array_r2(k) -! if(dabs(contrib*mos_array_r2(k)).lt.threshld_two_bod_dm)cycle do j = 1, n_act_orb ! p1 -! contrib *= mos_array_r1(j) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle do i = 1,n_act_orb ! h1 double precision :: contrib_tmp +! print*,'i,j',i,j +! print*,mos_array_r1(i) , mos_array_r1(j) +! print*,'k,l',k,l +! print*,mos_array_r2(k) * mos_array_r2(l) +! print*,'gama = ',two_body_dm_ab_big_array(i,j,k,l) +! pause contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) compute_extra_diag_two_body_dm_ab += two_body_dm_ab_big_array(i,j,k,l) * contrib_tmp enddo From a0d58690546d906304978f83e8e360d66690e7d6 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 16 Jul 2016 16:09:50 +0200 Subject: [PATCH 06/32] Modifs of fobo-scf --- config/ifort.cfg | 2 +- plugins/All_singles/H_apply.irp.f | 7 + plugins/All_singles/all_1h_1p.irp.f | 2 +- plugins/All_singles/all_1h_1p_singles.irp.f | 76 + plugins/DFT_Utils/grid_density.irp.f | 31 +- plugins/DFT_Utils/integration_3d.irp.f | 34 +- plugins/DFT_Utils/integration_radial.irp.f | 3 +- plugins/FOBOCI/SC2_1h1p.irp.f | 699 +++++ plugins/FOBOCI/fobo_scf.irp.f | 2 +- .../foboci_lmct_mlct_threshold_old.irp.f | 4 + plugins/Properties/delta_rho.irp.f | 6 +- plugins/Properties/mulliken.irp.f | 15 +- plugins/Properties/print_spin_density.irp.f | 36 + plugins/Properties/provide_deltarho.irp.f | 11 + plugins/Properties/test_two_body_dm.irp.f | 46 +- plugins/loc_cele/loc_cele.irp.f | 309 +-- src/Bitmask/bitmasks.irp.f | 84 +- src/Determinants/density_matrix.irp.f | 12 +- ...gonalize_restart_and_save_all_states.irp.f | 16 + ...nalize_restart_and_save_lowest_state.irp.f | 25 + ...gonalize_restart_and_save_one_states.irp.f | 26 + ...gonalize_restart_and_save_two_states.irp.f | 27 + src/Determinants/occ_pattern.irp.f | 2 +- src/Determinants/print_H_matrix_restart.irp.f | 179 ++ src/Determinants/print_bitmask.irp.f | 11 + src/Determinants/print_holes_particles.irp.f | 36 + src/Determinants/print_wf.irp.f | 71 + src/Determinants/save_only_singles.irp.f | 50 + src/Determinants/test_3d.irp.f | 15 + src/Determinants/test_two_body.irp.f | 18 + src/Determinants/truncate_wf.irp.f | 23 +- src/Determinants/two_body_dm_map.irp.f | 369 ++- src/Integrals_Bielec/EZFIO.cfg | 7 + src/Integrals_Bielec/mo_bi_integrals.irp.f | 40 +- src/MO_Basis/mo_permutation.irp.f | 20 + src/MO_Basis/print_aos.irp.f | 53 + src/MO_Basis/print_mo_in_space.irp.f | 50 + src/Nuclei/atomic_radii.irp.f | 112 + src/Utils/angular_integration.irp.f | 2264 +++++++++++++++++ 39 files changed, 4424 insertions(+), 369 deletions(-) create mode 100644 plugins/All_singles/all_1h_1p_singles.irp.f create mode 100644 plugins/FOBOCI/SC2_1h1p.irp.f create mode 100644 plugins/Properties/print_spin_density.irp.f create mode 100644 plugins/Properties/provide_deltarho.irp.f create mode 100644 src/Determinants/diagonalize_restart_and_save_all_states.irp.f create mode 100644 src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f create mode 100644 src/Determinants/diagonalize_restart_and_save_one_states.irp.f create mode 100644 src/Determinants/diagonalize_restart_and_save_two_states.irp.f create mode 100644 src/Determinants/print_H_matrix_restart.irp.f create mode 100644 src/Determinants/print_bitmask.irp.f create mode 100644 src/Determinants/print_holes_particles.irp.f create mode 100644 src/Determinants/print_wf.irp.f create mode 100644 src/Determinants/save_only_singles.irp.f create mode 100644 src/Determinants/test_3d.irp.f create mode 100644 src/Determinants/test_two_body.irp.f create mode 100644 src/MO_Basis/mo_permutation.irp.f create mode 100644 src/MO_Basis/print_aos.irp.f create mode 100644 src/MO_Basis/print_mo_in_space.irp.f create mode 100644 src/Nuclei/atomic_radii.irp.f create mode 100644 src/Utils/angular_integration.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index a738a83c..da414912 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/All_singles/H_apply.irp.f b/plugins/All_singles/H_apply.irp.f index f34f003c..cb0976af 100644 --- a/plugins/All_singles/H_apply.irp.f +++ b/plugins/All_singles/H_apply.irp.f @@ -8,6 +8,13 @@ s.unset_skip() s.filter_only_1h1p() print s +s = H_apply("just_1h_1p_singles",do_double_exc=False) +s.set_selection_pt2("epstein_nesbet_2x2") +s.unset_skip() +s.filter_only_1h1p() +print s + + s = H_apply("just_mono",do_double_exc=False) s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() diff --git a/plugins/All_singles/all_1h_1p.irp.f b/plugins/All_singles/all_1h_1p.irp.f index a2786248..7a3700b1 100644 --- a/plugins/All_singles/all_1h_1p.irp.f +++ b/plugins/All_singles/all_1h_1p.irp.f @@ -49,7 +49,7 @@ subroutine routine endif call save_wavefunction if(n_det_before == N_det)then - selection_criterion = selection_criterion * 0.5d0 + selection_criterion_factor = selection_criterion_factor * 0.5d0 endif enddo diff --git a/plugins/All_singles/all_1h_1p_singles.irp.f b/plugins/All_singles/all_1h_1p_singles.irp.f new file mode 100644 index 00000000..b76a14b3 --- /dev/null +++ b/plugins/All_singles/all_1h_1p_singles.irp.f @@ -0,0 +1,76 @@ +program restart_more_singles + BEGIN_DOC + ! Generates and select single and double excitations of type 1h-1p + ! on the top of a given restart wave function of type CAS + END_DOC + read_wf = .true. + touch read_wf + print*,'ref_bitmask_energy = ',ref_bitmask_energy + call routine + +end +subroutine routine + implicit none + integer :: i,k + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) + integer :: N_st, degree + integer :: n_det_before + N_st = N_states + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) + i = 0 + print*,'N_det = ',N_det + print*,'n_det_max = ',n_det_max + print*,'pt2_max = ',pt2_max + pt2=-1.d0 + E_before = ref_bitmask_energy + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + n_det_before = N_det + i += 1 + print*,'-----------------------' + print*,'i = ',i + call H_apply_just_1h_1p_singles(pt2, norm_pert, H_pert_diag, N_st) + call diagonalize_CI + print*,'N_det = ',N_det + print*,'E = ',CI_energy(1) + print*,'pt2 = ',pt2(1) + print*,'E+PT2 = ',E_before + pt2(1) + E_before = CI_energy + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1)) + enddo + endif + call save_wavefunction + if(n_det_before == N_det)then + selection_criterion_factor = selection_criterion_factor * 0.5d0 + endif + + enddo + + threshold_davidson = 1.d-10 + soft_touch threshold_davidson davidson_criterion + call diagonalize_CI + if(N_states_diag.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i) - CI_energy(1) + enddo + endif + if(N_states.gt.1)then + print*,'Variational + perturbative Energy difference' + do i = 2, N_st + print*,'Delta E = ',CI_energy(i)+ pt2(i) - (CI_energy(1) + pt2(1)) + enddo + endif + call ezfio_set_all_singles_energy(CI_energy) + + call save_wavefunction + deallocate(pt2,norm_pert) +end diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f index ac3b702f..6071a18b 100644 --- a/plugins/DFT_Utils/grid_density.irp.f +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -1,11 +1,11 @@ BEGIN_PROVIDER [integer, n_points_angular_grid] implicit none - n_points_angular_grid = 51 + n_points_angular_grid = 50 END_PROVIDER BEGIN_PROVIDER [integer, n_points_radial_grid] implicit none - n_points_radial_grid = 1000 + n_points_radial_grid = 10000 END_PROVIDER @@ -15,8 +15,28 @@ END_PROVIDER BEGIN_DOC ! weights and grid points for the integration on the angular variables on ! the unit sphere centered on (0,0,0) +! According to the LEBEDEV scheme END_DOC call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) + include 'constants.include.F' + integer :: i + double precision :: accu + double precision :: degre_rad +!degre_rad = 180.d0/pi +!accu = 0.d0 +!do i = 1, n_points_integration_angular_lebedev +! accu += weights_angular_integration_lebedev(i) +! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi +! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) & +! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) +! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) & +! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) +! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) +!enddo +!print*,'ANGULAR' +!print*,'' +!print*,'accu = ',accu +!ASSERT( dabs(accu - 1.D0) < 1.d-10) END_PROVIDER @@ -55,7 +75,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid x_ref = nucl_coord(i,1) y_ref = nucl_coord(i,2) z_ref = nucl_coord(i,3) - do j = 1, n_points_radial_grid + do j = 1, n_points_radial_grid-1 double precision :: x,r x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration @@ -81,7 +101,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang double precision :: tmp_array(nucl_num) ! run over all points in space do j = 1, nucl_num ! that are referred to each atom - do k = 1, n_points_radial_grid !for each radial grid attached to the "jth" atom + do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) @@ -95,6 +115,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang enddo accu = 1.d0/accu weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu +! print*,weight_functions_at_grid_points(l,k,j) enddo enddo enddo @@ -110,7 +131,7 @@ END_PROVIDER double precision :: r(3) double precision :: aos_array(ao_num),mos_array(mo_tot_num) do j = 1, nucl_num - do k = 1, n_points_radial_grid + do k = 1, n_points_radial_grid -1 do l = 1, n_points_angular_grid one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f index e2c6d8d0..43eb1ab8 100644 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -4,12 +4,18 @@ double precision function step_function_becke(x) double precision :: f_function_becke integer :: i,n_max_becke - step_function_becke = f_function_becke(x) - n_max_becke = 3 - do i = 1, n_max_becke - step_function_becke = f_function_becke(step_function_becke) - enddo - step_function_becke = 0.5d0*(1.d0 - step_function_becke) +!if(x.lt.-1.d0)then +! step_function_becke = 0.d0 +!else if (x .gt.1)then +! step_function_becke = 0.d0 +!else + step_function_becke = f_function_becke(x) +!!n_max_becke = 1 + do i = 1, 4 + step_function_becke = f_function_becke(step_function_becke) + enddo + step_function_becke = 0.5d0*(1.d0 - step_function_becke) +!endif end double precision function f_function_becke(x) @@ -46,19 +52,3 @@ double precision function cell_function_becke(r,atom_number) enddo end -double precision function weight_function_becke(r,atom_number) - implicit none - double precision, intent(in) :: r(3) - integer, intent(in) :: atom_number - BEGIN_DOC - ! atom_number :: atom on which the weight function of Becke (1988, JCP,88(4)) - ! r(1:3) :: x,y,z coordinantes of the current point - END_DOC - double precision :: cell_function_becke,accu - integer :: j - accu = 0.d0 - do j = 1, nucl_num - accu += cell_function_becke(r,j) - enddo - weight_function_becke = cell_function_becke(r,atom_number)/accu -end diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f index 3670db14..4943783b 100644 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -16,7 +16,7 @@ do j = 1, nucl_num integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 integral_density_beta_knowles_becke_per_atom(j) = 0.d0 - do i = 1, n_points_radial_grid + do i = 1, n_points_radial_grid-1 ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" f_average_angular_alpha = 0.d0 f_average_angular_beta = 0.d0 @@ -48,7 +48,6 @@ END_PROVIDER double precision, intent(in) :: alpha,x integer, intent(in) :: m knowles_function = -alpha * dlog(1.d0-x**m) -!knowles_function = 1.d0 end double precision function derivative_knowles_function(alpha,m,x) diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f new file mode 100644 index 00000000..d347c6e5 --- /dev/null +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -0,0 +1,699 @@ +subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: diag_H_elements(dim_in) + double precision, intent(in) :: convergence + + integer :: i,j,k,l + integer :: n_singles + integer :: index_singles(sze),hole_particles_singles(sze,3) + integer :: n_doubles + integer :: index_doubles(sze),hole_particles_doubles(sze,2) + integer :: index_hf + double precision :: e_corr_singles(mo_tot_num,2) + double precision :: e_corr_doubles(mo_tot_num) + double precision :: e_corr_singles_total(2) + double precision :: e_corr_doubles_1h1p + + integer :: exc(0:2,2,2),degree + integer :: h1,h2,p1,p2,s1,s2 + integer :: other_spin(2) + double precision :: phase + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i_ok + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: hij,c_ref,contrib + integer :: iorb + + other_spin(1) = 2 + other_spin(2) = 1 + + n_singles = 0 + n_doubles = 0 + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij) + diag_H_elements(i) = hij + if(degree == 0)then + index_hf = i + else if (degree == 1)then + n_singles +=1 + index_singles(n_singles) = i + ! h1 = inactive orbital of the hole + hole_particles_singles(n_singles,1) = h1 + ! p1 = virtual orbital of the particle + hole_particles_singles(n_singles,2) = p1 + ! s1 = spin of the electron excited + hole_particles_singles(n_singles,3) = s1 + else if (degree == 2)then + n_doubles +=1 + index_doubles(n_doubles) = i + ! h1 = inactive orbital of the hole (beta of course) + hole_particles_doubles(n_doubles,1) = h1 + ! p1 = virtual orbital of the particle (alpha of course) + hole_particles_doubles(n_doubles,2) = p2 + else + print*,'PB !! found out other thing than a single or double' + print*,'stopping ..' + stop + endif + enddo + + e_corr_singles = 0.d0 + e_corr_doubles = 0.d0 + e_corr_singles_total = 0.d0 + e_corr_doubles_1h1p = 0.d0 + c_ref = 1.d0/u_in(index_hf,1) + print*,'c_ref = ',c_ref + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij) + contrib = hij * u_in(i,1) * c_ref + if (degree == 1)then + e_corr_singles(h1,s1) += contrib + e_corr_singles(p1,s1) += contrib + e_corr_singles_total(s1)+= contrib + else if (degree == 2)then + e_corr_doubles_1h1p += contrib + e_corr_doubles(h1) += contrib + e_corr_doubles(p2) += contrib + endif + enddo + print*,'e_corr_singles alpha = ',e_corr_singles_total(1) + print*,'e_corr_singles beta = ',e_corr_singles_total(2) + print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p + + ! repeat all the correlation energy on the singles + do i = 1,n_singles + ! you can repeat all the correlation energy of the single excitation of the other spin + diag_H_elements(index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3))) + + ! you can repeat all the correlation energy of the single excitation of the same spin + do j = 1, n_inact_orb + iorb = list_inact(j) + ! except the one of the hole + if(iorb == hole_particles_singles(i,1))cycle + ! ispin = hole_particles_singles(i,3) + diag_H_elements(index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3)) + enddo + ! also exclude all the energy coming from the virtual orbital + diag_H_elements(index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3)) + + ! If it is a single excitation alpha, you can repeat : + ! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r" + ! If it is a single excitation alpha, you can repeat : + ! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i" + diag_H_elements(index_singles(i)) += e_corr_doubles_1h1p + if(hole_particles_singles(i,3) == 1)then ! alpha single excitation + diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2)) + else ! beta single exctitation + diag_H_elements(index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1)) + endif + enddo + + ! repeat all the correlation energy on the doubles + ! as all the doubles involve the active space, you cannot repeat any of them one on another + do i = 1, n_doubles + ! on a given double, you can repeat all the correlation energy of the singles alpha + do j = 1, n_inact_orb + iorb = list_inact(j) + ! ispin = hole_particles_singles(i,3) + diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,1) + enddo + ! except the part involving the virtual orbital "hole_particles_doubles(i,2)" + diag_H_elements(index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1) + ! on a given double, you can repeat all the correlation energy of the singles beta + do j = 1, n_inact_orb + iorb = list_inact(j) + ! except the one of the hole + if(iorb == hole_particles_doubles(i,1))cycle + ! ispin = hole_particles_singles(i,3) + diag_H_elements(index_doubles(i)) += e_corr_singles(iorb,2) + enddo + enddo + + + ! Taking into account the connected part of the 2h2p on the HF determinant + ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} + +! diag_H_elements(index_hf) += total_corr_e_2h2p + c_ref = c_ref * c_ref + print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf) + do i = 1, n_singles + ! start on the single excitation "|i>" + h1 = hole_particles_singles(i,1) + p1 = hole_particles_singles(i,2) + do j = 1, n_singles + do k = 1, N_int + key_tmp(k,1) = dets_in(k,1,index_singles(i)) + key_tmp(k,2) = dets_in(k,2,index_singles(i)) + enddo + h2 = hole_particles_singles(j,1) + p2 = hole_particles_singles(j,2) + call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) + ! apply the excitation operator from the single excitation "|j>" + if(i_ok .ne. 1)cycle + double precision :: phase_ref_other_single,diag_H_mat_elem,hijj,contrib_e2,coef_1 + call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int) + call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_ref_other_single,N_int) + call i_H_j(ref_bitmask,key_tmp,N_int,hij) + diag_H_elements(index_hf) += u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * hij & + * phase_single_double * phase_ref_other_single + enddo + enddo + print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf) + +end + +subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: u_in(dim_in,N_st) + double precision, intent(inout) :: H_matrix(sze,sze) + double precision, intent(in) :: convergence + + integer :: i,j,k,l + integer :: n_singles + integer :: index_singles(sze),hole_particles_singles(sze,3) + integer :: n_doubles + integer :: index_doubles(sze),hole_particles_doubles(sze,2) + integer :: index_hf + double precision :: e_corr_singles(mo_tot_num,2) + double precision :: e_corr_doubles(mo_tot_num) + double precision :: e_corr_singles_total(2) + double precision :: e_corr_doubles_1h1p + + integer :: exc(0:2,2,2),degree + integer :: h1,h2,p1,p2,s1,s2 + integer :: other_spin(2) + double precision :: phase + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i_ok + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: hij,c_ref,contrib + integer :: iorb + + other_spin(1) = 2 + other_spin(2) = 1 + + n_singles = 0 + n_doubles = 0 + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + if(degree == 0)then + index_hf = i + else if (degree == 1)then + n_singles +=1 + index_singles(n_singles) = i + ! h1 = inactive orbital of the hole + hole_particles_singles(n_singles,1) = h1 + ! p1 = virtual orbital of the particle + hole_particles_singles(n_singles,2) = p1 + ! s1 = spin of the electron excited + hole_particles_singles(n_singles,3) = s1 + else if (degree == 2)then + n_doubles +=1 + index_doubles(n_doubles) = i + ! h1 = inactive orbital of the hole (beta of course) + hole_particles_doubles(n_doubles,1) = h1 + ! p1 = virtual orbital of the particle (alpha of course) + hole_particles_doubles(n_doubles,2) = p2 + else + print*,'PB !! found out other thing than a single or double' + print*,'stopping ..' + stop + endif + enddo + double precision, allocatable :: dressing_H_mat_elem(:) + allocate(dressing_H_mat_elem(N_det)) + logical :: lmct + dressing_H_mat_elem = 0.d0 + call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det) + lmct = .False. + call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,1000) + lmct = .true. + call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,1000) + do i = 1, N_det + H_matrix(i,i) += dressing_H_mat_elem(i) + enddo + + e_corr_singles = 0.d0 + e_corr_doubles = 0.d0 + e_corr_singles_total = 0.d0 + e_corr_doubles_1h1p = 0.d0 + c_ref = 1.d0/u_in(index_hf,1) + print*,'c_ref = ',c_ref + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call i_H_j(ref_bitmask,dets_in(1,1,i),N_int,hij) + contrib = hij * u_in(i,1) * c_ref + if (degree == 1)then + e_corr_singles(h1,s1) += contrib + e_corr_singles(p1,s1) += contrib + e_corr_singles_total(s1)+= contrib + else if (degree == 2)then + e_corr_doubles_1h1p += contrib + e_corr_doubles(h1) += contrib + e_corr_doubles(p2) += contrib + endif + enddo + print*,'e_corr_singles alpha = ',e_corr_singles_total(1) + print*,'e_corr_singles beta = ',e_corr_singles_total(2) + print*,'e_corr_doubles_1h1p = ',e_corr_doubles_1h1p + + + ! repeat all the correlation energy on the singles +! do i = 1,n_singles +! ! you can repeat all the correlation energy of the single excitation of the other spin +! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles_total(other_spin(hole_particles_singles(i,3))) + +! ! you can repeat all the correlation energy of the single excitation of the same spin +! do j = 1, n_inact_orb +! iorb = list_inact(j) +! ! except the one of the hole +! if(iorb == hole_particles_singles(i,1))cycle +! ! ispin = hole_particles_singles(i,3) +! H_matrix(index_singles(i),index_singles(i)) += e_corr_singles(iorb,hole_particles_singles(i,3)) +! enddo +! ! also exclude all the energy coming from the virtual orbital +! H_matrix(index_singles(i),index_singles(i)) -= e_corr_singles(hole_particles_singles(i,2),hole_particles_singles(i,3)) +! +! ! If it is a single excitation alpha, you can repeat : +! ! +) all the double excitation 1h1p, appart the part involving the virtual orbital "r" +! ! If it is a single excitation alpha, you can repeat : +! ! +) all the double excitation 1h1p, appart the part involving the inactive orbital "i" +! H_matrix(index_singles(i),index_singles(i)) += e_corr_doubles_1h1p +! if(hole_particles_singles(i,3) == 1)then ! alpha single excitation +! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,2)) +! else ! beta single exctitation +! H_matrix(index_singles(i),index_singles(i)) -= e_corr_doubles(hole_particles_singles(i,1)) +! endif +! enddo + +! ! repeat all the correlation energy on the doubles +! ! as all the doubles involve the active space, you cannot repeat any of them one on another +! do i = 1, n_doubles +! ! on a given double, you can repeat all the correlation energy of the singles alpha +! do j = 1, n_inact_orb +! iorb = list_inact(j) +! ! ispin = hole_particles_singles(i,3) +! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,1) +! enddo +! ! except the part involving the virtual orbital "hole_particles_doubles(i,2)" +! H_matrix(index_doubles(i),index_doubles(i)) -= e_corr_singles(hole_particles_doubles(i,2),1) +! ! on a given double, you can repeat all the correlation energy of the singles beta +! do j = 1, n_inact_orb +! iorb = list_inact(j) +! ! except the one of the hole +! if(iorb == hole_particles_doubles(i,1))cycle +! ! ispin = hole_particles_singles(i,3) +! H_matrix(index_doubles(i),index_doubles(i)) += e_corr_singles(iorb,2) +! enddo +! enddo + + + ! Taking into account the connected part of the 2h2p on the HF determinant + ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} + +! H_matrix(index_hf) += total_corr_e_2h2p + print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf) + do i = 1, n_singles + ! start on the single excitation "|i>" + h1 = hole_particles_singles(i,1) + p1 = hole_particles_singles(i,2) + print*,'i = ',i + do j = i+1, n_singles + do k = 1, N_int + key_tmp(k,1) = dets_in(k,1,index_singles(i)) + key_tmp(k,2) = dets_in(k,2,index_singles(i)) + enddo + h2 = hole_particles_singles(j,1) + p2 = hole_particles_singles(j,2) + call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) + ! apply the excitation operator from the single excitation "|j>" + if(i_ok .ne. 1)cycle + double precision :: H_array(sze),diag_H_mat_elem,hjj + do k = 1, sze + call get_excitation_degree(dets_in(1,1,k),key_tmp,degree,N_int) + H_array(k) = 0.d0 + if(degree > 2)cycle + call i_H_j(dets_in(1,1,k),key_tmp,N_int,hij) + H_array(k) = hij + enddo + hjj = 1.d0/(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) +! contrib_e2 = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * hij * hij)) + do l = 2, sze +! pause + H_matrix(l,l) += H_array(l) * H_array(l) * hjj +! H_matrix(1,l) += H_array(1) * H_array(l) * hjj +! H_matrix(l,1) += H_array(1) * H_array(l) * hjj + enddo + enddo + enddo + print*,'H_matrix(index_hf,index_hf) = ',H_matrix(index_hf,index_hf) + +end + +subroutine SC2_1h1p_full(dets_in,u_in,energies,H_matrix,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: H_matrix(sze,sze) + double precision, intent(in) :: convergence + integer :: i,j,iter + print*,'sze = ',sze + do iter = 1, 1 +! if(sze<=N_det_max_jacobi)then + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) + allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) + H_matrix_tmp = 0.d0 + call dressing_1h1p_full(dets_in,u_in,H_matrix_tmp,dim_in,sze,N_st,Nint,convergence) + do j=1,sze + do i=1,sze + H_matrix_tmp(i,j) += H_matrix_all_dets(i,j) + enddo + enddo + print*,'passed the dressing' + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_tmp,size(H_matrix_all_dets,1),sze) + do j=1,min(N_states_diag,sze) + do i=1,sze + u_in(i,j) = eigenvectors(i,j) + enddo + energies(j) = eigenvalues(j) + enddo + deallocate (H_matrix_tmp, eigenvalues, eigenvectors) +! else +! call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) +! endif + print*,'E = ',energies(1) + nuclear_repulsion + + enddo + + +end + + +subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: diag_H_elements(dim_in) + double precision, intent(in) :: convergence + integer :: i,j,iter + do iter = 1, 1 + call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) + if(sze<=N_det_max_jacobi)then + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) + allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) + do j=1,sze + do i=1,sze + H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) + enddo + enddo + do i = 1,sze + H_matrix_tmp(i,i) = diag_H_elements(i) + enddo + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_tmp,size(H_matrix_all_dets,1),sze) + do j=1,min(N_states_diag,sze) + do i=1,sze + u_in(i,j) = eigenvectors(i,j) + enddo + energies(j) = eigenvalues(j) + enddo + deallocate (H_matrix_tmp, eigenvalues, eigenvectors) + else + call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) + endif + print*,'E = ',energies(1) + nuclear_repulsion + + enddo + + +end + + +subroutine density_matrix_1h1p(dets_in,u_in,density_matrix_alpha,density_matrix_beta,norm,dim_in,sze,N_st,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(inout) :: density_matrix_alpha(mo_tot_num_align,mo_tot_num) + double precision, intent(inout) :: density_matrix_beta(mo_tot_num_align,mo_tot_num) + double precision, intent(inout) :: norm + + integer :: i,j,k,l + integer :: n_singles + integer :: index_singles(sze),hole_particles_singles(sze,3) + integer :: n_doubles + integer :: index_doubles(sze),hole_particles_doubles(sze,2) + integer :: index_hf + + integer :: exc(0:2,2,2),degree + integer :: h1,h2,p1,p2,s1,s2 + integer :: other_spin(2) + double precision :: phase + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i_ok + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: hij,c_ref,contrib + integer :: iorb + + other_spin(1) = 2 + other_spin(2) = 1 + + n_singles = 0 + n_doubles = 0 + norm = 0.d0 + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + norm += u_in(i,1)* u_in(i,1) + if(degree == 0)then + index_hf = i + c_ref = 1.d0/psi_coef(i,1) + else if (degree == 1)then + n_singles +=1 + index_singles(n_singles) = i + ! h1 = inactive orbital of the hole + hole_particles_singles(n_singles,1) = h1 + ! p1 = virtual orbital of the particle + hole_particles_singles(n_singles,2) = p1 + ! s1 = spin of the electron excited + hole_particles_singles(n_singles,3) = s1 + else if (degree == 2)then + n_doubles +=1 + index_doubles(n_doubles) = i + ! h1 = inactive orbital of the hole (beta of course) + hole_particles_doubles(n_doubles,1) = h1 + ! p1 = virtual orbital of the particle (alpha of course) + hole_particles_doubles(n_doubles,2) = p2 + else + print*,'PB !! found out other thing than a single or double' + print*,'stopping ..' + stop + endif + enddo + print*,'norm = ',norm + + ! Taking into account the connected part of the 2h2p on the HF determinant + ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} + + do i = 1, n_singles + ! start on the single excitation "|i>" + h1 = hole_particles_singles(i,1) + p1 = hole_particles_singles(i,2) + do j = 1, n_singles + do k = 1, N_int + key_tmp(k,1) = dets_in(k,1,index_singles(i)) + key_tmp(k,2) = dets_in(k,2,index_singles(i)) + enddo + h2 = hole_particles_singles(j,1) + p2 = hole_particles_singles(j,2) + call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) + ! apply the excitation operator from the single excitation "|j>" + if(i_ok .ne. 1)cycle + double precision :: coef_ijrs,phase_other_single_ref + integer :: occ(N_int*bit_kind_size,2),n_occ(2) + call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_single_double,N_int) + call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) + call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) + coef_ijrs = u_in(index_singles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & + * phase_single_double * phase_other_single_ref + call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int) + do k=1,elec_alpha_num + l = occ(k,1) + density_matrix_alpha(l,l) += coef_ijrs*coef_ijrs + enddo + do k=1,elec_beta_num + l = occ(k,1) + density_matrix_beta(l,l) += coef_ijrs*coef_ijrs + enddo + norm += coef_ijrs* coef_ijrs + if(hole_particles_singles(j,3) == 1)then ! single alpha + density_matrix_alpha(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref + density_matrix_alpha(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref + else + density_matrix_beta(h2,p2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref + density_matrix_beta(p2,h2) += coef_ijrs * phase_single_double * u_in(index_singles(i),1) * c_ref + endif + enddo + enddo + + + do i = 1, n_doubles + ! start on the double excitation "|i>" + h1 = hole_particles_doubles(i,1) + p1 = hole_particles_doubles(i,2) + do j = 1, n_singles + do k = 1, N_int + key_tmp(k,1) = dets_in(k,1,index_doubles(i)) + key_tmp(k,2) = dets_in(k,2,index_doubles(i)) + enddo + h2 = hole_particles_singles(j,1) + p2 = hole_particles_singles(j,2) + call do_mono_excitation(key_tmp,h2,p2,hole_particles_singles(j,3),i_ok) + ! apply the excitation operator from the single excitation "|j>" + if(i_ok .ne. 1)cycle + double precision :: coef_ijrs_kv,phase_double_triple + call get_excitation(key_tmp,dets_in(1,1,index_singles(i)),exc,degree,phase_double_triple,N_int) + call get_excitation(ref_bitmask,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) + call get_excitation(key_tmp,dets_in(1,1,index_singles(j)),exc,degree,phase_other_single_ref,N_int) + coef_ijrs_kv = u_in(index_doubles(i),1) * u_in(index_singles(j),1) * c_ref * c_ref & + * phase_double_triple * phase_other_single_ref + call bitstring_to_list_ab(key_tmp, occ, n_occ, N_int) + do k=1,elec_alpha_num + l = occ(k,1) + density_matrix_alpha(l,l) += coef_ijrs_kv*coef_ijrs_kv + enddo + do k=1,elec_beta_num + l = occ(k,1) + density_matrix_beta(l,l) += coef_ijrs_kv*coef_ijrs_kv + enddo + norm += coef_ijrs_kv* coef_ijrs_kv + if(hole_particles_singles(j,3) == 1)then ! single alpha + density_matrix_alpha(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref + density_matrix_alpha(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref + else + density_matrix_beta(h2,p2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref + density_matrix_beta(p2,h2) += coef_ijrs_kv * phase_double_triple * u_in(index_doubles(i),1) * c_ref + endif + enddo + enddo + + + + + print*,'norm = ',norm + norm = 1.d0/norm + do i = 1, mo_tot_num + do j = 1, mo_tot_num + density_matrix_alpha(i,j) *= norm + density_matrix_beta(i,j) *= norm + enddo + enddo + coef_ijrs = 0.d0 + do i = 1, mo_tot_num + coef_ijrs += density_matrix_beta(i,i) + density_matrix_beta(i,i) + enddo + print*,'accu = ',coef_ijrs + +end + diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 0b0902b0..8656b633 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,6 +1,6 @@ program foboscf implicit none -!call run_prepare + call run_prepare no_oa_or_av_opt = .True. touch no_oa_or_av_opt call routine_fobo_scf diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index dc6519b8..e81b3fc1 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -81,6 +81,8 @@ subroutine FOBOCI_lmct_mlct_old_thr call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) call all_single + call make_s2_eigenfunction + call diagonalize_ci ! if(dressing_2h2p)then ! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct) ! endif @@ -193,6 +195,8 @@ subroutine FOBOCI_lmct_mlct_old_thr ! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) ! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) call all_single + call make_s2_eigenfunction + call diagonalize_ci ! if(dressing_2h2p)then ! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct) ! endif diff --git a/plugins/Properties/delta_rho.irp.f b/plugins/Properties/delta_rho.irp.f index 69894c38..7803ba3d 100644 --- a/plugins/Properties/delta_rho.irp.f +++ b/plugins/Properties/delta_rho.irp.f @@ -3,9 +3,9 @@ &BEGIN_PROVIDER [double precision, z_max] &BEGIN_PROVIDER [double precision, delta_z] implicit none - z_min = -20.d0 - z_max = 20.d0 - delta_z = 0.1d0 + z_min = 0.d0 + z_max = 10.d0 + delta_z = 0.005d0 N_z_pts = (z_max - z_min)/delta_z print*,'N_z_pts = ',N_z_pts diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f index cc0a2f8e..deeb90bf 100644 --- a/plugins/Properties/mulliken.irp.f +++ b/plugins/Properties/mulliken.irp.f @@ -14,13 +14,16 @@ BEGIN_PROVIDER [double precision, spin_population, (ao_num_align,ao_num)] enddo END_PROVIDER -BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)] + BEGIN_PROVIDER [double precision, spin_population_angular_momentum, (0:ao_l_max)] +&BEGIN_PROVIDER [double precision, spin_population_angular_momentum_per_atom, (0:ao_l_max,nucl_num)] implicit none integer :: i double precision :: accu spin_population_angular_momentum = 0.d0 + spin_population_angular_momentum_per_atom = 0.d0 do i = 1, ao_num spin_population_angular_momentum(ao_l(i)) += spin_gross_orbital_product(i) + spin_population_angular_momentum_per_atom(ao_l(i),ao_nucl(i)) += spin_gross_orbital_product(i) enddo END_PROVIDER @@ -133,6 +136,16 @@ subroutine print_mulliken_sd print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i) print*,'sum = ',accu enddo + print*,'Angular momentum analysis per atom' + print*,'Angular momentum analysis' + do j = 1,nucl_num + accu = 0.d0 + do i = 0, ao_l_max + accu += spin_population_angular_momentum_per_atom(i,j) + write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) + print*,'sum = ',accu + enddo + enddo end diff --git a/plugins/Properties/print_spin_density.irp.f b/plugins/Properties/print_spin_density.irp.f new file mode 100644 index 00000000..9daa6fb7 --- /dev/null +++ b/plugins/Properties/print_spin_density.irp.f @@ -0,0 +1,36 @@ +program print_sd + implicit none + read_wf = .True. + touch read_wf + call routine + +end + +subroutine routine + implicit none + integer :: i,j,k + double precision :: z + double precision :: r(3),accu,accu_alpha,accu_beta,tmp + double precision, allocatable :: aos_array(:) + allocate(aos_array(ao_num)) + r = 0.d0 + r(3) = z_min + do i = 1, N_z_pts + call give_all_aos_at_r(r,aos_array) + accu = 0.d0 + accu_alpha = 0.d0 + accu_beta = 0.d0 + do j = 1, ao_num + do k = 1, ao_num + tmp = aos_array(k) * aos_array(j) + accu += one_body_spin_density_ao(k,j) * tmp + accu_alpha += one_body_dm_ao_alpha(k,j) * tmp + accu_beta += one_body_dm_ao_beta(k,j) * tmp + enddo + enddo + r(3) += delta_z + write(33,'(100(f16.10,X))')r(3),accu,accu_alpha,accu_beta + enddo + + +end diff --git a/plugins/Properties/provide_deltarho.irp.f b/plugins/Properties/provide_deltarho.irp.f new file mode 100644 index 00000000..d576d622 --- /dev/null +++ b/plugins/Properties/provide_deltarho.irp.f @@ -0,0 +1,11 @@ +program pouet + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + provide integrated_delta_rho_all_points +end diff --git a/plugins/Properties/test_two_body_dm.irp.f b/plugins/Properties/test_two_body_dm.irp.f index 6fc02abf..f79aed86 100644 --- a/plugins/Properties/test_two_body_dm.irp.f +++ b/plugins/Properties/test_two_body_dm.irp.f @@ -7,28 +7,67 @@ end subroutine routine implicit none integer :: i,j,k,l + integer :: h1,p1,h2,p2,s1,s2 double precision :: accu,get_two_body_dm_ab_map_element,get_mo_bielec_integral_schwartz accu = 0.d0 - ! Diag part of the two body dm + ! Diag part of the core two body dm + do i = 1, n_core_orb + h1 = list_core(i) + do j = 1, n_core_orb + h2 = list_core(j) + accu += two_body_dm_ab_diag_core(j,i) * mo_bielec_integral_jj(h1,h2) + enddo + enddo + + ! Diag part of the active two body dm do i = 1, n_act_orb + h1 = list_act(i) do j = 1, n_act_orb - accu += two_body_dm_ab_diag(i,j) * mo_bielec_integral_jj(i,j) + h2 = list_act(j) + accu += two_body_dm_ab_diag_act(j,i) * mo_bielec_integral_jj(h1,h2) + enddo + enddo + + ! Diag part of the active <-> core two body dm + do i = 1, n_act_orb + h1 = list_act(i) + do j = 1, n_core_orb + h2 = list_core(j) + accu += two_body_dm_diag_core_act(j,i) * mo_bielec_integral_jj(h1,h2) enddo enddo print*,'BI ELECTRONIC = ',accu double precision :: accu_extra_diag accu_extra_diag = 0.d0 + ! purely active part of the two body dm do l = 1, n_act_orb ! p2 + p2 = list_act(l) do k = 1, n_act_orb ! h2 + h2 = list_act(k) do j = 1, n_act_orb ! p1 + p1 = list_act(j) do i = 1,n_act_orb ! h1 - accu_extra_diag += two_body_dm_ab_big_array(i,j,k,l) * get_mo_bielec_integral_schwartz(i,k,j,l,mo_integrals_map) + h1 = list_act(i) + accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) enddo enddo enddo enddo + + ! core <-> active part of the two body dm + do l = 1, n_act_orb ! p1 + p1 = list_act(l) + do k = 1, n_act_orb ! h1 + h1 = list_act(k) + do i = 1,n_core_orb ! h2 + h2 = list_core(i) + accu_extra_diag += two_body_dm_ab_big_array_core_act(i,k,l) * get_mo_bielec_integral_schwartz(h1,h2,p1,h2,mo_integrals_map) + enddo + enddo + enddo + print*,'extra_diag = ',accu_extra_diag double precision :: average_mono call get_average(mo_mono_elec_integral,one_body_dm_mo,average_mono) @@ -41,7 +80,6 @@ subroutine routine print*,' = ',e_0 + nuclear_repulsion integer :: degree integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 double precision :: phase integer :: n_elements n_elements = 0 diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index c9036aa1..8a110c05 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -92,7 +92,7 @@ - nrot(1) = 64 ! number of orbitals to be localized + nrot(1) = 6 ! number of orbitals to be localized integer :: index_rot(1000,1) @@ -101,261 +101,72 @@ cmoref = 0.d0 irot = 0 -! H2 molecule for the mixed localization - do i=1,64 - irot(i,1) = i+2 + do i=1,nrot(1) + irot(i,1) = 19+i enddo - do i=1,17 - cmoref(i+1,i,1)=1.d0 - enddo - cmoref(19,19-1,1)=1.d0 - cmoref(20,19-1,1)=-1.d0 - cmoref(19,20-1,1)=-1.d0 - cmoref(20,20-1,1)=-1.d0 - cmoref(21,20-1,1)=2.d0 - cmoref(22,21-1,1)=1.d0 - cmoref(23,22-1,1)=1.d0 - cmoref(24,23-1,1)=1.d0 +! ESATRIENE with 3 bonding and anti bonding orbitals +! First bonding orbital for esa +! cmoref(7,1,1) = 1.d0 ! +! cmoref(26,1,1) = 1.d0 ! +! Second bonding orbital for esa +! cmoref(45,2,1) = 1.d0 ! +! cmoref(64,2,1) = 1.d0 ! +! Third bonding orbital for esa +! cmoref(83,3,1) = 1.d0 ! +! cmoref(102,3,1) = 1.d0 ! + +! First anti bonding orbital for esa +! cmoref(7,4,1) = 1.d0 ! +! cmoref(26,4,1) = -1.d0 ! +! Second anti bonding orbital for esa +! cmoref(45,5,1) = 1.d0 ! +! cmoref(64,5,1) = -1.d0 ! +! Third anti bonding orbital for esa +! cmoref(83,6,1) = 1.d0 ! +! cmoref(102,6,1) = -1.d0 ! + +! ESATRIENE with 2 bonding and anti bonding orbitals +! AND 2 radical orbitals +! First radical orbital +! cmoref(7,1,1) = 1.d0 ! +! First bonding orbital +! cmoref(26,2,1) = 1.d0 ! +! cmoref(45,2,1) = 1.d0 ! +! Second bonding orbital +! cmoref(64,3,1) = 1.d0 ! +! cmoref(83,3,1) = 1.d0 ! +! Second radical orbital for esa +! cmoref(102,4,1) = 1.d0 ! + +! First anti bonding orbital for esa +! cmoref(26,5,1) = 1.d0 ! +! cmoref(45,5,1) =-1.d0 ! +! Second anti bonding orbital for esa +! cmoref(64,6,1) = 1.d0 ! +! cmoref(83,6,1) =-1.d0 ! + +! ESATRIENE with 1 central bonding and anti bonding orbitals +! AND 4 radical orbitals +! First radical orbital + cmoref(7,1,1) = 1.d0 ! +! Second radical orbital + cmoref(26,2,1) = 1.d0 ! +! First bonding orbital + cmoref(45,3,1) = 1.d0 ! + cmoref(64,3,1) = 1.d0 ! +! Third radical orbital for esa + cmoref(83,4,1) = 1.d0 ! +! Fourth radical orbital for esa + cmoref(102,5,1) = 1.d0 ! +! First anti bonding orbital + cmoref(45,6,1) = 1.d0 ! + cmoref(64,6,1) =-1.d0 ! - cmoref(25,24-1,1)=1.d0 - cmoref(26,24-1,1)=-1.d0 - cmoref(25,25-1,1)=-1.d0 - cmoref(26,25-1,1)=-1.d0 - cmoref(27,25-1,1)=2.d0 - cmoref(28,26-1,1)=1.d0 - cmoref(29,27-1,1)=1.d0 - cmoref(30,28-1,1)=1.d0 - - cmoref(31,29-1,1)=1.d0 - cmoref(32,29-1,1)=-1.d0 - cmoref(31,30-1,1)=-1.d0 - cmoref(32,30-1,1)=-1.d0 - cmoref(33,30-1,1)=2.d0 - cmoref(34,31-1,1)=1.d0 - cmoref(35,32-1,1)=1.d0 - cmoref(36,33-1,1)=1.d0 - - do i=33,49 - cmoref(i+5,i,1)= 1.d0 - enddo - - cmoref(55,52-2,1)=1.d0 - cmoref(56,52-2,1)=-1.d0 - cmoref(55,53-2,1)=-1.d0 - cmoref(56,53-2,1)=-1.d0 - cmoref(57,53-2,1)=2.d0 - cmoref(58,54-2,1)=1.d0 - cmoref(59,55-2,1)=1.d0 - cmoref(60,56-2,1)=1.d0 - - cmoref(61,57-2,1)=1.d0 - cmoref(62,57-2,1)=-1.d0 - cmoref(61,58-2,1)=-1.d0 - cmoref(62,58-2,1)=-1.d0 - cmoref(63,58-2,1)=2.d0 - cmoref(64,59-2,1)=1.d0 - cmoref(65,60-2,1)=1.d0 - cmoref(66,61-2,1)=1.d0 - - cmoref(67,62-2,1)=1.d0 - cmoref(68,62-2,1)=-1.d0 - cmoref(67,63-2,1)=-1.d0 - cmoref(68,63-2,1)=-1.d0 - cmoref(69,63-2,1)=2.d0 - cmoref(70,64-2,1)=1.d0 - cmoref(71,65-2,1)=1.d0 - cmoref(72,66-2,1)=1.d0 -! H2 molecule -! do i=1,66 -! irot(i,1) = i -! enddo -! -! do i=1,18 -! cmoref(i,i,1)=1.d0 -! enddo -! cmoref(19,19,1)=1.d0 -! cmoref(20,19,1)=-1.d0 -! cmoref(19,20,1)=-1.d0 -! cmoref(20,20,1)=-1.d0 -! cmoref(21,20,1)=2.d0 -! cmoref(22,21,1)=1.d0 -! cmoref(23,22,1)=1.d0 -! cmoref(24,23,1)=1.d0 -! -! -! cmoref(25,24,1)=1.d0 -! cmoref(26,24,1)=-1.d0 -! cmoref(25,25,1)=-1.d0 -! cmoref(26,25,1)=-1.d0 -! cmoref(27,25,1)=2.d0 -! cmoref(28,26,1)=1.d0 -! cmoref(29,27,1)=1.d0 -! cmoref(30,28,1)=1.d0 -! -! cmoref(31,29,1)=1.d0 -! cmoref(32,29,1)=-1.d0 -! cmoref(31,30,1)=-1.d0 -! cmoref(32,30,1)=-1.d0 -! cmoref(33,30,1)=2.d0 -! cmoref(34,31,1)=1.d0 -! cmoref(35,32,1)=1.d0 -! cmoref(36,33,1)=1.d0 -! -! do i=34,51 -! cmoref(i+3,i,1)= 1.d0 -! enddo -! -! cmoref(55,52,1)=1.d0 -! cmoref(56,52,1)=-1.d0 -! cmoref(55,53,1)=-1.d0 -! cmoref(56,53,1)=-1.d0 -! cmoref(57,53,1)=2.d0 -! cmoref(58,54,1)=1.d0 -! cmoref(59,55,1)=1.d0 -! cmoref(60,56,1)=1.d0 -! -! cmoref(61,57,1)=1.d0 -! cmoref(62,57,1)=-1.d0 -! cmoref(61,58,1)=-1.d0 -! cmoref(62,58,1)=-1.d0 -! cmoref(63,58,1)=2.d0 -! cmoref(64,59,1)=1.d0 -! cmoref(65,60,1)=1.d0 -! cmoref(66,61,1)=1.d0 -! -! cmoref(67,62,1)=1.d0 -! cmoref(68,62,1)=-1.d0 -! cmoref(67,63,1)=-1.d0 -! cmoref(68,63,1)=-1.d0 -! cmoref(69,63,1)=2.d0 -! cmoref(70,64,1)=1.d0 -! cmoref(71,65,1)=1.d0 -! cmoref(72,66,1)=1.d0 -! H atom -! do i=1,33 -! irot(i,1) = i -! enddo -! -! do i=1,18 -! cmoref(i,i,1)=1.d0 -! enddo -! cmoref(19,19,1)=1.d0 -! cmoref(20,19,1)=-1.d0 -! cmoref(19,20,1)=-1.d0 -! cmoref(20,20,1)=-1.d0 -! cmoref(21,20,1)=2.d0 -! cmoref(22,21,1)=1.d0 -! cmoref(23,22,1)=1.d0 -! cmoref(24,23,1)=1.d0 - - -! cmoref(25,24,1)=1.d0 -! cmoref(26,24,1)=-1.d0 -! cmoref(25,25,1)=-1.d0 -! cmoref(26,25,1)=-1.d0 -! cmoref(27,25,1)=2.d0 -! cmoref(28,26,1)=1.d0 -! cmoref(29,27,1)=1.d0 -! cmoref(30,28,1)=1.d0 -! -! cmoref(31,29,1)=1.d0 -! cmoref(32,29,1)=-1.d0 -! cmoref(31,30,1)=-1.d0 -! cmoref(32,30,1)=-1.d0 -! cmoref(33,30,1)=2.d0 -! cmoref(34,31,1)=1.d0 -! cmoref(35,32,1)=1.d0 -! cmoref(36,33,1)=1.d0 - - ! Definition of the index of the MO to be rotated -! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO -! irot(3,1) = 22 ! etc.... -! irot(4,1) = 23 ! -! irot(5,1) = 24 ! -! irot(6,1) = 25 ! - -!N2 -! irot(1,1) = 5 -! irot(2,1) = 6 -! irot(3,1) = 7 -! irot(4,1) = 8 -! irot(5,1) = 9 -! irot(6,1) = 10 -! -! cmoref(5,1,1) = 1.d0 ! -! cmoref(6,2,1) = 1.d0 ! -! cmoref(7,3,1) = 1.d0 ! -! cmoref(40,4,1) = 1.d0 ! -! cmoref(41,5,1) = 1.d0 ! -! cmoref(42,6,1) = 1.d0 ! -!END N2 - -!HEXATRIENE -! irot(1,1) = 20 -! irot(2,1) = 21 -! irot(3,1) = 22 -! irot(4,1) = 23 -! irot(5,1) = 24 -! irot(6,1) = 25 -! -! cmoref(7,1,1) = 1.d0 ! -! cmoref(26,1,1) = 1.d0 ! -! cmoref(45,2,1) = 1.d0 ! -! cmoref(64,2,1) = 1.d0 ! -! cmoref(83,3,1) = 1.d0 ! -! cmoref(102,3,1) = 1.d0 ! -! cmoref(7,4,1) = 1.d0 ! -! cmoref(26,4,1) = -1.d0 ! -! cmoref(45,5,1) = 1.d0 ! -! cmoref(64,5,1) = -1.d0 ! -! cmoref(83,6,1) = 1.d0 ! -! cmoref(102,6,1) = -1.d0 ! -!END HEXATRIENE - -!!!!H2 H2 CAS -! irot(1,1) = 1 -! irot(2,1) = 2 -! -! cmoref(1,1,1) = 1.d0 -! cmoref(37,2,1) = 1.d0 -!END H2 -!!!! LOCALIZATION ON THE BASIS FUNCTIONS -! do i = 1, nrot(1) -! irot(i,1) = i -! cmoref(i,i,1) = 1.d0 -! enddo - -!END BASISLOC - -! do i = 1, nrot(1) -! irot(i,1) = 4+i -! enddo do i = 1, nrot(1) print*,'irot(i,1) = ',irot(i,1) enddo -! pause - - ! you define the guess vectors that you want - ! the new MO to be close to - ! cmore(i,j,1) = < AO_i | guess_vector_MO(j) > - ! i goes from 1 to ao_num - ! j goes from 1 to nrot(1) - - ! Here you must go to the GAMESS output file - ! where the AOs are listed and explicited - ! From the basis of this knowledge you can build your - ! own guess vectors for the MOs - ! The new MOs are provided in output - ! in the same order than the guess MOs -! do i = 1, nrot(1) -! j = 5+(i-1)*15 -! cmoref(j,i,1) = 0.2d0 -! cmoref(j+3,i,1) = 0.12d0 -! print*,'j = ',j -! enddo -! pause diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 7bb6e16e..f23d51e9 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -37,6 +37,30 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] enddo END_PROVIDER +BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] + implicit none + integer :: i + do i=1,N_int + core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ] + implicit none + integer :: i + do i=1,N_int + virt_bitmask_4(i,1) = virt_bitmask(i,1) + virt_bitmask_4(i,2) = virt_bitmask(i,1) + virt_bitmask_4(i,3) = virt_bitmask(i,1) + virt_bitmask_4(i,4) = virt_bitmask(i,1) + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)] implicit none @@ -369,11 +393,19 @@ END_PROVIDER BEGIN_PROVIDER [ integer, list_inact, (n_inact_orb)] &BEGIN_PROVIDER [ integer, list_virt, (n_virt_orb)] + &BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_tot_num)] + &BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_tot_num)] BEGIN_DOC ! list_inact : List of the inactive orbitals which are supposed to be doubly excited ! in post CAS methods ! list_virt : List of vritual orbitals which are supposed to be recieve electrons ! in post CAS methods + ! list_inact_reverse : reverse list of inactive orbitals + ! list_inact_reverse(i) = 0 ::> not an inactive + ! list_inact_reverse(i) = k ::> IS the kth inactive + ! list_virt_reverse : reverse list of virtual orbitals + ! list_virt_reverse(i) = 0 ::> not an virtual + ! list_virt_reverse(i) = k ::> IS the kth virtual END_DOC implicit none integer :: occ_inact(N_int*bit_kind_size) @@ -381,15 +413,20 @@ END_PROVIDER occ_inact = 0 call bitstring_to_list(inact_bitmask(1,1), occ_inact(1), itest, N_int) ASSERT(itest==n_inact_orb) + list_inact_reverse = 0 do i = 1, n_inact_orb list_inact(i) = occ_inact(i) + list_inact_reverse(occ_inact(i)) = i enddo + occ_inact = 0 call bitstring_to_list(virt_bitmask(1,1), occ_inact(1), itest, N_int) ASSERT(itest==n_virt_orb) + list_virt_reverse = 0 do i = 1, n_virt_orb list_virt(i) = occ_inact(i) + list_virt_reverse(occ_inact(i)) = i enddo END_PROVIDER @@ -397,7 +434,7 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] implicit none BEGIN_DOC - ! Reunion of the inactive, active and virtual bitmasks + ! Reunion of the core and inactive and virtual bitmasks END_DOC integer :: i,j do i = 1, N_int @@ -407,6 +444,20 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the core, inactive and active bitmasks + END_DOC + integer :: i,j + + do i = 1, N_int + reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),cas_bitmask(i,1,1)) + reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),cas_bitmask(i,1,1)) + enddo + END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] @@ -435,6 +486,7 @@ END_PROVIDER END_PROVIDER BEGIN_PROVIDER [integer, list_core, (n_core_orb)] +&BEGIN_PROVIDER [integer, list_core_reverse, (mo_tot_num)] BEGIN_DOC ! List of the core orbitals that are never excited in post CAS method END_DOC @@ -444,8 +496,10 @@ END_PROVIDER occ_core = 0 call bitstring_to_list(core_bitmask(1,1), occ_core(1), itest, N_int) ASSERT(itest==n_core_orb) + list_core_reverse = 0 do i = 1, n_core_orb list_core(i) = occ_core(i) + list_core_reverse(occ_core(i)) = i enddo END_PROVIDER @@ -497,11 +551,17 @@ BEGIN_PROVIDER [ integer, n_act_orb] do i = 1, N_int n_act_orb += popcnt(cas_bitmask(i,1,1)) enddo + print*,'n_act_orb = ',n_act_orb END_PROVIDER -BEGIN_PROVIDER [integer, list_act, (n_act_orb)] + BEGIN_PROVIDER [integer, list_act, (n_act_orb)] +&BEGIN_PROVIDER [integer, list_act_reverse, (mo_tot_num)] BEGIN_DOC - ! list of active orbitals + ! list_act(i) = index of the ith active orbital + ! + ! list_act_reverse : reverse list of active orbitals + ! list_act_reverse(i) = 0 ::> not an active + ! list_act_reverse(i) = k ::> IS the kth active orbital END_DOC implicit none integer :: occ_act(N_int*bit_kind_size) @@ -509,10 +569,11 @@ BEGIN_PROVIDER [integer, list_act, (n_act_orb)] occ_act = 0 call bitstring_to_list(cas_bitmask(1,1,1), occ_act(1), itest, N_int) ASSERT(itest==n_act_orb) + list_act_reverse = 0 do i = 1, n_act_orb list_act(i) = occ_act(i) + list_act_reverse(occ_act(i)) = i enddo - END_PROVIDER BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] @@ -537,4 +598,19 @@ END_PROVIDER enddo END_PROVIDER + + BEGIN_PROVIDER [integer, n_core_orb_allocate] + implicit none + n_core_orb_allocate = max(n_core_orb,1) + END_PROVIDER + + BEGIN_PROVIDER [integer, n_inact_orb_allocate] + implicit none + n_inact_orb_allocate = max(n_inact_orb,1) + END_PROVIDER + + BEGIN_PROVIDER [integer, n_virt_orb_allocate] + implicit none + n_virt_orb_allocate = max(n_virt_orb,1) + END_PROVIDER diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 62d09381..2253c33c 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -238,17 +238,19 @@ END_PROVIDER END_DOC implicit none integer :: i,j,k,l - double precision :: dm_mo + double precision :: mo_alpha,mo_beta - one_body_spin_density_ao = 0.d0 + one_body_dm_ao_alpha = 0.d0 + one_body_dm_ao_beta = 0.d0 do k = 1, ao_num do l = 1, ao_num do i = 1, mo_tot_num do j = 1, mo_tot_num - dm_mo = one_body_dm_mo_alpha(j,i) + mo_alpha = one_body_dm_mo_alpha(j,i) + mo_beta = one_body_dm_mo_beta(j,i) ! if(dabs(dm_mo).le.1.d-10)cycle - one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo - one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * dm_mo + one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha + one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta enddo enddo diff --git a/src/Determinants/diagonalize_restart_and_save_all_states.irp.f b/src/Determinants/diagonalize_restart_and_save_all_states.irp.f new file mode 100644 index 00000000..3bdc37c5 --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_all_states.irp.f @@ -0,0 +1,16 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + call diagonalize_CI + print*,'N_det = ',N_det + call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + + + +end diff --git a/src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f b/src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f new file mode 100644 index 00000000..11c98034 --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_lowest_state.irp.f @@ -0,0 +1,25 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + print*,'N_det = ',N_det + call diagonalize_CI + integer :: igood_state + igood_state=1 + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(n_det)) + integer :: i + do i = 1, N_det + psi_coef_tmp(i) = psi_coef(i,igood_state) + enddo + call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp) + deallocate(psi_coef_tmp) + + + +end diff --git a/src/Determinants/diagonalize_restart_and_save_one_states.irp.f b/src/Determinants/diagonalize_restart_and_save_one_states.irp.f new file mode 100644 index 00000000..c5f4e59d --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_one_states.irp.f @@ -0,0 +1,26 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + print*,'N_det = ',N_det + call diagonalize_CI + write(*,*)'Which state would you like to save ?' + integer :: igood_state + read(5,*)igood_state + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(n_det)) + integer :: i + do i = 1, N_det + psi_coef_tmp(i) = psi_coef(i,igood_state) + enddo + call save_wavefunction_general(N_det,1,psi_det,n_det,psi_coef_tmp) + deallocate(psi_coef_tmp) + + + +end diff --git a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f new file mode 100644 index 00000000..97fed531 --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f @@ -0,0 +1,27 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: igood_state_1,igood_state_2 + double precision, allocatable :: psi_coef_tmp(:,:) + integer :: i + print*,'N_det = ',N_det +!call diagonalize_CI + write(*,*)'Which couple of states would you like to save ?' + read(5,*)igood_state_1,igood_state_2 + allocate(psi_coef_tmp(n_det,2)) + do i = 1, N_det + psi_coef_tmp(i,1) = psi_coef(i,igood_state_1) + psi_coef_tmp(i,2) = psi_coef(i,igood_state_2) + enddo + call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp) + deallocate(psi_coef_tmp) + + + +end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index aa059870..e2e12974 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -256,7 +256,7 @@ subroutine make_s2_eigenfunction integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction - return +! return ! !TODO DEBUG ! do i=1,N_det diff --git a/src/Determinants/print_H_matrix_restart.irp.f b/src/Determinants/print_H_matrix_restart.irp.f new file mode 100644 index 00000000..813f14d0 --- /dev/null +++ b/src/Determinants/print_H_matrix_restart.irp.f @@ -0,0 +1,179 @@ +program print_H_matrix_restart + implicit none + read_wf = .True. + touch read_wf + call routine + +end + +subroutine routine + use bitmasks + implicit none + integer :: i,j + integer, allocatable :: H_matrix_degree(:,:) + double precision, allocatable :: H_matrix_phase(:,:) + integer :: degree + integer(bit_kind), allocatable :: keys_tmp(:,:,:) + allocate(keys_tmp(N_int,2,N_det)) + do i = 1, N_det + print*,'' + call debug_det(psi_det(1,1,i),N_int) + do j = 1, N_int + keys_tmp(j,1,i) = psi_det(j,1,i) + keys_tmp(j,2,i) = psi_det(j,2,i) + enddo + enddo + if(N_det.ge.10000)then + print*,'Warning !!!' + print*,'Number of determinants is ',N_det + print*,'It means that the H matrix will be enormous !' + print*,'stoppping ..' + stop + endif + print*,'' + print*,'Determinants ' + do i = 1, N_det + enddo + allocate(H_matrix_degree(N_det,N_det),H_matrix_phase(N_det,N_det)) + integer :: exc(0:2,2,2) + double precision :: phase + do i = 1, N_det + do j = i, N_det + call get_excitation_degree(psi_det(1,1,i),psi_det(1,1,j),degree,N_int) + H_matrix_degree(i,j) = degree + H_matrix_degree(j,i) = degree + phase = 0.d0 + if(degree==1.or.degree==2)then + call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) + endif + H_matrix_phase(i,j) = phase + H_matrix_phase(j,i) = phase + enddo + enddo + print*,'H matrix ' + double precision :: ref_h_matrix,s2 + ref_h_matrix = H_matrix_all_dets(1,1) + print*,'HF like determinant energy = ',ref_bitmask_energy+nuclear_repulsion + print*,'Ref element of H_matrix = ',ref_h_matrix+nuclear_repulsion + print*,'Printing the H matrix ...' + print*,'' + print*,'' +!do i = 1, N_det +! H_matrix_all_dets(i,i) -= ref_h_matrix +!enddo + + do i = 1, N_det + H_matrix_all_dets(i,i) += nuclear_repulsion + enddo + +!do i = 5,N_det +! H_matrix_all_dets(i,3) = 0.d0 +! H_matrix_all_dets(3,i) = 0.d0 +! H_matrix_all_dets(i,4) = 0.d0 +! H_matrix_all_dets(4,i) = 0.d0 +!enddo + + + + + + do i = 1, N_det + write(*,'(I3,X,A3,1000(F16.7))')i,' | ',H_matrix_all_dets(i,:) + enddo + + print*,'' + print*,'' + print*,'' + print*,'Printing the degree of excitations within the H matrix' + print*,'' + print*,'' + do i = 1, N_det + write(*,'(I3,X,A3,X,1000(I1,X))')i,' | ',H_matrix_degree(i,:) + enddo + + + print*,'' + print*,'' + print*,'Printing the phase of the Hamiltonian matrix elements ' + print*,'' + print*,'' + do i = 1, N_det + write(*,'(I3,X,A3,X,1000(F3.0,X))')i,' | ',H_matrix_phase(i,:) + enddo + print*,'' + + + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + double precision, allocatable :: s2_eigvalues(:) + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + print*,'Two first eigenvectors ' + do j = 1, n_states +!do j = 1, 1 + print*,'State ',j + call get_s2_u0(keys_tmp,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) + print*,'s2 = ',s2 + print*,'e = ',eigenvalues(j) + print*,'coefs : ' + do i = 1, N_det + print*,'i = ',i,eigenvectors(i,j) + enddo + + if(j>1)then + print*,'Delta E(H) = ',eigenvalues(1) - eigenvalues(j) + print*,'Delta E(eV) = ',(eigenvalues(1) - eigenvalues(j))*27.2114d0 + endif + enddo + double precision :: get_mo_bielec_integral_schwartz,k_a_iv,k_b_iv + integer :: h1,p1,h2,p2 + h1 = 10 + p1 = 16 + h2 = 14 + p2 = 14 +!h1 = 1 +!p1 = 4 +!h2 = 2 +!p2 = 2 + k_a_iv = get_mo_bielec_integral_schwartz(h1,h2,p2,p1,mo_integrals_map) + h2 = 15 + p2 = 15 + k_b_iv = get_mo_bielec_integral_schwartz(h1,h2,p2,p1,mo_integrals_map) + print*,'k_a_iv = ',k_a_iv + print*,'k_b_iv = ',k_b_iv + double precision :: k_av,k_bv,k_ai,k_bi + h1 = 16 + p1 = 14 + h2 = 14 + p2 = 16 + k_av = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + h1 = 16 + p1 = 15 + h2 = 15 + p2 = 16 + k_bv = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + + h1 = 10 + p1 = 14 + h2 = 14 + p2 = 10 + k_ai = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + + h1 = 10 + p1 = 15 + h2 = 15 + p2 = 10 + k_bi = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + + print*,'k_av, k_bv = ',k_av,k_bv + print*,'k_ai, k_bi = ',k_ai,k_bi + double precision :: k_iv + + h1 = 10 + p1 = 16 + h2 = 16 + p2 = 10 + k_iv = get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + print*,'k_iv = ',k_iv +end diff --git a/src/Determinants/print_bitmask.irp.f b/src/Determinants/print_bitmask.irp.f new file mode 100644 index 00000000..2f1c8f73 --- /dev/null +++ b/src/Determinants/print_bitmask.irp.f @@ -0,0 +1,11 @@ +program print_bitmask + implicit none + print*,'core' + call debug_det(core_bitmask,N_int) + print*,'inact' + call debug_det(inact_bitmask,N_int) + print*,'virt' + call debug_det(virt_bitmask,N_int) + + +end diff --git a/src/Determinants/print_holes_particles.irp.f b/src/Determinants/print_holes_particles.irp.f new file mode 100644 index 00000000..601015f7 --- /dev/null +++ b/src/Determinants/print_holes_particles.irp.f @@ -0,0 +1,36 @@ +program pouet + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: i,j,number_of_holes,number_of_particles + integer :: n_h,n_p + do i = 1, N_det + n_h = number_of_holes(psi_det(1,1,i)) + n_p = number_of_particles(psi_det(1,1,i)) + if(n_h == 0 .and. n_p == 0)then + print*,'CAS' + else if(n_h == 1 .and. n_p ==0)then + print*,'1h' + else if(n_h == 0 .and. n_p ==1)then + print*,'1p' + else if(n_h == 1 .and. n_p ==1)then + print*,'1h1p' + else if(n_h == 2 .and. n_p ==1)then + print*,'2h1p' + else if(n_h == 1 .and. n_p ==2)then + print*,'1h2p' + else + print*,'PB !! ' + call debug_det(psi_det(1,1,i), N_int) + stop + endif + enddo + + + +end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f new file mode 100644 index 00000000..e7ca5dc6 --- /dev/null +++ b/src/Determinants/print_wf.irp.f @@ -0,0 +1,71 @@ +program printwf + implicit none + read_wf = .True. + touch read_wf + print*,'ref_bitmask_energy = ',ref_bitmask_energy + call routine + +end + +subroutine routine + implicit none + integer :: i + integer :: degree + double precision :: hij + integer :: exc(0:2,2,2) + double precision :: phase + integer :: h1,p1,h2,p2,s1,s2 + double precision :: get_mo_bielec_integral_schwartz + double precision :: norm_mono_a,norm_mono_b + norm_mono_a = 0.d0 + norm_mono_b = 0.d0 + do i = 1, min(500,N_det) + print*,'' + print*,'i = ',i + 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) + print*,'degree = ',degree + if(degree == 0)then + print*,'Reference determinant ' + else + call i_H_j(psi_det(1,1,i),psi_det(1,1,1),N_int,hij) + 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) + print*,'phase = ',phase + if(degree == 1)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + if(s1 == 1)then + norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) + else + norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) + endif + print*,'< h | Ka| p > = ',get_mo_bielec_integral_schwartz(h1,list_act(1),list_act(1),p1,mo_integrals_map) + double precision :: hmono,hdouble + call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) + print*,'hmono = ',hmono + print*,'hdouble = ',hdouble + print*,'hmono+hdouble = ',hmono+hdouble + print*,'hij = ',hij + else + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + print*,'s2',s2 + print*,'h2,p2 = ',h2,p2 + print*,'< h | Ka| p > = ',get_mo_bielec_integral_schwartz(h1,h2,p1,p2,mo_integrals_map) + endif + + print*,' = ',hij + endif + print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1) + + enddo + + + print*,'' + print*,'' + print*,'' + print*,'mono alpha = ',norm_mono_a + print*,'mono beta = ',norm_mono_b + +end diff --git a/src/Determinants/save_only_singles.irp.f b/src/Determinants/save_only_singles.irp.f new file mode 100644 index 00000000..ae68a52c --- /dev/null +++ b/src/Determinants/save_only_singles.irp.f @@ -0,0 +1,50 @@ +program save_only_singles + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: i,j,k,l + use bitmasks + integer :: n_det_restart,degree + integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) + double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) + integer, allocatable :: index_restart(:) + allocate(index_restart(N_det)) + N_det_restart = 0 + do i = 1, N_det + call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,i),degree,N_int) + if(degree == 0 .or. degree==1)then + N_det_restart +=1 + index_restart(N_det_restart) = i + cycle + endif + enddo + allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) + accu = 0.d0 + do i = 1, N_det_restart + do j = 1, N_int + psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) + psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) + enddo + do j = 1,N_states + psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) + accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) + enddo + enddo + do j = 1, N_states + accu(j) = 1.d0/dsqrt(accu(j)) + enddo + do j = 1,N_states + do i = 1, N_det_restart + psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) + enddo + enddo + call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) + + deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) + +end diff --git a/src/Determinants/test_3d.irp.f b/src/Determinants/test_3d.irp.f new file mode 100644 index 00000000..748890da --- /dev/null +++ b/src/Determinants/test_3d.irp.f @@ -0,0 +1,15 @@ +program test_3d + implicit none + integer :: i,npt + double precision :: dx,domain,x_min,x,step_function_becke + domain = 5.d0 + npt = 100 + dx = domain/dble(npt) + x_min = -0.5d0 * domain + x = x_min + do i = 1, npt + write(33,*)x,step_function_becke(x) + x += dx + enddo + +end diff --git a/src/Determinants/test_two_body.irp.f b/src/Determinants/test_two_body.irp.f new file mode 100644 index 00000000..54c43c09 --- /dev/null +++ b/src/Determinants/test_two_body.irp.f @@ -0,0 +1,18 @@ +program test + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: i,j,k,l + do i = 1, n_act_orb + do j = 1, n_act_orb + do k = 1, n_act_orb + + enddo + enddo + enddo +end diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index 42340c71..aba16fa7 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,18 +1,11 @@ -program cisd - implicit none - integer :: i,k - - - double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) - integer :: N_st, degree - N_det=10000 - do i=1,N_det - do k=1,N_int - psi_det(k,1,i) = psi_det_sorted(k,1,i) - psi_det(k,2,i) = psi_det_sorted(k,2,i) - enddo - psi_coef(i,:) = psi_coef_sorted(i,:) - enddo +program s2_eig_restart + implicit none + read_wf = .True. + call routine +end +subroutine routine + implicit none + call make_s2_eigenfunction TOUCH psi_det psi_coef psi_det_sorted psi_coef_sorted psi_average_norm_contrib_sorted N_det call save_wavefunction end diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index f88d6ea3..aa8f630b 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -193,33 +193,141 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) end -BEGIN_PROVIDER [double precision, two_body_dm_ab_diag, (mo_tot_num, mo_tot_num)] + BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] +&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] +&BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] +&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_a_act_b, (n_core_orb_allocate,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_b_act_a, (n_core_orb_allocate,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_diag_core_act, (n_core_orb_allocate,n_act_orb)] implicit none + use bitmasks integer :: i,j,k,l,m integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) + integer :: occ_act(N_int*bit_kind_size,2) + integer :: n_occ_ab_act(2) + integer :: occ_core(N_int*bit_kind_size,2) + integer :: n_occ_ab_core(2) double precision :: contrib BEGIN_DOC - ! two_body_dm_ab_diag(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi> + ! two_body_dm_ab_diag_all(k,m) = <\Psi | n_(k\alpha) n_(m\beta) | \Psi> + ! two_body_dm_ab_diag_act(k,m) is restricted to the active orbitals : + ! orbital k = list_act(k) + ! two_body_dm_ab_diag_inact(k,m) is restricted to the inactive orbitals : + ! orbital k = list_inact(k) + ! two_body_dm_ab_diag_core(k,m) is restricted to the core orbitals : + ! orbital k = list_core(k) + ! two_body_dm_ab_diag_core_b_act_a(k,m) represents the core beta <-> active alpha part of the two body dm + ! orbital k = list_core(k) + ! orbital m = list_act(m) + ! two_body_dm_ab_diag_core_a_act_b(k,m) represents the core alpha <-> active beta part of the two body dm + ! orbital k = list_core(k) + ! orbital m = list_act(m) + ! two_body_dm_ab_diag_core_act(k,m) represents the core<->active part of the diagonal two body dm + ! when we traced on the spin + ! orbital k = list_core(k) + ! orbital m = list_act(m) END_DOC + integer(bit_kind) :: key_tmp_core(N_int,2) + integer(bit_kind) :: key_tmp_act(N_int,2) - two_body_dm_ab_diag = 0.d0 + two_body_dm_ab_diag_all = 0.d0 + two_body_dm_ab_diag_act = 0.d0 + two_body_dm_ab_diag_core = 0.d0 + two_body_dm_ab_diag_inact = 0.d0 + two_body_dm_diag_core_a_act_b = 0.d0 + two_body_dm_diag_core_b_act_a = 0.d0 + two_body_dm_diag_core_act = 0.d0 do i = 1, N_det ! i == |I> - call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + ! Full diagonal part of the two body dm contrib = psi_coef(i,1)**2 + call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) do j = 1, elec_beta_num k = occ(j,2) do l = 1, elec_alpha_num m = occ(l,1) - two_body_dm_ab_diag(k,m) += 0.5d0 * contrib - two_body_dm_ab_diag(m,k) += 0.5d0 * contrib + two_body_dm_ab_diag_all(k,m) += 0.5d0 * contrib + two_body_dm_ab_diag_all(m,k) += 0.5d0 * contrib enddo enddo + + ! ACTIVE PART of the diagonal part of the two body dm + do j = 1, N_int + key_tmp_act(j,1) = psi_det(j,1,i) + key_tmp_act(j,2) = psi_det(j,2,i) + enddo + do j = 1, N_int + key_tmp_act(j,1) = iand(key_tmp_act(j,1),cas_bitmask(j,1,1)) + key_tmp_act(j,2) = iand(key_tmp_act(j,2),cas_bitmask(j,1,1)) + enddo + call bitstring_to_list_ab(key_tmp_act, occ_act, n_occ_ab_act, N_int) + do j = 1,n_occ_ab_act(2) + k = list_act_reverse(occ_act(j,2)) + do l = 1, n_occ_ab_act(1) + m = list_act_reverse(occ_act(l,1)) + two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib + two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib + enddo + enddo + + ! CORE PART of the diagonal part of the two body dm + do j = 1, N_int + key_tmp_core(j,1) = psi_det(j,1,i) + key_tmp_core(j,2) = psi_det(j,2,i) + enddo + do j = 1, N_int + key_tmp_core(j,1) = iand(key_tmp_core(j,1),core_bitmask(j,1)) + key_tmp_core(j,2) = iand(key_tmp_core(j,2),core_bitmask(j,1)) + enddo + call bitstring_to_list_ab(key_tmp_core, occ_core, n_occ_ab_core, N_int) + do j = 1,n_occ_ab_core(2) + k = list_core_reverse(occ_core(j,2)) + do l = 1, n_occ_ab_core(1) + m = list_core_reverse(occ_core(l,1)) + two_body_dm_ab_diag_core(k,m) += 0.5d0 * contrib + two_body_dm_ab_diag_core(m,k) += 0.5d0 * contrib + enddo + enddo + + ! ACT<->CORE PART + ! alpha electron in active space + do j = 1,n_occ_ab_act(1) + k = list_act_reverse(occ_act(j,1)) + ! beta electron in core space + do l = 1, n_occ_ab_core(2) + m = list_core_reverse(occ_core(l,2)) + ! The fact that you have 1 * contrib and not 0.5 * contrib + ! takes into account the following symmetry : + ! 0.5 * + 0.5 * + two_body_dm_diag_core_b_act_a(m,k) += contrib + enddo + enddo + ! beta electron in active space + do j = 1,n_occ_ab_act(2) + k = list_act_reverse(occ_act(j,2)) + ! alpha electron in core space + do l = 1, n_occ_ab_core(1) + m = list_core_reverse(occ_core(l,1)) + ! The fact that you have 1 * contrib and not 0.5 * contrib + ! takes into account the following symmetry : + ! 0.5 * + 0.5 * + two_body_dm_diag_core_a_act_b(m,k) += contrib + enddo + enddo + enddo + + do j = 1, n_core_orb + do l = 1, n_act_orb + two_body_dm_diag_core_act(j,l) = two_body_dm_diag_core_b_act_a(j,l) + two_body_dm_diag_core_a_act_b(j,l) + enddo enddo END_PROVIDER -BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] implicit none + use bitmasks integer :: i,j,k,l,m integer :: degree PROVIDE mo_coef psi_coef psi_det @@ -229,54 +337,108 @@ BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array, (n_act_orb,n_act_orb double precision :: contrib integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - two_body_dm_ab_big_array = 0.d0 + integer :: occ_core(N_int*bit_kind_size,2) + integer :: n_occ_ab_core(2) + integer(bit_kind) :: key_tmp_i(N_int,2) + integer(bit_kind) :: key_tmp_i_core(N_int,2) + integer(bit_kind) :: key_tmp_j(N_int,2) + two_body_dm_ab_big_array_act = 0.d0 + two_body_dm_ab_big_array_core_act = 0.d0 BEGIN_DOC -! The alpha-beta energy can be computed thanks to -! sum_{h1,p1,h2,p2} two_body_dm_ab_big_array(h1,p1,h2,p2) * (h1p1|h2p2) +! two_body_dm_ab_big_array_act = Purely active part of the two body density matrix +! two_body_dm_ab_big_array_act_core takes only into account the single excitation +! within the active space that adds terms in the act <-> core two body dm +! two_body_dm_ab_big_array_act_core(i,j,k) = < a^\dagger_i n_k a_j > +! with i,j in the ACTIVE SPACE +! with k in the CORE SPACE +! +! The alpha-beta extra diagonal energy FOR WF DEFINED AS AN APPROXIMATION OF A CAS can be computed thanks to +! sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_act(h1,p1,h2,p2) * (h1p1|h2p2) +! + sum_{h1,p1,h2,p2} two_body_dm_ab_big_array_core_act(h1,p1,h2,p2) * (h1p1|h2p2) END_DOC do i = 1, N_det ! i == |I> - call bitstring_to_list_ab(psi_det(1,1,i), occ, n_occ_ab, N_int) + ! active part of psi_det(i) + do j = 1, N_int + key_tmp_i(j,1) = psi_det(j,1,i) + key_tmp_i(j,2) = psi_det(j,2,i) + key_tmp_i_core(j,1) = psi_det(j,1,i) + key_tmp_i_core(j,2) = psi_det(j,2,i) + enddo + do j = 1, N_int + key_tmp_i(j,1) = iand(key_tmp_i(j,1),cas_bitmask(j,1,1)) + key_tmp_i(j,2) = iand(key_tmp_i(j,2),cas_bitmask(j,1,1)) + enddo + do j = 1, N_int + key_tmp_i_core(j,1) = iand(key_tmp_i_core(j,1),core_bitmask(j,1)) + key_tmp_i_core(j,2) = iand(key_tmp_i_core(j,2),core_bitmask(j,1)) + enddo + call bitstring_to_list_ab(key_tmp_i_core, occ_core, n_occ_ab_core, N_int) + call bitstring_to_list_ab(key_tmp_i, occ, n_occ_ab, N_int) do j = i+1, N_det ! j == 2)cycle + ! if it is the case, then compute the hamiltonian matrix element with the proper phase call get_excitation(psi_det(1,1,i),psi_det(1,1,j),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! if(i==3.or.j==3)then -! print*,'i,j = ',i,j -! call debug_det(psi_det(1,1,i),N_int) -! call debug_det(psi_det(1,1,j),N_int) -! print*,degree,s1,s2 -! print*,h1,p1,h2,p2 -! print*,phase -! pause -! endif contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase -! print*,'coucou' -! print*,'i,j = ',i,j -! print*,'contrib = ',contrib -! print*,h1,p1,h2,p2 -! print*,'s1,s2',s1,s2 -! call debug_det(psi_det(1,1,i),N_int) -! call debug_det(psi_det(1,1,j),N_int) -! pause if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + h1 = list_act_reverse(h1) + h2 = list_act_reverse(h2) + p1 = list_act_reverse(p1) + p2 = list_act_reverse(p2) + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** + print*,'h1 = ',h1 + h1 = list_act_reverse(h1) + print*,'h1 = ',h1 + print*,'p1 = ',p1 + p1 = list_act_reverse(p1) + print*,'p1 = ',p1 + if(s1==1)then ! Mono alpha : - do k = 1, elec_beta_num - m = occ(k,2) + ! purely active part of the extra diagonal two body dm + do k = 1, n_occ_ab(2) + m = list_act_reverse(occ(k,2)) ! * c_I * c_J - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + enddo + + ! core <-> active part of the extra diagonal two body dm + do k = 1, n_occ_ab_core(2) + m = list_core_reverse(occ_core(k,2)) + ! * c_I * c_J + two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib + two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib enddo else ! Mono Beta : - do k = 1, elec_alpha_num - m = occ(k,1) + ! purely active part of the extra diagonal two body dm + do k = 1, n_occ_ab(1) + m = list_act_reverse(occ(k,1)) ! * c_I * c_J - call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) + enddo + + ! core <-> active part of the extra diagonal two body dm + do k = 1, n_occ_ab_core(1) + m = list_core_reverse(occ_core(k,1)) + ! * c_I * c_J + two_body_dm_ab_big_array_core_act(m,h1,p1) += 2.d0 * contrib + two_body_dm_ab_big_array_core_act(m,p1,h1) += 2.d0 * contrib enddo endif @@ -303,30 +465,39 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr end -double precision function compute_extra_diag_two_body_dm_ab(r1,r2) +double precision function compute_extra_diag_two_body_dm_ab(r1,r2) implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 + END_DOC + double precision :: r1(3), r2(3) + double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act + compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) +end + +double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + PROVIDE n_act_orb double precision, intent(in) :: r1(3),r2(3) integer :: i,j,k,l - double precision :: mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num) + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) double precision :: contrib - compute_extra_diag_two_body_dm_ab = 0.d0 -!call give_all_mos_at_r(r1,mos_array_r1) -!call give_all_mos_at_r(r2,mos_array_r2) + double precision :: contrib_tmp +!print*,'n_act_orb = ',n_act_orb + compute_extra_diag_two_body_dm_ab_act = 0.d0 call give_all_act_mos_at_r(r1,mos_array_r1) call give_all_act_mos_at_r(r2,mos_array_r2) do l = 1, n_act_orb ! p2 do k = 1, n_act_orb ! h2 do j = 1, n_act_orb ! p1 do i = 1,n_act_orb ! h1 - double precision :: contrib_tmp -! print*,'i,j',i,j -! print*,mos_array_r1(i) , mos_array_r1(j) -! print*,'k,l',k,l -! print*,mos_array_r2(k) * mos_array_r2(l) -! print*,'gama = ',two_body_dm_ab_big_array(i,j,k,l) -! pause contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) - compute_extra_diag_two_body_dm_ab += two_body_dm_ab_big_array(i,j,k,l) * contrib_tmp + compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp enddo enddo enddo @@ -334,13 +505,69 @@ double precision function compute_extra_diag_two_body_dm_ab(r1,r2) end -double precision function compute_diag_two_body_dm_ab(r1,r2) +double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + double precision, intent(in) :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_extra_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) + do i = 1, n_act_orb ! h1 + do j = 1, n_act_orb ! p1 + contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) + contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) + do k = 1,n_core_orb ! h2 + contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) + contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) + compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp + enddo + enddo + enddo + +end + +double precision function compute_diag_two_body_dm_ab_core(r1,r2) implicit none double precision :: r1(3),r2(3) integer :: i,j,k,l - double precision :: mos_array_r1(mo_tot_num),mos_array_r2(mo_tot_num) + double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab = 0.d0 + compute_diag_two_body_dm_ab_core = 0.d0 + call give_all_core_mos_at_r(r1,mos_array_r1) + call give_all_core_mos_at_r(r2,mos_array_r2) + do l = 1, n_core_orb ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_core_orb ! + contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp + enddo + enddo + +end + + +double precision function compute_diag_two_body_dm_ab_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib,contrib_tmp + compute_diag_two_body_dm_ab_act = 0.d0 call give_all_act_mos_at_r(r1,mos_array_r1) call give_all_act_mos_at_r(r2,mos_array_r2) do l = 1, n_act_orb ! @@ -349,10 +576,44 @@ double precision function compute_diag_two_body_dm_ab(r1,r2) do k = 1, n_act_orb ! contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) ! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab += two_body_dm_ab_diag(k,l) * contrib_tmp + compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp enddo enddo - end +double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_act_orb ! + contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) + contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do l = 1, n_core_orb ! + contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) + contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) + compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp + enddo + enddo +end +double precision function compute_diag_two_body_dm_ab(r1,r2) + implicit none + double precision,intent(in) :: r1(3),r2(3) + double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core + double precision :: compute_diag_two_body_dm_ab_core_act + compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & + + compute_diag_two_body_dm_ab_core_act(r1,r2) +end diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 3834b121..feed02c1 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -5,6 +5,13 @@ interface: ezfio,provider,ocaml default: False ezfio_name: direct +[no_vvvv_integrals] +type: logical +doc: If True, do not compute the bielectronic integrals when 4 indices are virtual +interface: ezfio,provider,ocaml +default: False +ezfio_name: None + [disk_access_mo_integrals] type: Disk_access doc: Read/Write MO integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 69ca0733..3557772d 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -21,6 +21,7 @@ end BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] implicit none + integer(bit_kind) :: mask_ijkl(N_int,4) BEGIN_DOC ! If True, the map of MO bielectronic integrals is provided @@ -36,7 +37,44 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] endif endif - call add_integrals_to_map(full_ijkl_bitmask_4) + if(no_vvvv_integrals)then + integer :: i,j,k,l + ! (core+inact+act) ^ 4 + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,3) + mask_ijkl(i,4) = core_inact_act_bitmask_4(i,4) + enddo + call add_integrals_to_map(mask_ijkl) + ! (core+inact+act) ^ 3 (virt) ^1 + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,3) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + ! (core+inact+act) ^ 2 (virt) ^2 + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + ! (core+inact+act) ^ 1 (virt) ^3 + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = virt_bitmask(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + + else + call add_integrals_to_map(full_ijkl_bitmask_4) + endif END_PROVIDER subroutine add_integrals_to_map(mask_ijkl) diff --git a/src/MO_Basis/mo_permutation.irp.f b/src/MO_Basis/mo_permutation.irp.f new file mode 100644 index 00000000..72f132d7 --- /dev/null +++ b/src/MO_Basis/mo_permutation.irp.f @@ -0,0 +1,20 @@ +program permut_mos + implicit none + integer :: mo1,mo2 + integer :: i,j,k,l + double precision :: mo_coef_tmp(ao_num_align,2) + print*,'Which MOs would you like to change ?' + read(5,*)mo1,mo2 + print*,'' + do i= 1,ao_num + mo_coef_tmp(i,1) = mo_coef(i,mo1) + mo_coef_tmp(i,2) = mo_coef(i,mo2) + enddo + do i = 1,ao_num + mo_coef(i,mo1) = mo_coef_tmp(i,2) + mo_coef(i,mo2) = mo_coef_tmp(i,1) + enddo + touch mo_coef + call save_mos + +end diff --git a/src/MO_Basis/print_aos.irp.f b/src/MO_Basis/print_aos.irp.f new file mode 100644 index 00000000..f6b3bedf --- /dev/null +++ b/src/MO_Basis/print_aos.irp.f @@ -0,0 +1,53 @@ +program pouet + implicit none + integer :: i,j,k + double precision :: r(3) + double precision, allocatable :: aos_array(:),mos_array(:),ao_ortho_array(:) + allocate(aos_array(ao_num),mos_array(mo_tot_num), ao_ortho_array(ao_num)) + integer :: nx,ny + double precision :: interval_x + double precision :: xmin,xmax + double precision :: dx + + double precision :: interval_y + double precision :: ymin,ymax + double precision :: dy + + double precision :: val_max + +!do i = 1, ao_num +! write(41,'(100(F16.10,X))'),ao_ortho_canonical_overlap(i,:) +!enddo + +!stop + + + xmin = nucl_coord(1,1)-6.d0 + xmax = nucl_coord(2,1)+6.d0 + interval_x = xmax - xmin +!interval_x = nucl_dist(1,3) + nx = 500 + dx = interval_x/dble(nx) +!dx = dabs(interval_x)/dble(nx) * 1.d0/sqrt(2.d0) + + r = 0.d0 + r(3) = xmin +!r(2) = nucl_coord(1,2) +!r(3) = nucl_coord(1,3) +!r(1) = nucl_coord(2,1) +!r(2) = 1.D0 +!r(3) = nucl_coord(2,3) + double precision :: dr(3) +!dr = 0.d0 +!dr(1) = -dx +!dr(3) = dx + do j = 1, nx+1 + call give_all_mos_at_r(r,mos_array) + write(37,'(100(F16.10,X))') r(3),mos_array(1)*mos_array(1) , mos_array(2)*mos_array(2), mos_array(1)*mos_array(2) + write(38,'(100(F16.10,X))') r(3),mos_array(1), mos_array(2), mos_array(1)*mos_array(2) +! write(38,'(100(F16.10,X))') r(3),mos_array(10), mos_array(2) - 0.029916d0 * mos_array(10),mos_array(2) + 0.029916d0 * mos_array(10) + r(3) += dx +! r += dr + enddo + deallocate(aos_array,mos_array, ao_ortho_array) +end diff --git a/src/MO_Basis/print_mo_in_space.irp.f b/src/MO_Basis/print_mo_in_space.irp.f new file mode 100644 index 00000000..5a2bc297 --- /dev/null +++ b/src/MO_Basis/print_mo_in_space.irp.f @@ -0,0 +1,50 @@ +program pouet + implicit none + integer :: i,j,k + double precision :: r(3) + double precision, allocatable :: aos_array(:),mos_array(:),ao_ortho_array(:) + allocate(aos_array(ao_num),mos_array(mo_tot_num), ao_ortho_array(ao_num)) + integer :: nx,ny + double precision :: interval_x + double precision :: xmin,xmax + double precision :: dx + + double precision :: interval_y + double precision :: ymin,ymax + double precision :: dy + + double precision :: val_max + +!do i = 1, ao_num +! write(41,'(100(F16.10,X))'),ao_ortho_canonical_overlap(i,:) +!enddo + +!stop + + + xmin = -4.d0 + xmax = 4.d0 + interval_x = xmax - xmin + nx = 100 + dx = dabs(interval_x)/dble(nx) + + r = 0.d0 +!r(3) = xmin + r(1) = xmin + val_max = 0.d0 + do j = 1, nx +! call give_all_aos_at_r(r,aos_array) + call give_all_mos_at_r(r,mos_array) + write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(1)* mos_array(2) + !write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(4) + !write(37,'(100(F16.10,X))') r(1),mos_array(1) * mos_array(2), mos_array(4)*mos_array(2) +! if(val_max.le.aos_array(1) * aos_array(2) )then +! val_max = aos_array(1) * aos_array(2) +! endif + r(1) += dx +! r(3) += dx + enddo +!write(40,'(100(F16.10,X))')nucl_coord(1,2),nucl_coord(1,3),val_max * 1.5d0 +!write(41,'(100(F16.10,X))')nucl_coord(2,2),nucl_coord(2,3),val_max * 1.5d0 + deallocate(aos_array,mos_array, ao_ortho_array) +end diff --git a/src/Nuclei/atomic_radii.irp.f b/src/Nuclei/atomic_radii.irp.f new file mode 100644 index 00000000..7b04a97b --- /dev/null +++ b/src/Nuclei/atomic_radii.irp.f @@ -0,0 +1,112 @@ +BEGIN_PROVIDER [ double precision, slater_bragg_radii, (100)] + implicit none + BEGIN_DOC + ! atomic radii in Angstrom defined in table I of JCP 41, 3199 (1964) Slater + ! execpt for the Hydrogen atom where we took the value of Becke (1988, JCP) + END_DOC + + slater_bragg_radii = 0.d0 + + slater_bragg_radii(1) = 0.35d0 + slater_bragg_radii(2) = 0.35d0 + + slater_bragg_radii(3) = 1.45d0 + slater_bragg_radii(4) = 1.05d0 + + slater_bragg_radii(5) = 0.85d0 + slater_bragg_radii(6) = 0.70d0 + slater_bragg_radii(7) = 0.65d0 + slater_bragg_radii(8) = 0.60d0 + slater_bragg_radii(9) = 0.50d0 + slater_bragg_radii(10) = 0.45d0 + + slater_bragg_radii(11) = 1.80d0 + slater_bragg_radii(12) = 1.70d0 + + slater_bragg_radii(13) = 1.50d0 + slater_bragg_radii(14) = 1.25d0 + slater_bragg_radii(15) = 1.10d0 + slater_bragg_radii(16) = 1.00d0 + slater_bragg_radii(17) = 1.00d0 + slater_bragg_radii(18) = 1.00d0 + + slater_bragg_radii(19) = 2.20d0 + slater_bragg_radii(20) = 1.80d0 + + + slater_bragg_radii(21) = 1.60d0 + slater_bragg_radii(22) = 1.40d0 + slater_bragg_radii(23) = 1.34d0 + slater_bragg_radii(24) = 1.40d0 + slater_bragg_radii(25) = 1.40d0 + slater_bragg_radii(26) = 1.40d0 + slater_bragg_radii(27) = 1.35d0 + slater_bragg_radii(28) = 1.35d0 + slater_bragg_radii(29) = 1.35d0 + slater_bragg_radii(30) = 1.35d0 + + slater_bragg_radii(31) = 1.30d0 + slater_bragg_radii(32) = 1.25d0 + slater_bragg_radii(33) = 1.15d0 + slater_bragg_radii(34) = 1.15d0 + slater_bragg_radii(35) = 1.15d0 + slater_bragg_radii(36) = 1.15d0 + +END_PROVIDER + +BEGIN_PROVIDER [double precision, slater_bragg_radii_ua, (100)] + implicit none + integer :: i + do i = 1, 100 + slater_bragg_radii_ua(i) = slater_bragg_radii(i) * 1.889725989d0 + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, slater_bragg_radii_per_atom, (nucl_num)] + implicit none + integer :: i + do i = 1, nucl_num + slater_bragg_radii_per_atom(i) = slater_bragg_radii(int(nucl_charge(i))) + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, slater_bragg_radii_per_atom_ua, (nucl_num)] + implicit none + integer :: i + do i = 1, nucl_num + slater_bragg_radii_per_atom_ua(i) = slater_bragg_radii_ua(int(nucl_charge(i))) + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, slater_bragg_type_inter_distance, (nucl_num, nucl_num)] + implicit none + integer :: i,j + double precision :: xhi_tmp,u_ij + slater_bragg_type_inter_distance = 0.d0 + do i = 1, nucl_num + do j = i+1, nucl_num + xhi_tmp = slater_bragg_radii_per_atom(i) / slater_bragg_radii_per_atom(j) + u_ij = (xhi_tmp - 1.d0 ) / (xhi_tmp +1.d0) + slater_bragg_type_inter_distance(i,j) = u_ij / (u_ij * u_ij - 1.d0) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [double precision, slater_bragg_type_inter_distance_ua, (nucl_num, nucl_num)] + implicit none + integer :: i,j + double precision :: xhi_tmp,u_ij + slater_bragg_type_inter_distance_ua = 0.d0 + do i = 1, nucl_num + do j = i+1, nucl_num + xhi_tmp = slater_bragg_radii_per_atom_ua(i) / slater_bragg_radii_per_atom_ua(j) + u_ij = (xhi_tmp - 1.d0 ) / (xhi_tmp +1.d0) + slater_bragg_type_inter_distance_ua(i,j) = u_ij / (u_ij * u_ij - 1.d0) + if(slater_bragg_type_inter_distance_ua(i,j).gt.0.5d0)then + slater_bragg_type_inter_distance_ua(i,j) = 0.5d0 + else if( slater_bragg_type_inter_distance_ua(i,j) .le.-0.5d0)then + slater_bragg_type_inter_distance_ua(i,j) = -0.5d0 + endif + enddo + enddo +END_PROVIDER diff --git a/src/Utils/angular_integration.irp.f b/src/Utils/angular_integration.irp.f new file mode 100644 index 00000000..1efd4abc --- /dev/null +++ b/src/Utils/angular_integration.irp.f @@ -0,0 +1,2264 @@ +BEGIN_PROVIDER [integer, degree_max_integration_lebedev] + BEGIN_DOC +! integrate correctly a polynom of order "degree_max_integration_lebedev" + ! needed for the angular integration according to LEBEDEV formulae + END_DOC + implicit none + degree_max_integration_lebedev= 15 + +END_PROVIDER + +BEGIN_PROVIDER [integer, n_points_integration_angular_lebedev] + BEGIN_DOC +! Number of points needed for the angular integral + END_DOC + implicit none + if (degree_max_integration_lebedev == 3)then + n_points_integration_angular_lebedev = 6 + else if (degree_max_integration_lebedev == 5)then + n_points_integration_angular_lebedev = 14 + else if (degree_max_integration_lebedev == 7)then + n_points_integration_angular_lebedev = 26 + else if (degree_max_integration_lebedev == 9)then + n_points_integration_angular_lebedev = 38 + else if (degree_max_integration_lebedev == 11)then + n_points_integration_angular_lebedev = 50 + else if (degree_max_integration_lebedev == 13)then + n_points_integration_angular_lebedev = 74 + else if (degree_max_integration_lebedev == 15)then + n_points_integration_angular_lebedev = 86 + else if (degree_max_integration_lebedev == 17)then + n_points_integration_angular_lebedev = 110 + else if (degree_max_integration_lebedev == 19)then + n_points_integration_angular_lebedev = 146 + else if (degree_max_integration_lebedev == 21)then + n_points_integration_angular_lebedev = 170 + endif + +END_PROVIDER + + BEGIN_PROVIDER [double precision, theta_angular_integration_lebedev, (n_points_integration_angular_lebedev)] +&BEGIN_PROVIDER [double precision, phi_angular_integration_lebedev, (n_points_integration_angular_lebedev)] +&BEGIN_PROVIDER [double precision, weights_angular_integration_lebedev, (n_points_integration_angular_lebedev)] + implicit none + BEGIN_DOC +! Theta phi values together with the weights values for the angular integration : +! integral [dphi,dtheta] f(x,y,z) = 4 * pi * sum (1 Date: Wed, 24 Aug 2016 16:43:01 +0200 Subject: [PATCH 07/32] Formally finished to code the MRPT_Utils --- plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 60 +++ plugins/MRPT_Utils/energies_cas.irp.f | 457 ++++++++++++++++++ .../energies_cas_spin_averaged.irp.f | 190 ++++++++ plugins/MRPT_Utils/fock_like_operators.irp.f | 170 +++++++ plugins/MRPT_Utils/psi_active_prov.irp.f | 279 +++++++++++ plugins/MRPT_Utils/utils_bitmask.irp.f | 36 ++ src/Bitmask/bitmasks.irp.f | 33 +- src/Determinants/create_excitations.irp.f | 13 + 8 files changed, 1237 insertions(+), 1 deletion(-) create mode 100644 plugins/MRPT_Utils/MRPT_Utils.main.irp.f create mode 100644 plugins/MRPT_Utils/energies_cas.irp.f create mode 100644 plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f create mode 100644 plugins/MRPT_Utils/fock_like_operators.irp.f create mode 100644 plugins/MRPT_Utils/psi_active_prov.irp.f create mode 100644 plugins/MRPT_Utils/utils_bitmask.irp.f diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f new file mode 100644 index 00000000..c65e89d8 --- /dev/null +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -0,0 +1,60 @@ +program MRPT_Utils + implicit none + read_wf = .True. + touch read_wf +! call routine +! call routine_2 + call routine_3 +end + + +subroutine routine_3 + implicit none + provide one_creation + +end + +subroutine routine_2 + implicit none + integer :: i + do i = 1, n_core_inact_orb + print*,fock_core_inactive_total(i,1),fock_core_inactive(i) + enddo + double precision :: accu + accu = 0.d0 + do i = 1, n_act_orb + integer :: j_act_orb + j_act_orb = list_act(i) + accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb) + print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb),one_body_dm_mo_beta(j_act_orb,j_act_orb) + enddo + print*,'accu = ',accu + +end + +subroutine routine + implicit none + integer :: i,j + integer :: orb, spin_exc + integer :: hole_particle + double precision, allocatable :: norm_out(:) + allocate(norm_out(N_states_diag)) + + orb = list_virt(10) + hole_particle = -1 + spin_exc = 1 + + call apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_det,psi_coef, n_det,psi_det_size,psi_det_size,N_states_diag) + do i = 1, N_det + if(psi_coef(i,1).ne.0.d0)then + print*, '' + call debug_det(psi_det(1,1,i),N_int) + print*, 'coef = ',psi_coef(i,1) + endif + enddo + print*,'norm_out = ',norm_out + + deallocate(norm_out) + +end diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f new file mode 100644 index 00000000..dda6e11e --- /dev/null +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -0,0 +1,457 @@ +BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] + implicit none + integer :: i + double precision :: energies(N_states_diag) + do i = 1, N_states + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + energy_cas_dyall(i) = energies(i) + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, one_creation, (n_act_orb,2)] + implicit none + integer :: i,j + integer :: ispin + integer :: orb, hole_particle,spin_exc + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb + do iorb = 1,n_act_orb + do ispin = 1,2 + orb = list_act(iorb) + hole_particle = 1 + spin_exc = ispin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + call apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_creation(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_anhilation, (n_act_orb,2)] + implicit none + integer :: i,j + integer :: ispin + integer :: orb, hole_particle,spin_exc + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb + do iorb = 1,n_act_orb + do ispin = 1,2 + orb = list_act(iorb) + hole_particle = -1 + spin_exc = ispin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + call apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhilation(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_creation, (n_act_orb,n_act_orb,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = 1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = 1 + spin_exc_j = jspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_anhilation, (n_act_orb,n_act_orb,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = -1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = -1 + spin_exc_j = jspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhilation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_anhilation_one_creation, (n_act_orb,n_act_orb,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = 1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = -1 + spin_exc_j = jspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhilation_one_creation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_anhilation_one_creation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: korb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = 1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = -1 + spin_exc_j = jspin + do korb = 1, n_act_orb + do kspin = 1,2 + orb_k = list_act(korb) + hole_particle_k = -1 + spin_exc_k = kspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhilation_one_creation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_creation_one_anhilation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: korb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = 1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = 1 + spin_exc_j = jspin + do korb = 1, n_act_orb + do kspin = 1,2 + orb_k = list_act(korb) + hole_particle_k = -1 + spin_exc_k = kspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creation_one_anhilation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_creation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: korb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = 1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = 1 + spin_exc_j = jspin + do korb = 1, n_act_orb + do kspin = 1,2 + orb_k = list_act(korb) + hole_particle_k = 1 + spin_exc_k = kspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_creation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, three_anhilation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] + implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,n_det) + double precision :: psi_in_out_coef(n_det,N_states_diag) + use bitmasks + + integer :: iorb,jorb + integer :: korb + integer :: state_target + state_target = 1 + double precision :: energies(n_states_diag) + do iorb = 1,n_act_orb + do ispin = 1,2 + orb_i = list_act(iorb) + hole_particle_i = -1 + spin_exc_i = ispin + do jorb = 1, n_act_orb + do jspin = 1,2 + orb_j = list_act(jorb) + hole_particle_j = -1 + spin_exc_j = jspin + do korb = 1, n_act_orb + do kspin = 1,2 + orb_k = list_act(korb) + hole_particle_k = -1 + spin_exc_k = kspin + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,1,i) = psi_active(j,2,i) + enddo + enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_anhilation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER diff --git a/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f b/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f new file mode 100644 index 00000000..6ecffcce --- /dev/null +++ b/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f @@ -0,0 +1,190 @@ + +BEGIN_PROVIDER [ double precision, one_creation_spin_averaged, (n_act_orb)] + implicit none + integer :: i + do i = 1, n_act_orb + one_creation_spin_averaged(i) = one_creation(i,1) + one_creation(i,2) + one_creation_spin_averaged(i) = 0.5d0 * one_creation_spin_averaged(i) + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, one_anhilation_spin_averaged, (n_act_orb)] + implicit none + integer :: i + do i = 1, n_act_orb + one_anhilation_spin_averaged(i) = one_anhilation(i,1) + one_anhilation(i,2) + one_anhilation_spin_averaged(i) = 0.5d0 * one_anhilation_spin_averaged(i) + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_creation_spin_averaged, (n_act_orb,n_act_orb)] + implicit none + integer :: i,j + integer :: ispin,jspin + double precision :: counting + do i = 1, n_act_orb + do j = 1, n_act_orb + two_creation_spin_averaged(j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + two_creation_spin_averaged(j,i) += two_creation(j,i,ispin,jspin) + counting += 1.d0 + enddo + enddo + two_creation_spin_averaged(j,i) = two_creation_spin_averaged(j,i) / counting + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_anhilation_spin_averaged, (n_act_orb,n_act_orb)] + implicit none + integer :: i,j + integer :: ispin,jspin + double precision :: counting + do i = 1, n_act_orb + do j = 1, n_act_orb + two_anhilation_spin_averaged(j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + two_anhilation_spin_averaged(j,i) += two_anhilation(j,i,ispin,jspin) + counting += 1.d0 + enddo + enddo + two_anhilation_spin_averaged(j,i) = two_anhilation_spin_averaged(j,i) / counting + enddo + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, one_anhilation_one_creation_spin_averaged, (n_act_orb,n_act_orb)] + implicit none + integer :: i,j + integer :: ispin,jspin + double precision :: counting + do i = 1, n_act_orb + do j = 1, n_act_orb + one_anhilation_one_creation_spin_averaged(j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + one_anhilation_one_creation_spin_averaged(j,i) += one_anhilation_one_creation(j,i,jspin,ispin) + counting += 1.d0 + enddo + enddo + one_anhilation_one_creation_spin_averaged(j,i) = one_anhilation_one_creation_spin_averaged(j,i) / counting + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, two_anhilation_one_creation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k + integer :: ispin,jspin,kspin + double precision :: counting + + do i = 1, n_act_orb + do j = 1, n_act_orb + do k = 1, n_act_orb + two_anhilation_one_creation_spin_averaged(k,j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + do kspin = 1,2 + two_anhilation_one_creation_spin_averaged(k,j,i) += two_anhilation_one_creation(k,j,i,kspin,jspin,ispin) + counting += 1.d0 + enddo + enddo + two_anhilation_one_creation_spin_averaged(k,j,i) = two_anhilation_one_creation_spin_averaged(k,j,i) / counting + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_creation_one_anhilation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k + integer :: ispin,jspin,kspin + double precision :: counting + + do i = 1, n_act_orb + do j = 1, n_act_orb + do k = 1, n_act_orb + two_creation_one_anhilation_spin_averaged(k,j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + do kspin = 1,2 + two_creation_one_anhilation_spin_averaged(k,j,i) += two_creation_one_anhilation(k,j,i,kspin,jspin,ispin) + counting += 1.d0 + enddo + enddo + two_creation_one_anhilation_spin_averaged(k,j,i) = two_creation_one_anhilation_spin_averaged(k,j,i) / counting + enddo + enddo + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_creation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k + integer :: ispin,jspin,kspin + double precision :: counting + + do i = 1, n_act_orb + do j = 1, n_act_orb + do k = 1, n_act_orb + three_creation_spin_averaged(k,j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + do kspin = 1,2 + three_creation_spin_averaged(k,j,i) += three_creation(k,j,i,kspin,jspin,ispin) + counting += 1.d0 + enddo + enddo + three_creation_spin_averaged(k,j,i) = three_creation_spin_averaged(k,j,i) / counting + enddo + enddo + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, three_anhilation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k + integer :: ispin,jspin,kspin + double precision :: counting + + do i = 1, n_act_orb + do j = 1, n_act_orb + do k = 1, n_act_orb + three_anhilation_spin_averaged(k,j,i) = 0.d0 + counting = 0.d0 + do ispin = 1, 2 + do jspin = 1,2 + do kspin = 1,2 + three_anhilation_spin_averaged(k,j,i) += three_anhilation(k,j,i,kspin,jspin,ispin) + counting += 1.d0 + enddo + enddo + three_anhilation_spin_averaged(k,j,i) = three_anhilation_spin_averaged(k,j,i) / counting + enddo + enddo + enddo + enddo + +END_PROVIDER + diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f new file mode 100644 index 00000000..c7e21d0c --- /dev/null +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -0,0 +1,170 @@ + BEGIN_PROVIDER [double precision, fock_core_inactive, (mo_tot_num)] + BEGIN_DOC +! inactive part of the fock operator with contributions only from the inactive + END_DOC + implicit none + integer :: i,j + double precision :: accu + + integer :: j_inact_core_orb,i_inact_core_orb + do i = 1, n_core_inact_orb + accu = 0.d0 + i_inact_core_orb = list_core_inact(i) + do j = 1, n_core_inact_orb +! do j = 1, elec_alpha_num +! j_inact_core_orb = j + j_inact_core_orb = list_core_inact(j) + accu += 2.d0 * mo_bielec_integral_jj(i_inact_core_orb,j_inact_core_orb) & + - mo_bielec_integral_jj_exchange(i_inact_core_orb,j_inact_core_orb) + enddo + fock_core_inactive(i_inact_core_orb) = accu + mo_mono_elec_integral(i_inact_core_orb,i_inact_core_orb) + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, fock_virt_from_core_inact, (mo_tot_num)] + BEGIN_DOC +! fock operator for the virtuals that comes from the doubly occupied orbitals + END_DOC + implicit none + integer :: i,j + double precision :: accu + + integer :: j_inact_core_orb,i_virt_orb + do i = 1, n_virt_orb + accu = 0.d0 + i_virt_orb = list_virt(i) + do j = 1, n_core_inact_orb +! do j = 1, elec_alpha_num +! j_inact_core_orb = j + j_inact_core_orb = list_core_inact(j) + accu += 2.d0 * mo_bielec_integral_jj(i_virt_orb,j_inact_core_orb) & + - mo_bielec_integral_jj_exchange(i_virt_orb,j_inact_core_orb) + enddo + fock_virt_from_core_inact(i_virt_orb) = accu + mo_mono_elec_integral(i_virt_orb,i_virt_orb) + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2)] + BEGIN_DOC +! inactive part of the fock operator with contributions only from the active + END_DOC + implicit none + integer :: i,j + double precision :: accu_coulomb,accu_exchange(2) + double precision :: na,nb,ntot + double precision :: coulomb, exchange + integer :: j_act_orb,i_inact_core_orb + + do i = 1, n_core_inact_orb + accu_coulomb = 0.d0 + accu_exchange = 0.d0 + i_inact_core_orb = list_core_inact(i) + do j = 1, n_act_orb + j_act_orb = list_act(j) + na = one_body_dm_mo_alpha(j_act_orb,j_act_orb) + nb = one_body_dm_mo_beta(j_act_orb,j_act_orb) + ntot = na + nb + coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb) + exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb) + accu_coulomb += ntot * coulomb + accu_exchange(1) += na * exchange + accu_exchange(2) += nb * exchange + enddo + fock_core_inactive_from_act(i_inact_core_orb,1) = accu_coulomb + accu_exchange(1) + fock_core_inactive_from_act(i_inact_core_orb,2) = accu_coulomb + accu_exchange(2) + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2)] + BEGIN_DOC +! virtual part of the fock operator with contributions only from the active + END_DOC + implicit none + integer :: i,j + double precision :: accu_coulomb,accu_exchange(2) + double precision :: na,nb,ntot + double precision :: coulomb, exchange + integer :: j_act_orb,i_virt_orb + + do i = 1, n_virt_orb + accu_coulomb = 0.d0 + accu_exchange = 0.d0 + i_virt_orb = list_virt(i) + do j = 1, n_act_orb + j_act_orb = list_act(j) + na = one_body_dm_mo_alpha(j_act_orb,j_act_orb) + nb = one_body_dm_mo_beta(j_act_orb,j_act_orb) + ntot = na + nb + coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb) + exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb) + accu_coulomb += ntot * coulomb + accu_exchange(1) += na * exchange + accu_exchange(2) += nb * exchange + enddo + fock_virt_from_act(i_virt_orb,1) = accu_coulomb + accu_exchange(1) + fock_virt_from_act(i_virt_orb,2) = accu_coulomb + accu_exchange(2) + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2)] +&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_averaged, (mo_tot_num)] + BEGIN_DOC +! inactive part of the fock operator + END_DOC + implicit none + integer :: i + integer :: i_inact_core_orb + do i = 1, n_core_inact_orb + i_inact_core_orb = list_core_inact(i) + fock_core_inactive_total(i_inact_core_orb,1) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1) + fock_core_inactive_total(i_inact_core_orb,2) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2) + fock_core_inactive_total_spin_averaged(i_inact_core_orb) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1) + fock_core_inactive_total(i_inact_core_orb,2)) + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2)] +&BEGIN_PROVIDER [double precision, fock_virt_total_spin_averaged, (mo_tot_num)] + BEGIN_DOC +! inactive part of the fock operator + END_DOC + implicit none + integer :: i + integer :: i_virt_orb + do i = 1, n_virt_orb + i_virt_orb= list_virt(i) + fock_virt_total(i_virt_orb,1) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2) + fock_virt_total_spin_averaged(i_virt_orb) = 0.5d0 * ( fock_virt_total(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) ) + enddo + END_PROVIDER + + + + + + BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (n_act_orb,n_act_orb)] + BEGIN_DOC +! active part of the fock operator with contributions only from the inactive + END_DOC + implicit none + integer :: i,j,k + double precision :: accu + double precision :: get_mo_bielec_integral,coulomb, exchange + PROVIDE mo_bielec_integrals_in_map + do i = 1, n_act_orb + do j = 1, n_act_orb + accu = 0.d0 + do k = 1, n_core_inact_orb + coulomb = get_mo_bielec_integral(k,i,k,j,mo_integrals_map) + exchange = get_mo_bielec_integral(k,i,i,k,mo_integrals_map) + accu += 2.d0 * coulomb - exchange + enddo + fock_operator_active_from_core_inact(i,j) = accu + enddo + enddo + + END_PROVIDER + + + + diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f new file mode 100644 index 00000000..e5848814 --- /dev/null +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -0,0 +1,279 @@ + + use bitmasks +BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] + BEGIN_DOC +! active part of psi + END_DOC + implicit none + use bitmasks + integer :: i,j,k,l + do i = 1, N_det + do j = 1, N_int + psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) + psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) + enddo + enddo +END_PROVIDER + + +subroutine give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin,n_particles_spin,n_holes,n_particles,& + holes_active_list,particles_active_list) + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_1(N_int,2) + integer(bit_kind),intent(in ) :: det_2(N_int,2) + integer, intent(out) :: n_holes_spin(2),n_particles_spin(2) + integer, intent(out) :: n_holes,n_particles + integer, intent(out) :: holes_active_list(2 * n_act_orb,2) + integer, intent(out) :: particles_active_list(2 * n_act_orb,2) + integer :: i + integer(bit_kind) :: holes(N_int,2) + integer(bit_kind) :: particles(N_int,2) + integer(bit_kind) :: det_tmp_2(N_int,2),det_tmp_1(N_int,2) + BEGIN_DOC +! returns the holes and particles operators WITHIN THE ACTIVE SPACE +! that connect det_1 and det_2. By definition, the holes/particles +! are such that one starts from det_1 and goes to det_2 +! +! n_holes is the total number of holes +! n_particles is the total number of particles +! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta) +! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta) +! holes_active_list is the index of the holes per spin, that ranges from 1 to n_act_orb +! particles_active_list is the index of the particles per spin, that ranges from 1 to n_act_orb + END_DOC + + call give_active_part_determinant(det_1,det_tmp_1) + call give_active_part_determinant(det_2,det_tmp_2) + do i = 1, N_int + holes(i,1) = iand(det_tmp_1(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1))) + holes(i,2) = iand(det_tmp_1(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2))) + particles(i,1) = iand(det_tmp_2(i,1),xor(det_tmp_1(i,1),det_tmp_2(i,1))) + particles(i,2) = iand(det_tmp_2(i,2),xor(det_tmp_1(i,2),det_tmp_2(i,2))) + enddo + + integer :: holes_list(N_int*bit_kind_size,2) + holes_list = 0 + call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int) + call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int) + + n_holes = 0 + do i = 1, n_holes_spin(1) + n_holes +=1 + holes_active_list(i,1) = list_act_reverse(holes_list(i,1)) + enddo + do i = 1, n_holes_spin(2) + n_holes +=1 + holes_active_list(i,2) = list_act_reverse(holes_list(i,2)) + enddo + + + integer :: particles_list(N_int*bit_kind_size,2) + particles_list = 0 + call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int) + call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int) + n_particles = 0 + do i = 1, n_particles_spin(1) + n_particles += 1 + particles_active_list(i,1) = list_act_reverse(particles_list(i,1)) + enddo + do i = 1, n_particles_spin(2) + n_particles += 1 + particles_active_list(i,2) = list_act_reverse(particles_list(i,2)) + enddo + +end + +subroutine give_holes_in_inactive_space(det_1,n_holes_spin,n_holes,holes_list) + BEGIN_DOC +! returns the holes operators WITHIN THE INACTIVE SPACE +! that has lead to det_1. +! +! n_holes is the total number of holes +! n_holes_spin is the number of number of holes per spin (1=alpha, 2=beta) +! holes_inactive_list is the index of the holes per spin, that ranges from 1 to mo_tot_num + END_DOC + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_1(N_int,2) + integer, intent(out) :: n_holes_spin(2) + integer, intent(out) :: n_holes + integer, intent(out) :: holes_list(N_int*bit_kind_size,2) + integer :: i + integer(bit_kind) :: holes(N_int,2) + integer(bit_kind) :: det_tmp_1(N_int,2) + + call give_core_inactive_part_determinant(det_1,det_tmp_1) + + do i = 1, N_int + holes(i,1) = iand(reunion_of_core_inact_bitmask(i,1),xor(det_tmp_1(i,1),reunion_of_core_inact_bitmask(i,1))) + holes(i,2) = iand(reunion_of_core_inact_bitmask(i,2),xor(det_tmp_1(i,2),reunion_of_core_inact_bitmask(i,2))) + enddo + holes_list = 0 + call bitstring_to_list(holes(1,1), holes_list(1,1), n_holes_spin(1), N_int) + call bitstring_to_list(holes(1,2), holes_list(1,2), n_holes_spin(2), N_int) + n_holes = n_holes_spin(1) + n_holes_spin(2) + +end + +subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,particles_list) + BEGIN_DOC +! returns the holes operators WITHIN THE VIRTUAL SPACE +! that has lead to det_1. +! +! n_particles is the total number of particles +! n_particles_spin is the number of number of particles per spin (1=alpha, 2=beta) +! particles_inactive_list is the index of the particles per spin, that ranges from 1 to mo_tot_num + END_DOC + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_1(N_int,2) + integer, intent(out) :: n_particles_spin(2) + integer, intent(out) :: n_particles + integer, intent(out) :: particles_list(N_int*bit_kind_size,2) + integer :: i + integer(bit_kind) :: det_tmp_1(N_int,2) + integer(bit_kind) :: particles(N_int,2) + + call give_virt_part_determinant(det_1,det_tmp_1) + + do i = 1, N_int + particles(i,1) = iand(virt_bitmask(i,1),xor(det_tmp_1(i,1),virt_bitmask(i,1))) + particles(i,2) = iand(virt_bitmask(i,2),xor(det_tmp_1(i,2),virt_bitmask(i,2))) + enddo + + particles_list = 0 + call bitstring_to_list(particles(1,1), particles_list(1,1), n_particles_spin(1), N_int) + call bitstring_to_list(particles(1,2), particles_list(1,2), n_particles_spin(2), N_int) + n_particles = n_particles_spin(1) + n_particles_spin(2) + + +end + +subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) + implicit none + use bitmasks + double precision, intent(out) :: delta_e_final + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer :: i,j,k,l + + integer :: n_holes_spin(2) + integer :: n_holes + integer :: holes_list(N_int*bit_kind_size,2) + + + double precision :: delta_e_inactive + integer :: i_hole_inact + + call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) + delta_e_inactive = 0.d0 + do i = 1, n_holes_spin(1) + i_hole_inact = holes_list(i,1) + delta_e_inactive += fock_core_inactive_total_spin_averaged(i_hole_inact) + enddo + + do i = 1, n_holes_spin(2) + i_hole_inact = holes_list(i,2) + delta_e_inactive += fock_core_inactive_total_spin_averaged(i_hole_inact) + enddo + + double precision :: delta_e_virt + integer :: i_part_virt + integer :: n_particles_spin(2) + integer :: n_particles + integer :: particles_list(N_int*bit_kind_size,2) + + call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) + delta_e_virt = 0.d0 + do i = 1, n_particles_spin(1) + i_part_virt = particles_list(i,1) + delta_e_virt += fock_virt_total_spin_averaged(i_part_virt) + enddo + + + integer :: n_holes_spin_act(2),n_particles_spin_act(2) + integer :: n_holes_act,n_particles_act + integer :: holes_active_list(2*n_act_orb,2) + integer :: holes_active_list_spin_traced(4*n_act_orb) + integer :: particles_active_list(2*n_act_orb,2) + integer :: particles_active_list_spin_traced(4*n_act_orb) + double precision :: delta_e_act + delta_e_act = 0.d0 + call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & + n_holes_act,n_particles_act,holes_active_list,particles_active_list) + integer :: icount + icount = 0 + do i = 1, n_holes_spin_act(1) + icount += 1 + holes_active_list_spin_traced(icount) = holes_active_list(i,1) + enddo + do i = 1, n_holes_spin_act(2) + icount += 1 + holes_active_list_spin_traced(icount) = holes_active_list(i,2) + enddo + if(icount .ne. n_holes) then + print * , 'pb in holes_active_list_spin_traced !!' + stop + endif + + icount = 0 + do i = 1, n_particles_spin_act(1) + icount += 1 + particles_active_list_spin_traced(icount) = particles_active_list(i,1) + enddo + do i = 1, n_particles_spin_act(2) + icount += 1 + particles_active_list_spin_traced(icount) = particles_active_list(i,2) + enddo + if(icount .ne. n_particles) then + print * , 'pb in particles_active_list_spin_traced !!' + stop + endif + + + integer :: i_hole_act, j_hole_act, k_hole_act + integer :: i_particle_act, j_particle_act, k_particle_act + + + if (n_holes_act == 1 .and. n_particles_act == 0) then + i_hole_act = holes_active_list_spin_traced(1) + delta_e_act += one_creation_spin_averaged(i_hole_act) + + else if (n_holes_act == 0 .and. n_particles_act == 1) then + i_particle_act = particles_active_list_spin_traced(1) + delta_e_act += one_anhilation_spin_averaged(i_particle_act) + + else if (n_holes_act == 1 .and. n_particles_act == 1) then + i_hole_act = holes_active_list_spin_traced(1) + i_particle_act = particles_active_list_spin_traced(1) + delta_e_act += one_anhilation_one_creation_spin_averaged(i_hole_act,i_particle_act) + + else if (n_holes_act == 2 .and. n_particles_act == 1) then + i_hole_act = holes_active_list_spin_traced(1) + j_hole_act = holes_active_list_spin_traced(2) + i_particle_act = particles_active_list_spin_traced(1) + delta_e_act += two_anhilation_one_creation_spin_averaged(i_hole_act,j_hole_act,i_particle_act) + + else if (n_holes_act == 1 .and. n_particles_act == 2) then + i_hole_act = holes_active_list_spin_traced(1) + i_particle_act = particles_active_list_spin_traced(1) + j_particle_act = particles_active_list_spin_traced(2) + delta_e_act += two_creation_one_anhilation_spin_averaged(i_hole_act,i_particle_act,j_particle_act) + + else if (n_holes_act == 3 .and. n_particles_act == 0) then + i_hole_act = holes_active_list_spin_traced(1) + j_hole_act = holes_active_list_spin_traced(2) + k_hole_act = holes_active_list_spin_traced(3) + delta_e_act += three_anhilation_spin_averaged(i_hole_act,j_hole_act,k_hole_act) + + else if (n_holes_act == 0 .and. n_particles_act == 3) then + i_particle_act = particles_active_list_spin_traced(1) + j_particle_act = particles_active_list_spin_traced(2) + k_particle_act = particles_active_list_spin_traced(3) + delta_e_act += three_creation_spin_averaged(i_particle_act,j_particle_act,k_particle_act) + + endif + + delta_e_final = delta_e_act + delta_e_virt + delta_e_inactive + +end diff --git a/plugins/MRPT_Utils/utils_bitmask.irp.f b/plugins/MRPT_Utils/utils_bitmask.irp.f new file mode 100644 index 00000000..1b262eb6 --- /dev/null +++ b/plugins/MRPT_Utils/utils_bitmask.irp.f @@ -0,0 +1,36 @@ + +subroutine give_active_part_determinant(det_in,det_out) + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_in(N_int,2) + integer(bit_kind),intent(out) :: det_out(N_int,2) + integer :: i + do i = 1,N_int + det_out(i,1) = iand(det_in(i,1),cas_bitmask(i,1,1)) + det_out(i,2) = iand(det_in(i,2),cas_bitmask(i,1,1)) + enddo +end + +subroutine give_core_inactive_part_determinant(det_in,det_out) + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_in(N_int,2) + integer(bit_kind),intent(out) :: det_out(N_int,2) + integer :: i + do i = 1,N_int + det_out(i,1) = iand(det_in(i,1),reunion_of_core_inact_bitmask(i,1)) + det_out(i,2) = iand(det_in(i,2),reunion_of_core_inact_bitmask(i,1)) + enddo +end + +subroutine give_virt_part_determinant(det_in,det_out) + implicit none + use bitmasks + integer(bit_kind),intent(in) :: det_in(N_int,2) + integer(bit_kind),intent(out) :: det_out(N_int,2) + integer :: i + do i = 1,N_int + det_out(i,1) = iand(det_in(i,1),virt_bitmask(i,1)) + det_out(i,2) = iand(det_in(i,2),virt_bitmask(i,1)) + enddo +end diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index f23d51e9..c52ed837 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -431,12 +431,40 @@ END_PROVIDER END_PROVIDER + + BEGIN_PROVIDER [ integer, list_core_inact, (n_core_inact_orb)] +&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_tot_num)] + + implicit none + integer :: occ_inact(N_int*bit_kind_size) + integer :: itest,i + occ_inact = 0 + + call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), occ_inact(1), itest, N_int) + + list_core_inact_reverse = 0 + do i = 1, n_core_inact_orb + list_core_inact(i) = occ_inact(i) + list_core_inact_reverse(occ_inact(i)) = i + enddo + + END_PROVIDER + + BEGIN_PROVIDER [ integer, n_core_inact_orb ] + implicit none + integer :: i + n_core_inact_orb = 0 + do i = 1, N_int + n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) + enddo + ENd_PROVIDER + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] implicit none BEGIN_DOC ! Reunion of the core and inactive and virtual bitmasks END_DOC - integer :: i,j + integer :: i do i = 1, N_int reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1)) reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2)) @@ -474,6 +502,7 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)] +&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)] implicit none BEGIN_DOC ! Reunion of the inactive and virtual bitmasks @@ -482,6 +511,8 @@ END_PROVIDER do i = 1, N_int inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1)) inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) + core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1)) + core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) enddo END_PROVIDER diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index b7233beb..a487cc23 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -45,3 +45,16 @@ subroutine set_bit_to_integer(i_physical,key,Nint) j = i_physical-ishft(k-1,bit_kind_shift)-1 key(k) = ibset(key(k),j) end + + +subroutine clear_bit_to_integer(i_physical,key,Nint) + use bitmasks + implicit none + integer, intent(in) :: i_physical,Nint + integer(bit_kind), intent(inout) :: key(Nint) + integer :: k,j,i + k = ishft(i_physical-1,-bit_kind_shift)+1 + j = i_physical-ishft(k-1,bit_kind_shift)-1 + key(k) = ibclr(key(k),j) +end + From 0075d01bd9f9a3165db617c701709da62d5ee42b Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 26 Aug 2016 18:00:49 +0200 Subject: [PATCH 08/32] New perturbation theory is working --- config/ifort.cfg | 2 +- plugins/Full_CI/H_apply.irp.f | 7 +- plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 4 +- plugins/MRPT_Utils/energies_cas.irp.f | 103 +++++---- .../energies_cas_spin_averaged.irp.f | 68 +++--- plugins/MRPT_Utils/fock_like_operators.irp.f | 63 ++++-- plugins/MRPT_Utils/psi_active_prov.irp.f | 195 +++++++++++++++--- plugins/Perturbation/NEEDED_CHILDREN_MODULES | 2 +- plugins/Perturbation/pt2_equations.irp.f | 51 ++++- plugins/Selectors_full/e_corr_selectors.irp.f | 2 +- plugins/Selectors_full/selectors.irp.f | 4 +- src/Determinants/slater_rules.irp.f | 1 + src/Determinants/test_3d.irp.f | 18 +- 13 files changed, 374 insertions(+), 146 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index da414912..a738a83c 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 1eb2d45a..921b9a1a 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -7,7 +7,12 @@ s.set_selection_pt2("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply_zmq("FCI_PT2") +s = H_apply("FCI_PT2_new") +s.set_perturbation("decontracted") +s.unset_openmp() +print s + +s = H_apply("FCI_PT2") s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index c65e89d8..c8140f70 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -10,7 +10,9 @@ end subroutine routine_3 implicit none - provide one_creation +!provide fock_virt_total_spin_trace + provide energy_cas_dyall + print*, 'nuclear_reuplsion = ',nuclear_repulsion end diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index dda6e11e..0c104be6 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -3,20 +3,21 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] integer :: i double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0(energies,psi_det,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall(i) = energies(i) + print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, one_creation, (n_act_orb,2)] +BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2)] implicit none integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind) :: psi_in_out(N_int,2,N_det) + double precision :: psi_in_out_coef(N_det,N_states_diag) use bitmasks integer :: iorb @@ -30,8 +31,8 @@ BEGIN_PROVIDER [ double precision, one_creation, (n_act_orb,2)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo integer :: state_target @@ -40,13 +41,13 @@ BEGIN_PROVIDER [ double precision, one_creation, (n_act_orb,2)] call apply_exc_to_psi(orb,hole_particle,spin_exc, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_creation(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) + one_creat(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhilation, (n_act_orb,2)] +BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2)] implicit none integer :: i,j integer :: ispin @@ -67,8 +68,8 @@ BEGIN_PROVIDER [ double precision, one_anhilation, (n_act_orb,2)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo integer :: state_target @@ -76,14 +77,25 @@ BEGIN_PROVIDER [ double precision, one_anhilation, (n_act_orb,2)] double precision :: energies(n_states_diag) call apply_exc_to_psi(orb,hole_particle,spin_exc, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) +! do j = 1, n_det +! print*, 'psi_in_out_coef' +! print*, psi_in_out_coef(j,1) +! call debug_det(psi_in_out(1,1,j),N_int) +! enddo call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhilation(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) +! print*,'energy_cas_dyall(state_target)' +! print*, energy_cas_dyall(state_target) +! print*,'energies(state_target)' +! print*, energies(state_target) + one_anhil(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) +! print*,'one_anhil(iorb,ispin)' +! print*, one_anhil(iorb,ispin) enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creation, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2)] implicit none integer :: i,j integer :: ispin,jspin @@ -113,8 +125,8 @@ BEGIN_PROVIDER [ double precision, two_creation, (n_act_orb,n_act_orb,2,2)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & @@ -122,7 +134,7 @@ BEGIN_PROVIDER [ double precision, two_creation, (n_act_orb,n_act_orb,2,2)] call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + two_creat(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -130,7 +142,7 @@ BEGIN_PROVIDER [ double precision, two_creation, (n_act_orb,n_act_orb,2,2)] END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhilation, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2)] implicit none integer :: i,j integer :: ispin,jspin @@ -160,8 +172,8 @@ BEGIN_PROVIDER [ double precision, two_anhilation, (n_act_orb,n_act_orb,2,2)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & @@ -169,7 +181,7 @@ BEGIN_PROVIDER [ double precision, two_anhilation, (n_act_orb,n_act_orb,2,2)] call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhilation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + two_anhil(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -177,7 +189,7 @@ BEGIN_PROVIDER [ double precision, two_anhilation, (n_act_orb,n_act_orb,2,2)] END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhilation_one_creation, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2)] implicit none integer :: i,j integer :: ispin,jspin @@ -207,16 +219,16 @@ BEGIN_PROVIDER [ double precision, one_anhilation_one_creation, (n_act_orb,n_act psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhilation_one_creation(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -224,7 +236,7 @@ BEGIN_PROVIDER [ double precision, one_anhilation_one_creation, (n_act_orb,n_act END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhilation_one_creation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -261,18 +273,19 @@ BEGIN_PROVIDER [ double precision, two_anhilation_one_creation, (n_act_orb,n_act psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhilation_one_creation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -282,7 +295,7 @@ BEGIN_PROVIDER [ double precision, two_anhilation_one_creation, (n_act_orb,n_act END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creation_one_anhilation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -319,18 +332,18 @@ BEGIN_PROVIDER [ double precision, two_creation_one_anhilation, (n_act_orb,n_act psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creation_one_anhilation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -340,7 +353,7 @@ BEGIN_PROVIDER [ double precision, two_creation_one_anhilation, (n_act_orb,n_act END_PROVIDER -BEGIN_PROVIDER [ double precision, three_creation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -377,8 +390,8 @@ BEGIN_PROVIDER [ double precision, three_creation, (n_act_orb,n_act_orb,n_act_or psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & @@ -388,7 +401,7 @@ BEGIN_PROVIDER [ double precision, three_creation, (n_act_orb,n_act_orb,n_act_or call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_creation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -398,7 +411,7 @@ BEGIN_PROVIDER [ double precision, three_creation, (n_act_orb,n_act_orb,n_act_or END_PROVIDER -BEGIN_PROVIDER [ double precision, three_anhilation, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -435,8 +448,8 @@ BEGIN_PROVIDER [ double precision, three_anhilation, (n_act_orb,n_act_orb,n_act_ psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,1,i) = psi_active(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & @@ -446,7 +459,7 @@ BEGIN_PROVIDER [ double precision, three_anhilation, (n_act_orb,n_act_orb,n_act_ call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_anhilation(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo diff --git a/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f b/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f index 6ecffcce..f6b542bd 100644 --- a/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f +++ b/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f @@ -1,88 +1,88 @@ -BEGIN_PROVIDER [ double precision, one_creation_spin_averaged, (n_act_orb)] +BEGIN_PROVIDER [ double precision, one_creat_spin_trace, (n_act_orb)] implicit none integer :: i do i = 1, n_act_orb - one_creation_spin_averaged(i) = one_creation(i,1) + one_creation(i,2) - one_creation_spin_averaged(i) = 0.5d0 * one_creation_spin_averaged(i) + one_creat_spin_trace(i) = one_creat(i,1) + one_creat(i,2) + one_creat_spin_trace(i) = 0.5d0 * one_creat_spin_trace(i) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhilation_spin_averaged, (n_act_orb)] +BEGIN_PROVIDER [ double precision, one_anhil_spin_trace, (n_act_orb)] implicit none integer :: i do i = 1, n_act_orb - one_anhilation_spin_averaged(i) = one_anhilation(i,1) + one_anhilation(i,2) - one_anhilation_spin_averaged(i) = 0.5d0 * one_anhilation_spin_averaged(i) + one_anhil_spin_trace(i) = one_anhil(i,1) + one_anhil(i,2) + one_anhil_spin_trace(i) = 0.5d0 * one_anhil_spin_trace(i) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creation_spin_averaged, (n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, two_creat_spin_trace, (n_act_orb,n_act_orb)] implicit none integer :: i,j integer :: ispin,jspin double precision :: counting do i = 1, n_act_orb do j = 1, n_act_orb - two_creation_spin_averaged(j,i) = 0.d0 + two_creat_spin_trace(j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 - two_creation_spin_averaged(j,i) += two_creation(j,i,ispin,jspin) + two_creat_spin_trace(j,i) += two_creat(j,i,ispin,jspin) counting += 1.d0 enddo enddo - two_creation_spin_averaged(j,i) = two_creation_spin_averaged(j,i) / counting + two_creat_spin_trace(j,i) = two_creat_spin_trace(j,i) / counting enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhilation_spin_averaged, (n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, two_anhil_spin_trace, (n_act_orb,n_act_orb)] implicit none integer :: i,j integer :: ispin,jspin double precision :: counting do i = 1, n_act_orb do j = 1, n_act_orb - two_anhilation_spin_averaged(j,i) = 0.d0 + two_anhil_spin_trace(j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 - two_anhilation_spin_averaged(j,i) += two_anhilation(j,i,ispin,jspin) + two_anhil_spin_trace(j,i) += two_anhil(j,i,ispin,jspin) counting += 1.d0 enddo enddo - two_anhilation_spin_averaged(j,i) = two_anhilation_spin_averaged(j,i) / counting + two_anhil_spin_trace(j,i) = two_anhil_spin_trace(j,i) / counting enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhilation_one_creation_spin_averaged, (n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, one_anhil_one_creat_spin_trace, (n_act_orb,n_act_orb)] implicit none integer :: i,j integer :: ispin,jspin double precision :: counting do i = 1, n_act_orb do j = 1, n_act_orb - one_anhilation_one_creation_spin_averaged(j,i) = 0.d0 + one_anhil_one_creat_spin_trace(j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 - one_anhilation_one_creation_spin_averaged(j,i) += one_anhilation_one_creation(j,i,jspin,ispin) + one_anhil_one_creat_spin_trace(j,i) += one_anhil_one_creat(j,i,jspin,ispin) counting += 1.d0 enddo enddo - one_anhilation_one_creation_spin_averaged(j,i) = one_anhilation_one_creation_spin_averaged(j,i) / counting + one_anhil_one_creat_spin_trace(j,i) = one_anhil_one_creat_spin_trace(j,i) / counting enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhilation_one_creation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, two_anhil_one_creat_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] implicit none integer :: i,j,k integer :: ispin,jspin,kspin @@ -91,16 +91,16 @@ BEGIN_PROVIDER [ double precision, two_anhilation_one_creation_spin_averaged, (n do i = 1, n_act_orb do j = 1, n_act_orb do k = 1, n_act_orb - two_anhilation_one_creation_spin_averaged(k,j,i) = 0.d0 + two_anhil_one_creat_spin_trace(k,j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 do kspin = 1,2 - two_anhilation_one_creation_spin_averaged(k,j,i) += two_anhilation_one_creation(k,j,i,kspin,jspin,ispin) + two_anhil_one_creat_spin_trace(k,j,i) += two_anhil_one_creat(k,j,i,kspin,jspin,ispin) counting += 1.d0 enddo enddo - two_anhilation_one_creation_spin_averaged(k,j,i) = two_anhilation_one_creation_spin_averaged(k,j,i) / counting + two_anhil_one_creat_spin_trace(k,j,i) = two_anhil_one_creat_spin_trace(k,j,i) / counting enddo enddo enddo @@ -108,7 +108,7 @@ BEGIN_PROVIDER [ double precision, two_anhilation_one_creation_spin_averaged, (n END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creation_one_anhilation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] implicit none integer :: i,j,k integer :: ispin,jspin,kspin @@ -117,16 +117,16 @@ BEGIN_PROVIDER [ double precision, two_creation_one_anhilation_spin_averaged, (n do i = 1, n_act_orb do j = 1, n_act_orb do k = 1, n_act_orb - two_creation_one_anhilation_spin_averaged(k,j,i) = 0.d0 + two_creat_one_anhil_spin_trace(k,j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 do kspin = 1,2 - two_creation_one_anhilation_spin_averaged(k,j,i) += two_creation_one_anhilation(k,j,i,kspin,jspin,ispin) + two_creat_one_anhil_spin_trace(k,j,i) += two_creat_one_anhil(k,j,i,kspin,jspin,ispin) counting += 1.d0 enddo enddo - two_creation_one_anhilation_spin_averaged(k,j,i) = two_creation_one_anhilation_spin_averaged(k,j,i) / counting + two_creat_one_anhil_spin_trace(k,j,i) = two_creat_one_anhil_spin_trace(k,j,i) / counting enddo enddo enddo @@ -135,7 +135,7 @@ BEGIN_PROVIDER [ double precision, two_creation_one_anhilation_spin_averaged, (n END_PROVIDER -BEGIN_PROVIDER [ double precision, three_creation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, three_creat_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] implicit none integer :: i,j,k integer :: ispin,jspin,kspin @@ -144,16 +144,16 @@ BEGIN_PROVIDER [ double precision, three_creation_spin_averaged, (n_act_orb,n_ac do i = 1, n_act_orb do j = 1, n_act_orb do k = 1, n_act_orb - three_creation_spin_averaged(k,j,i) = 0.d0 + three_creat_spin_trace(k,j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 do kspin = 1,2 - three_creation_spin_averaged(k,j,i) += three_creation(k,j,i,kspin,jspin,ispin) + three_creat_spin_trace(k,j,i) += three_creat(k,j,i,kspin,jspin,ispin) counting += 1.d0 enddo enddo - three_creation_spin_averaged(k,j,i) = three_creation_spin_averaged(k,j,i) / counting + three_creat_spin_trace(k,j,i) = three_creat_spin_trace(k,j,i) / counting enddo enddo enddo @@ -162,7 +162,7 @@ BEGIN_PROVIDER [ double precision, three_creation_spin_averaged, (n_act_orb,n_ac END_PROVIDER -BEGIN_PROVIDER [ double precision, three_anhilation_spin_averaged, (n_act_orb,n_act_orb,n_act_orb)] +BEGIN_PROVIDER [ double precision, three_anhil_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] implicit none integer :: i,j,k integer :: ispin,jspin,kspin @@ -171,16 +171,16 @@ BEGIN_PROVIDER [ double precision, three_anhilation_spin_averaged, (n_act_orb,n_ do i = 1, n_act_orb do j = 1, n_act_orb do k = 1, n_act_orb - three_anhilation_spin_averaged(k,j,i) = 0.d0 + three_anhil_spin_trace(k,j,i) = 0.d0 counting = 0.d0 do ispin = 1, 2 do jspin = 1,2 do kspin = 1,2 - three_anhilation_spin_averaged(k,j,i) += three_anhilation(k,j,i,kspin,jspin,ispin) + three_anhil_spin_trace(k,j,i) += three_anhil(k,j,i,kspin,jspin,ispin) counting += 1.d0 enddo enddo - three_anhilation_spin_averaged(k,j,i) = three_anhilation_spin_averaged(k,j,i) / counting + three_anhil_spin_trace(k,j,i) = three_anhil_spin_trace(k,j,i) / counting enddo enddo enddo diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index c7e21d0c..bb561455 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -40,7 +40,7 @@ accu += 2.d0 * mo_bielec_integral_jj(i_virt_orb,j_inact_core_orb) & - mo_bielec_integral_jj_exchange(i_virt_orb,j_inact_core_orb) enddo - fock_virt_from_core_inact(i_virt_orb) = accu + mo_mono_elec_integral(i_virt_orb,i_virt_orb) + fock_virt_from_core_inact(i_virt_orb) = accu enddo END_PROVIDER @@ -49,11 +49,12 @@ ! inactive part of the fock operator with contributions only from the active END_DOC implicit none - integer :: i,j + integer :: i,j,k double precision :: accu_coulomb,accu_exchange(2) double precision :: na,nb,ntot double precision :: coulomb, exchange - integer :: j_act_orb,i_inact_core_orb + double precision :: get_mo_bielec_integral_schwartz + integer :: j_act_orb,k_act_orb,i_inact_core_orb do i = 1, n_core_inact_orb accu_coulomb = 0.d0 @@ -69,6 +70,17 @@ accu_coulomb += ntot * coulomb accu_exchange(1) += na * exchange accu_exchange(2) += nb * exchange + do k = j+1, n_act_orb + k_act_orb = list_act(k) + na = one_body_dm_mo_alpha(j_act_orb,k_act_orb) + nb = one_body_dm_mo_beta(j_act_orb,k_act_orb) + ntot = na + nb + coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) + exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) + accu_coulomb += 2.d0 * ntot * coulomb + accu_exchange(1) += 2.d0 * na * exchange + accu_exchange(2) += 2.d0 * nb * exchange + enddo enddo fock_core_inactive_from_act(i_inact_core_orb,1) = accu_coulomb + accu_exchange(1) fock_core_inactive_from_act(i_inact_core_orb,2) = accu_coulomb + accu_exchange(2) @@ -80,11 +92,12 @@ ! virtual part of the fock operator with contributions only from the active END_DOC implicit none - integer :: i,j + integer :: i,j,k double precision :: accu_coulomb,accu_exchange(2) double precision :: na,nb,ntot double precision :: coulomb, exchange - integer :: j_act_orb,i_virt_orb + double precision :: get_mo_bielec_integral_schwartz + integer :: j_act_orb,i_virt_orb,k_act_orb do i = 1, n_virt_orb accu_coulomb = 0.d0 @@ -100,14 +113,26 @@ accu_coulomb += ntot * coulomb accu_exchange(1) += na * exchange accu_exchange(2) += nb * exchange + do k = j+1, n_act_orb + k_act_orb = list_act(k) + na = one_body_dm_mo_alpha(j_act_orb,k_act_orb) + nb = one_body_dm_mo_beta(j_act_orb,k_act_orb) + ntot = na + nb + coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) + exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) + accu_coulomb += 2.d0 * ntot * coulomb + accu_exchange(1) += 2.d0 * na * exchange + accu_exchange(2) += 2.d0 * nb * exchange + enddo enddo fock_virt_from_act(i_virt_orb,1) = accu_coulomb + accu_exchange(1) fock_virt_from_act(i_virt_orb,2) = accu_coulomb + accu_exchange(2) + print*, fock_virt_from_act(i_virt_orb,1) , fock_virt_from_act(i_virt_orb,2) enddo END_PROVIDER BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2)] -&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_averaged, (mo_tot_num)] +&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num)] BEGIN_DOC ! inactive part of the fock operator END_DOC @@ -118,12 +143,12 @@ i_inact_core_orb = list_core_inact(i) fock_core_inactive_total(i_inact_core_orb,1) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1) fock_core_inactive_total(i_inact_core_orb,2) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2) - fock_core_inactive_total_spin_averaged(i_inact_core_orb) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1) + fock_core_inactive_total(i_inact_core_orb,2)) + fock_core_inactive_total_spin_trace(i_inact_core_orb) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1) + fock_core_inactive_total(i_inact_core_orb,2)) enddo END_PROVIDER BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2)] -&BEGIN_PROVIDER [double precision, fock_virt_total_spin_averaged, (mo_tot_num)] +&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num)] BEGIN_DOC ! inactive part of the fock operator END_DOC @@ -132,9 +157,10 @@ integer :: i_virt_orb do i = 1, n_virt_orb i_virt_orb= list_virt(i) - fock_virt_total(i_virt_orb,1) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1) - fock_virt_total(i_virt_orb,2) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2) - fock_virt_total_spin_averaged(i_virt_orb) = 0.5d0 * ( fock_virt_total(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) ) + fock_virt_total(i_virt_orb,1) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) + fock_virt_total(i_virt_orb,2) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) + fock_virt_total_spin_trace(i_virt_orb) = 0.5d0 * ( fock_virt_total(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) ) + print*, fock_virt_total_spin_trace(i_virt_orb) enddo END_PROVIDER @@ -142,24 +168,29 @@ - BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, fock_operator_active_from_core_inact, (mo_tot_num,mo_tot_num)] BEGIN_DOC ! active part of the fock operator with contributions only from the inactive END_DOC implicit none - integer :: i,j,k + integer :: i,j,k,k_inact_core_orb + integer :: iorb,jorb double precision :: accu double precision :: get_mo_bielec_integral,coulomb, exchange PROVIDE mo_bielec_integrals_in_map + fock_operator_active_from_core_inact = 0.d0 do i = 1, n_act_orb + iorb = list_act(i) do j = 1, n_act_orb + jorb = list_act(j) accu = 0.d0 do k = 1, n_core_inact_orb - coulomb = get_mo_bielec_integral(k,i,k,j,mo_integrals_map) - exchange = get_mo_bielec_integral(k,i,i,k,mo_integrals_map) + k_inact_core_orb = list_core_inact(k) + coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) + exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) accu += 2.d0 * coulomb - exchange enddo - fock_operator_active_from_core_inact(i,j) = accu + fock_operator_active_from_core_inact(iorb,jorb) = accu enddo enddo diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index e5848814..e6865bd8 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -7,6 +7,7 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] implicit none use bitmasks integer :: i,j,k,l + provide cas_bitmask do i = 1, N_det do j = 1, N_int psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) @@ -138,8 +139,8 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti call give_virt_part_determinant(det_1,det_tmp_1) do i = 1, N_int - particles(i,1) = iand(virt_bitmask(i,1),xor(det_tmp_1(i,1),virt_bitmask(i,1))) - particles(i,2) = iand(virt_bitmask(i,2),xor(det_tmp_1(i,2),virt_bitmask(i,2))) + particles(i,1) = iand(virt_bitmask(i,1),det_tmp_1(i,1)) + particles(i,2) = iand(virt_bitmask(i,2),det_tmp_1(i,2)) enddo particles_list = 0 @@ -169,12 +170,12 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) delta_e_inactive = 0.d0 do i = 1, n_holes_spin(1) i_hole_inact = holes_list(i,1) - delta_e_inactive += fock_core_inactive_total_spin_averaged(i_hole_inact) + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) enddo do i = 1, n_holes_spin(2) i_hole_inact = holes_list(i,2) - delta_e_inactive += fock_core_inactive_total_spin_averaged(i_hole_inact) + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) enddo double precision :: delta_e_virt @@ -187,7 +188,12 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) delta_e_virt = 0.d0 do i = 1, n_particles_spin(1) i_part_virt = particles_list(i,1) - delta_e_virt += fock_virt_total_spin_averaged(i_part_virt) + delta_e_virt += fock_virt_total_spin_trace(i_part_virt) + enddo + + do i = 1, n_particles_spin(2) + i_part_virt = particles_list(i,2) + delta_e_virt += fock_virt_total_spin_trace(i_part_virt) enddo @@ -201,31 +207,49 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) delta_e_act = 0.d0 call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & n_holes_act,n_particles_act,holes_active_list,particles_active_list) - integer :: icount + integer :: icount,icountbis + integer :: hole_list_practical(2,elec_num_tab(1)), particle_list_practical(2,elec_num_tab(1)) icount = 0 + icountbis = 0 do i = 1, n_holes_spin_act(1) icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 1 + hole_list_practical(2,icountbis) = holes_active_list(i,1) holes_active_list_spin_traced(icount) = holes_active_list(i,1) enddo do i = 1, n_holes_spin_act(2) icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 2 + hole_list_practical(2,icountbis) = holes_active_list(i,2) holes_active_list_spin_traced(icount) = holes_active_list(i,2) enddo - if(icount .ne. n_holes) then + if(icount .ne. n_holes_act) then + print*,'' + print*, icount, n_holes_act print * , 'pb in holes_active_list_spin_traced !!' stop endif icount = 0 + icountbis = 0 do i = 1, n_particles_spin_act(1) icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 1 + particle_list_practical(2,icountbis) = particles_active_list(i,1) particles_active_list_spin_traced(icount) = particles_active_list(i,1) enddo do i = 1, n_particles_spin_act(2) icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 2 + particle_list_practical(2,icountbis) = particles_active_list(i,2) particles_active_list_spin_traced(icount) = particles_active_list(i,2) enddo - if(icount .ne. n_particles) then + if(icount .ne. n_particles_act) then + print*, icount, n_particles_act print * , 'pb in particles_active_list_spin_traced !!' stop endif @@ -235,45 +259,148 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) integer :: i_particle_act, j_particle_act, k_particle_act - if (n_holes_act == 1 .and. n_particles_act == 0) then - i_hole_act = holes_active_list_spin_traced(1) - delta_e_act += one_creation_spin_averaged(i_hole_act) + integer :: ispin,jspin,kspin + if (n_holes_act == 0 .and. n_particles_act == 1) then +! i_particle_act = particles_active_list_spin_traced(1) +! delta_e_act += one_creat_spin_trace(i_particle_act ) + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += one_creat(i_particle_act,ispin) - else if (n_holes_act == 0 .and. n_particles_act == 1) then - i_particle_act = particles_active_list_spin_traced(1) - delta_e_act += one_anhilation_spin_averaged(i_particle_act) + else if (n_holes_act == 1 .and. n_particles_act == 0) then +! i_hole_act = holes_active_list_spin_traced(1) +! delta_e_act += one_anhil_spin_trace(i_hole_act ) + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + delta_e_act += one_anhil(i_hole_act , ispin) else if (n_holes_act == 1 .and. n_particles_act == 1) then - i_hole_act = holes_active_list_spin_traced(1) - i_particle_act = particles_active_list_spin_traced(1) - delta_e_act += one_anhilation_one_creation_spin_averaged(i_hole_act,i_particle_act) +! i_hole_act = holes_active_list_spin_traced(1) +! i_particle_act = particles_active_list_spin_traced(1) +! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act) + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin) + + else if (n_holes_act == 2 .and. n_particles_act == 0) then +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(1) +! delta_e_act += two_anhil_spin_trace(i_hole_act,j_hole_act) + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + delta_e_act += two_anhil(i_hole_act,j_hole_act,ispin,jspin) + + else if (n_holes_act == 0 .and. n_particles_act == 2) then +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! delta_e_act += two_creat_spin_trace(i_particle_act,j_particle_act) + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + delta_e_act += two_creat(i_particle_act,j_particle_act,ispin,jspin) else if (n_holes_act == 2 .and. n_particles_act == 1) then - i_hole_act = holes_active_list_spin_traced(1) - j_hole_act = holes_active_list_spin_traced(2) - i_particle_act = particles_active_list_spin_traced(1) - delta_e_act += two_anhilation_one_creation_spin_averaged(i_hole_act,j_hole_act,i_particle_act) +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(2) +! i_particle_act = particles_active_list_spin_traced(1) +! print*, 'i_hole_act,j_hole_act,i_particle_act' +! print*, i_hole_act,j_hole_act,i_particle_act +! print*, two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) +! delta_e_act += two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! first particle + kspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin) else if (n_holes_act == 1 .and. n_particles_act == 2) then - i_hole_act = holes_active_list_spin_traced(1) - i_particle_act = particles_active_list_spin_traced(1) - j_particle_act = particles_active_list_spin_traced(2) - delta_e_act += two_creation_one_anhilation_spin_averaged(i_hole_act,i_particle_act,j_particle_act) +! i_hole_act = holes_active_list_spin_traced(1) +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! delta_e_act += two_creat_one_anhil_spin_trace(i_hole_act,i_particle_act,j_particle_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! second particle + kspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + + delta_e_act += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin) else if (n_holes_act == 3 .and. n_particles_act == 0) then - i_hole_act = holes_active_list_spin_traced(1) - j_hole_act = holes_active_list_spin_traced(2) - k_hole_act = holes_active_list_spin_traced(3) - delta_e_act += three_anhilation_spin_averaged(i_hole_act,j_hole_act,k_hole_act) +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(2) +! k_hole_act = holes_active_list_spin_traced(3) +! delta_e_act += three_anhil_spin_trace(i_hole_act,j_hole_act,k_hole_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! third hole + kspin = hole_list_practical(1,3) + k_hole_act = hole_list_practical(2,3) + delta_e_act += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin) else if (n_holes_act == 0 .and. n_particles_act == 3) then - i_particle_act = particles_active_list_spin_traced(1) - j_particle_act = particles_active_list_spin_traced(2) - k_particle_act = particles_active_list_spin_traced(3) - delta_e_act += three_creation_spin_averaged(i_particle_act,j_particle_act,k_particle_act) +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! k_particle_act = particles_active_list_spin_traced(3) +! delta_e_act += three_creat_spin_trace(i_particle_act,j_particle_act,k_particle_act) + ! first particle + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! second particle + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + ! second particle + kspin = particle_list_practical(1,3) + k_particle_act = particle_list_practical(2,3) + + delta_e_act += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin) endif - delta_e_final = delta_e_act + delta_e_virt + delta_e_inactive +!print*, 'one_anhil_spin_trace' +!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) + + + delta_e_final = delta_e_act + delta_e_inactive - delta_e_virt + if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0)then + call debug_det(det_1,N_int) + call debug_det(det_2,N_int) + print*, 'n_holes_act,n_particles_act' + print*, n_holes_act,n_particles_act + print*, 'delta_e_act,delta_e_inactive,delta_e_vir' + print*, delta_e_act,delta_e_inactive,delta_e_virt + stop + + endif + + + +!if(delta_e_final > 0.d0)then +!print*, delta_e_final +!stop +!endif end diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index e29a6721..6a9bca47 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Properties Hartree_Fock +Determinants Properties Hartree_Fock MRPT_Utils diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 0086c67e..2621a9c6 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -45,6 +45,36 @@ subroutine pt2_epstein_nesbet ($arguments) end + +subroutine pt2_decontracted ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock, h + double precision :: i_H_psi_array(N_st) + double precision :: coef_pert + PROVIDE selection_criterion + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) + + + c_pert(1) = coef_pert + e_2_pert(1) = coef_pert * i_H_psi_array(1) +! print*,coef_pert,i_H_psi_array(1) + +end + + + + subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none @@ -68,8 +98,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) ASSERT (Nint > 0) PROVIDE CI_electronic_energy - !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) do i =1,N_st @@ -86,12 +116,29 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) c_pert(i) = 0.d0 endif H_pert_diag(i) = h*c_pert(i)*c_pert(i) +! print*, 'N_det,N_det_selectors = ',N_det,N_det_selectors +! print*, 'threshold_selectors',threshold_selectors +! print*, delta_e,i_H_psi_array(1) +! double precision :: hij,accu +! accu = 0.d0 +! do j = 1, N_det +! call i_H_j(det_pert,psi_selectors(1,1,j),N_int,hij) +! print*, 'psi_selectors_coef(j,1 = ',psi_selectors_coef(j,1),psi_coef(j,1) +! call debug_det(psi_det(1,1,i),N_int) +! call debug_det(psi_selectors(1,1,i),N_int) +! accu += psi_selectors_coef(j,1) * hij +! enddo +! print*, 'accu,ihpsi0',accu,i_H_psi_array(1) +! stop else e_2_pert(i) = 0.d0 c_pert(i) = 0.d0 H_pert_diag(i) = 0.d0 endif enddo +! if( e_2_pert(1) .ne. 0.d0)then +! print*,' e_2_pert(1) ', e_2_pert(1) +! endif end diff --git a/plugins/Selectors_full/e_corr_selectors.irp.f b/plugins/Selectors_full/e_corr_selectors.irp.f index 952e1c23..fec480f0 100644 --- a/plugins/Selectors_full/e_corr_selectors.irp.f +++ b/plugins/Selectors_full/e_corr_selectors.irp.f @@ -56,7 +56,7 @@ END_PROVIDER i_H_HF_per_selectors(i) = hij E_corr_per_selectors(i) = psi_selectors_coef(i,1) * hij E_corr_double_only += E_corr_per_selectors(i) - E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) +! E_corr_second_order += hij * hij /(ref_bitmask_energy - diag_H_mat_elem(psi_selectors(1,1,i),N_int)) elseif(exc_degree_per_selectors(i) == 0)then coef_hf_selector = psi_selectors_coef(i,1) E_corr_per_selectors(i) = -1000.d0 diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index 826dcc4b..71c3550e 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -18,8 +18,10 @@ BEGIN_PROVIDER [ integer, N_det_selectors] N_det_selectors = N_det do i=1,N_det norm = norm + psi_average_norm_contrib_sorted(i) + if (norm > threshold_selectors) then - N_det_selectors = i-1 +! N_det_selectors = i-1 + N_det_selectors = i exit endif enddo diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ec786941..735ca8e7 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1076,6 +1076,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max, end + subroutine i_H_psi_sec_ord(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,idx_interaction,interactions) use bitmasks implicit none diff --git a/src/Determinants/test_3d.irp.f b/src/Determinants/test_3d.irp.f index 748890da..a5d09cd3 100644 --- a/src/Determinants/test_3d.irp.f +++ b/src/Determinants/test_3d.irp.f @@ -2,14 +2,14 @@ program test_3d implicit none integer :: i,npt double precision :: dx,domain,x_min,x,step_function_becke - domain = 5.d0 - npt = 100 - dx = domain/dble(npt) - x_min = -0.5d0 * domain - x = x_min - do i = 1, npt - write(33,*)x,step_function_becke(x) - x += dx - enddo +!domain = 5.d0 +!npt = 100 +!dx = domain/dble(npt) +!x_min = -0.5d0 * domain +!x = x_min +!do i = 1, npt +! write(33,*)x,step_function_becke(x) +! x += dx +!enddo end From 35e4e5fde3fb2a09fa89216079fd576cae67a689 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 26 Aug 2016 18:01:41 +0200 Subject: [PATCH 09/32] forgot the pt2_new.irp.f --- plugins/Perturbation/pt2_new.irp.f | 71 ++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 plugins/Perturbation/pt2_new.irp.f diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f new file mode 100644 index 00000000..a991e483 --- /dev/null +++ b/plugins/Perturbation/pt2_new.irp.f @@ -0,0 +1,71 @@ +subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array,coef_pert) + use bitmasks + implicit none + integer, intent(in) :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist + integer(bit_kind), intent(in) :: keys(Nint,2,Ndet) + integer(bit_kind), intent(in) :: key(Nint,2) + double precision, intent(in) :: coef(Ndet_max,Nstate) + double precision, intent(out) :: i_H_psi_array(Nstate) + double precision, intent(out) :: coef_pert + + integer :: idx(0:Ndet) + + integer :: i, ii,j, i_in_key, i_in_coef + double precision :: phase + integer :: exc(0:2,2,2) + double precision :: hij + double precision :: delta_e_final + double precision :: hjj + BEGIN_DOC +! Computes = \sum_J c_J . +! +! Uses filter_connected_i_H_psi0 to get all the |J> to which |i> +! is connected. The |J> are searched in short pre-computed lists. + END_DOC + + ASSERT (Nint > 0) + ASSERT (N_int == Nint) + ASSERT (Nstate > 0) + ASSERT (Ndet > 0) + ASSERT (Ndet_max >= Ndet) + i_H_psi_array = 0.d0 + coef_pert = 0.d0 + + call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) + if (Nstate == 1) then + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij + call get_delta_e_dyall(keys(1,1,i_in_key),key,delta_e_final) + + coef_pert += coef(i_in_coef,1)*hij / delta_e_final +! print*, 'delta_e_final = ',delta_e_final + +! call i_H_j(key,key,Nint,hjj) +! coef_pert += coef(i_in_coef,1)*hij / (CI_electronic_energy(1) - hjj) + enddo + if (coef_pert * i_H_psi_array(1) > 0.d0)then + print*, coef_pert * i_H_psi_array(1) + endif + + else + + do ii=1,idx(0) + i_in_key = idx(ii) + i_in_coef = idx_key(idx(ii)) + !DIR$ FORCEINLINE + call i_H_j(keys(1,1,i_in_key),key,Nint,hij) + i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij + do j = 1, Nstate + i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij + enddo + enddo + + endif + +end + From 3f11982d10d6a314bb3dfa9c8eb28ab9aeb85c01 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 26 Aug 2016 20:06:43 +0200 Subject: [PATCH 10/32] minor bug fixed in new mrpt2 --- config/ifort.cfg | 2 +- plugins/Full_CI/full_ci_no_skip.irp.f | 2 - plugins/MRPT_Utils/psi_active_prov.irp.f | 270 ++++++++++++++++++++++- plugins/Perturbation/pt2_new.irp.f | 6 + 4 files changed, 265 insertions(+), 15 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index a738a83c..da414912 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/Full_CI/full_ci_no_skip.irp.f b/plugins/Full_CI/full_ci_no_skip.irp.f index 82cc9b79..3ed304a1 100644 --- a/plugins/Full_CI/full_ci_no_skip.irp.f +++ b/plugins/Full_CI/full_ci_no_skip.irp.f @@ -74,8 +74,6 @@ program full_ci if(do_pt2_end)then print*,'Last iteration only to compute the PT2' ! print*,'The thres' - threshold_selectors = 1.d0 - threshold_generators = 0.999d0 call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index e6865bd8..02d11244 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -208,7 +208,261 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & n_holes_act,n_particles_act,holes_active_list,particles_active_list) integer :: icount,icountbis - integer :: hole_list_practical(2,elec_num_tab(1)), particle_list_practical(2,elec_num_tab(1)) + integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) + icount = 0 + icountbis = 0 + do i = 1, n_holes_spin_act(1) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 1 + hole_list_practical(2,icountbis) = holes_active_list(i,1) + holes_active_list_spin_traced(icount) = holes_active_list(i,1) + enddo + do i = 1, n_holes_spin_act(2) + icount += 1 + icountbis += 1 + hole_list_practical(1,icountbis) = 2 + hole_list_practical(2,icountbis) = holes_active_list(i,2) + holes_active_list_spin_traced(icount) = holes_active_list(i,2) + enddo + if(icount .ne. n_holes_act) then + print*,'' + print*, icount, n_holes_act + print * , 'pb in holes_active_list_spin_traced !!' + stop + endif + + icount = 0 + icountbis = 0 + do i = 1, n_particles_spin_act(1) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 1 + particle_list_practical(2,icountbis) = particles_active_list(i,1) + particles_active_list_spin_traced(icount) = particles_active_list(i,1) + enddo + do i = 1, n_particles_spin_act(2) + icount += 1 + icountbis += 1 + particle_list_practical(1,icountbis) = 2 + particle_list_practical(2,icountbis) = particles_active_list(i,2) + particles_active_list_spin_traced(icount) = particles_active_list(i,2) + enddo + if(icount .ne. n_particles_act) then + print*, icount, n_particles_act + print * , 'pb in particles_active_list_spin_traced !!' + stop + endif + + + integer :: i_hole_act, j_hole_act, k_hole_act + integer :: i_particle_act, j_particle_act, k_particle_act + + + integer :: ispin,jspin,kspin + if (n_holes_act == 0 .and. n_particles_act == 1) then +! i_particle_act = particles_active_list_spin_traced(1) +! delta_e_act += one_creat_spin_trace(i_particle_act ) + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += one_creat(i_particle_act,ispin) + + else if (n_holes_act == 1 .and. n_particles_act == 0) then +! i_hole_act = holes_active_list_spin_traced(1) +! delta_e_act += one_anhil_spin_trace(i_hole_act ) + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + delta_e_act += one_anhil(i_hole_act , ispin) + + else if (n_holes_act == 1 .and. n_particles_act == 1) then +! i_hole_act = holes_active_list_spin_traced(1) +! i_particle_act = particles_active_list_spin_traced(1) +! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act) + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin) + + else if (n_holes_act == 2 .and. n_particles_act == 0) then +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(1) +! delta_e_act += two_anhil_spin_trace(i_hole_act,j_hole_act) + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + delta_e_act += two_anhil(i_hole_act,j_hole_act,ispin,jspin) + + else if (n_holes_act == 0 .and. n_particles_act == 2) then +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! delta_e_act += two_creat_spin_trace(i_particle_act,j_particle_act) + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + delta_e_act += two_creat(i_particle_act,j_particle_act,ispin,jspin) + + else if (n_holes_act == 2 .and. n_particles_act == 1) then +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(2) +! i_particle_act = particles_active_list_spin_traced(1) +! print*, 'i_hole_act,j_hole_act,i_particle_act' +! print*, i_hole_act,j_hole_act,i_particle_act +! print*, two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) +! delta_e_act += two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! first particle + kspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + delta_e_act += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin) + + else if (n_holes_act == 1 .and. n_particles_act == 2) then +! i_hole_act = holes_active_list_spin_traced(1) +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! delta_e_act += two_creat_one_anhil_spin_trace(i_hole_act,i_particle_act,j_particle_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! first particle + jspin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! second particle + kspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + + delta_e_act += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin) + + else if (n_holes_act == 3 .and. n_particles_act == 0) then +! i_hole_act = holes_active_list_spin_traced(1) +! j_hole_act = holes_active_list_spin_traced(2) +! k_hole_act = holes_active_list_spin_traced(3) +! delta_e_act += three_anhil_spin_trace(i_hole_act,j_hole_act,k_hole_act) + + ! first hole + ispin = hole_list_practical(1,1) + i_hole_act = hole_list_practical(2,1) + ! second hole + jspin = hole_list_practical(1,2) + j_hole_act = hole_list_practical(2,2) + ! third hole + kspin = hole_list_practical(1,3) + k_hole_act = hole_list_practical(2,3) + delta_e_act += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin) + + else if (n_holes_act == 0 .and. n_particles_act == 3) then +! i_particle_act = particles_active_list_spin_traced(1) +! j_particle_act = particles_active_list_spin_traced(2) +! k_particle_act = particles_active_list_spin_traced(3) +! delta_e_act += three_creat_spin_trace(i_particle_act,j_particle_act,k_particle_act) + ! first particle + ispin = particle_list_practical(1,1) + i_particle_act = particle_list_practical(2,1) + ! second particle + jspin = particle_list_practical(1,2) + j_particle_act = particle_list_practical(2,2) + ! second particle + kspin = particle_list_practical(1,3) + k_particle_act = particle_list_practical(2,3) + + delta_e_act += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin) + + else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then + + delta_e_act = -10000000.d0 + + endif + +!print*, 'one_anhil_spin_trace' +!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) + + + delta_e_final = delta_e_act + delta_e_inactive - delta_e_virt +!if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0 .or. delta_e_final == 0.d0)then +!if(delta_e_final == 0.d0)then + if(.False.)then + call debug_det(det_1,N_int) + call debug_det(det_2,N_int) + print*, 'n_holes_act,n_particles_act' + print*, n_holes_act,n_particles_act + print*, 'delta_e_act,delta_e_inactive,delta_e_vir' + print*, delta_e_act,delta_e_inactive,delta_e_virt + delta_e_final = -1000.d0 +!stop + + endif + +end + +subroutine get_delta_e_dyall_verbose(det_1,det_2,delta_e_final) + implicit none + use bitmasks + double precision, intent(out) :: delta_e_final + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer :: i,j,k,l + + integer :: n_holes_spin(2) + integer :: n_holes + integer :: holes_list(N_int*bit_kind_size,2) + + + double precision :: delta_e_inactive + integer :: i_hole_inact + + call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) + delta_e_inactive = 0.d0 + do i = 1, n_holes_spin(1) + i_hole_inact = holes_list(i,1) + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) + enddo + + do i = 1, n_holes_spin(2) + i_hole_inact = holes_list(i,2) + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) + enddo + + double precision :: delta_e_virt + integer :: i_part_virt + integer :: n_particles_spin(2) + integer :: n_particles + integer :: particles_list(N_int*bit_kind_size,2) + + call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) + delta_e_virt = 0.d0 + do i = 1, n_particles_spin(1) + i_part_virt = particles_list(i,1) + delta_e_virt += fock_virt_total_spin_trace(i_part_virt) + enddo + + do i = 1, n_particles_spin(2) + i_part_virt = particles_list(i,2) + delta_e_virt += fock_virt_total_spin_trace(i_part_virt) + enddo + + + integer :: n_holes_spin_act(2),n_particles_spin_act(2) + integer :: n_holes_act,n_particles_act + integer :: holes_active_list(2*n_act_orb,2) + integer :: holes_active_list_spin_traced(4*n_act_orb) + integer :: particles_active_list(2*n_act_orb,2) + integer :: particles_active_list_spin_traced(4*n_act_orb) + double precision :: delta_e_act + delta_e_act = 0.d0 + call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & + n_holes_act,n_particles_act,holes_active_list,particles_active_list) + integer :: icount,icountbis + integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) icount = 0 icountbis = 0 do i = 1, n_holes_spin_act(1) @@ -385,22 +639,14 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) delta_e_final = delta_e_act + delta_e_inactive - delta_e_virt - if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0)then +!if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0 .or. delta_e_final == 0.d0)then +!if(delta_e_final == 0.d0)then call debug_det(det_1,N_int) call debug_det(det_2,N_int) print*, 'n_holes_act,n_particles_act' print*, n_holes_act,n_particles_act print*, 'delta_e_act,delta_e_inactive,delta_e_vir' print*, delta_e_act,delta_e_inactive,delta_e_virt - stop - - endif - - - -!if(delta_e_final > 0.d0)then -!print*, delta_e_final -!stop -!endif + delta_e_final = -1000.d0 end diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f index a991e483..29821a74 100644 --- a/plugins/Perturbation/pt2_new.irp.f +++ b/plugins/Perturbation/pt2_new.irp.f @@ -42,6 +42,12 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij call get_delta_e_dyall(keys(1,1,i_in_key),key,delta_e_final) + if(delta_e_final == 0.d0)then + call get_delta_e_dyall_verbose(keys(1,1,i_in_key),key,delta_e_final) + call debug_det(keys(1,1,i_in_key),N_int) + call debug_det(key,N_int) + stop + endif coef_pert += coef(i_in_coef,1)*hij / delta_e_final ! print*, 'delta_e_final = ',delta_e_final From 8aebbd02cce0c08a57afdc88a1ba7edbd00cf080 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 30 Aug 2016 14:10:52 +0200 Subject: [PATCH 11/32] New PT2 with dressed matrix is working on H2 --- plugins/MRPT_Utils/H_apply.irp.f | 26 ++ plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 9 +- plugins/MRPT_Utils/excitations_cas.irp.f | 390 ++++++++++++++++++++ plugins/MRPT_Utils/mrpt_dress.irp.f | 161 ++++++++ plugins/MRPT_Utils/mrpt_utils.irp.f | 22 ++ plugins/Properties/print_spin_density.irp.f | 6 +- src/Determinants/NEEDED_CHILDREN_MODULES | 2 +- src/MO_Basis/print_mo_in_space.irp.f | 2 +- 8 files changed, 611 insertions(+), 7 deletions(-) create mode 100644 plugins/MRPT_Utils/H_apply.irp.f create mode 100644 plugins/MRPT_Utils/excitations_cas.irp.f create mode 100644 plugins/MRPT_Utils/mrpt_dress.irp.f create mode 100644 plugins/MRPT_Utils/mrpt_utils.irp.f diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f new file mode 100644 index 00000000..18bfc86f --- /dev/null +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -0,0 +1,26 @@ +use bitmasks +BEGIN_SHELL [ /usr/bin/env python ] +from generate_h_apply import * + +s = H_apply("mrpt") +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + + +END_SHELL + diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index c8140f70..1e2fe8a8 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -11,8 +11,13 @@ end subroutine routine_3 implicit none !provide fock_virt_total_spin_trace - provide energy_cas_dyall - print*, 'nuclear_reuplsion = ',nuclear_repulsion + provide delta_ij + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', second_order_pt_new(1) + print *, 'E = ', CI_energy + print *, 'E+PT2 = ', CI_energy+second_order_pt_new(1) end diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f new file mode 100644 index 00000000..acd70e3e --- /dev/null +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -0,0 +1,390 @@ +subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_in_out,psi_in_out_coef, ndet,dim_psi_in,dim_psi_coef,N_states_in) + use bitmasks + implicit none + integer, intent(in) :: orb, hole_particle,spin_exc,N_states_in,ndet,dim_psi_in,dim_psi_coef + double precision, intent(out) :: norm_out(N_states_in) + integer(bit_kind), intent(inout) :: psi_in_out(N_int,2,dim_psi_in) + double precision, intent(inout) :: psi_in_out_coef(dim_psi_coef,N_states_in) + BEGIN_DOC + ! apply a contracted excitation to psi_in_out whose coefficients + ! are psi_in_out_coef + ! hole_particle = 1 ===> creation of an electron in psi_in_out + ! = -1 ===> annhilation of an electron in psi_in_out + ! orb ===> is the index of orbital where you want wether to create or + ! annhilate an electron + ! spin_exc ===> is the spin of the electron (1 == alpha) (2 == beta) + ! the wave function gets out normalized to unity + ! + ! norm_out is the sum of the squared of the coefficients + ! on which the excitation has been possible + END_DOC + + integer :: elec_num_tab_local(2) + elec_num_tab_local = 0 + do i = 1, ndet + if( psi_in_out_coef (i,1) .ne. 0.d0)then + do j = 1, N_int + elec_num_tab_local(1) += popcnt(psi_in_out(j,1,i)) + elec_num_tab_local(2) += popcnt(psi_in_out(j,2,i)) + enddo + exit + endif + enddo + integer :: i,j,accu_elec + if(hole_particle == 1)then + do i = 1, ndet + call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) + accu_elec = 0 + do j = 1, N_int + accu_elec += popcnt(psi_in_out(j,spin_exc,i)) + enddo + if(accu_elec .ne. elec_num_tab_local(spin_exc)+1)then + do j = 1, N_int + psi_in_out(j,1,i) = 0_bit_kind + psi_in_out(j,2,i) = 0_bit_kind + enddo + do j = 1, N_states_in + psi_in_out_coef(i,j) = 0.d0 + enddo + endif + enddo + else if (hole_particle == -1)then + do i = 1, ndet + call clear_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) + accu_elec = 0 + do j = 1, N_int + accu_elec += popcnt(psi_in_out(j,spin_exc,i)) + enddo + if(accu_elec .ne. elec_num_tab_local(spin_exc)-1)then + do j = 1, N_int + psi_in_out(j,1,i) = 0_bit_kind + psi_in_out(j,2,i) = 0_bit_kind + enddo + do j = 1, N_states_in + psi_in_out_coef(i,j) = 0.d0 + enddo + endif + enddo + endif + norm_out = 0.d0 + double precision :: norm_factor + do j = 1, N_states_in + do i = 1, ndet + norm_out(j) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + enddo + if(norm_out(j).le.1.d-10)then + norm_factor = 0.d0 + else + norm_factor = 1.d0/(dsqrt(norm_out(j))) + endif + do i = 1, ndet + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm_factor + enddo + enddo +end + + +double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer :: i, j, iorb, jorb + integer :: occ(Nint*bit_kind_size,2) + integer :: elec_num_tab_local(2) + + diag_H_mat_elem_no_elec_check = 0.d0 + call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) + call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) + ! alpha - alpha + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) + enddo + enddo + + ! beta - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(2) + jorb = occ(j,2) + diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) + enddo + enddo + + + ! alpha - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + +end + +subroutine a_operator_no_check(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + integer :: tmp(2) + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibclr(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + na = na-1 + + hjj = hjj - mo_mono_elec_integral(iorb,iorb) + + ! Same spin + do i=1,na + hjj = hjj - mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj = hjj - mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + +end + + +subroutine ac_operator_no_check(iorb,ispin,key,hjj,Nint,na,nb) + use bitmasks + implicit none + BEGIN_DOC + ! Needed for diag_H_mat_elem + END_DOC + integer, intent(in) :: iorb, ispin, Nint + integer, intent(inout) :: na, nb + integer(bit_kind), intent(inout) :: key(Nint,2) + double precision, intent(inout) :: hjj + + integer :: occ(Nint*bit_kind_size,2) + integer :: other_spin + integer :: k,l,i + + ASSERT (iorb > 0) + ASSERT (ispin > 0) + ASSERT (ispin < 3) + ASSERT (Nint > 0) + + integer :: tmp(2) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key, occ, tmp, Nint) + + k = ishft(iorb-1,-bit_kind_shift)+1 + ASSERT (k > 0) + l = iorb - ishft(k-1,bit_kind_shift)-1 + key(k,ispin) = ibset(key(k,ispin),l) + other_spin = iand(ispin,1)+1 + + hjj = hjj + mo_mono_elec_integral(iorb,iorb) + + print*,'na.nb = ',na,nb + ! Same spin + do i=1,na + hjj = hjj + mo_bielec_integral_jj_anti(occ(i,ispin),iorb) + enddo + + ! Opposite spin + do i=1,nb + hjj = hjj + mo_bielec_integral_jj(occ(i,other_spin),iorb) + enddo + na = na+1 +end + + +subroutine i_H_j_dyall(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_schwartz + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2 + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + hij = phase*get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) + + case (0) + hij = diag_H_mat_elem_no_elec_check(key_i,Nint) + end select +end + + +subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) + use bitmasks + implicit none + integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target + integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) + double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) + double precision, intent(out) :: energies(N_states_in) + + integer :: i,j + double precision :: hij,accu + energies = 0.d0 + accu = 0.d0 + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(ndet)) + + do i = 1, ndet + psi_coef_tmp(i) = psi_in_coef(i,state_target) + enddo + + double precision :: hij_bis + do i = 1, ndet + if(psi_coef_tmp(i)==0.d0)cycle + do j = 1, ndet + if(psi_coef_tmp(j)==0.d0)cycle + call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) +! call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij_bis) +! print*, hij_bis,hij + accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij + enddo + enddo + energies(state_target) = accu + deallocate(psi_coef_tmp) +end diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f new file mode 100644 index 00000000..f0b58d24 --- /dev/null +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -0,0 +1,161 @@ +use omp_lib +use bitmasks + +BEGIN_PROVIDER [ integer(omp_lock_kind), psi_ref_bis_lock, (psi_det_size) ] + implicit none + BEGIN_DOC + ! Locks on ref determinants to fill delta_ij + END_DOC + integer :: i + do i=1,psi_det_size + call omp_init_lock( psi_ref_bis_lock(i) ) + enddo + +END_PROVIDER + + +subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,iproc,key_mask) + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint, iproc + integer, intent(in) :: Ndet + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + double precision, intent(inout) :: delta_ij_(Ndet,Ndet,*) + + + integer :: i,j,k,l + integer :: idx_alpha(0:psi_det_size) + integer :: degree_alpha(psi_det_size) + logical :: fullMatch + + double precision :: delta_e_array(psi_det_size) + double precision :: hij_array(psi_det_size) + + integer(bit_kind) :: tq(Nint,2,n_selected) + integer :: N_tq + + double precision :: hialpha + integer :: i_state, i_alpha + + integer(bit_kind),allocatable :: miniList(:,:,:) + integer,allocatable :: idx_miniList(:) + integer :: N_miniList, leng + double precision :: delta_e_final,hij_tmp + integer :: index_i,index_j + + + leng = max(N_det_generators, N_det) + allocate(miniList(Nint, 2, leng), idx_miniList(leng)) + + !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) + call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) + + if(fullMatch) then + return + end if + + + call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + + if(N_tq > 0) then + call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) + end if + + + do i_alpha=1,N_tq + call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) + + do j=1,idx_alpha(0) + idx_alpha(j) = idx_miniList(idx_alpha(j)) + enddo + + do i = 1,idx_alpha(0) + index_i = idx_alpha(i) + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e_final) + call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + delta_e_array(index_i) = 1.d0/delta_e_final + hij_array(index_i) = hialpha + enddo + + do i=1,idx_alpha(0) + index_i = idx_alpha(i) + hij_tmp = hij_array(index_i) + call omp_set_lock( psi_ref_bis_lock(index_i) ) + do j = 1, idx_alpha(0) + index_j = idx_alpha(j) + do i_state=1,N_states + delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_array(index_j) + enddo + enddo + call omp_unset_lock( psi_ref_bis_lock(index_i)) + enddo + enddo + deallocate(miniList, idx_miniList) +end + + + + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] + gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) + gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) +END_PROVIDER + + +subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) + + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,m + logical :: is_in_wavefunction + integer :: degree(psi_det_size) + integer :: idx(0:psi_det_size) + logical :: good + + integer(bit_kind), intent(out) :: tq(Nint,2,n_selected) + integer, intent(out) :: N_tq + + + integer :: nt,ni + logical, external :: is_connected_to + + + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer,intent(in) :: N_miniList + + + + N_tq = 0 + + + i_loop : do i=1,N_selected + if(is_connected_to(det_buffer(1,1,i), miniList, Nint, N_miniList)) then + cycle + end if + + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then + N_tq += 1 + do k=1,N_int + tq(k,1,N_tq) = det_buffer(k,1,i) + tq(k,2,N_tq) = det_buffer(k,2,i) + enddo + endif + enddo i_loop +end + + + + + + + diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f new file mode 100644 index 00000000..38c33377 --- /dev/null +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -0,0 +1,22 @@ + + BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ] + implicit none + BEGIN_DOC + ! Dressing matrix in N_det basis + END_DOC + integer :: i,j,m + delta_ij = 0.d0 + call H_apply_mrpt(delta_ij,N_det) + double precision :: accu + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + write(*,'(1000(F16.10,x))')delta_ij(i,:,:) + enddo + print*, 'accu = ',accu + second_order_pt_new(1) = accu +END_PROVIDER + diff --git a/plugins/Properties/print_spin_density.irp.f b/plugins/Properties/print_spin_density.irp.f index 9daa6fb7..b9cbe4e8 100644 --- a/plugins/Properties/print_spin_density.irp.f +++ b/plugins/Properties/print_spin_density.irp.f @@ -14,7 +14,7 @@ subroutine routine double precision, allocatable :: aos_array(:) allocate(aos_array(ao_num)) r = 0.d0 - r(3) = z_min + r(1) = z_min do i = 1, N_z_pts call give_all_aos_at_r(r,aos_array) accu = 0.d0 @@ -28,8 +28,8 @@ subroutine routine accu_beta += one_body_dm_ao_beta(k,j) * tmp enddo enddo - r(3) += delta_z - write(33,'(100(f16.10,X))')r(3),accu,accu_alpha,accu_beta + r(1) += delta_z + write(33,'(100(f16.10,X))')r(1),accu,accu_alpha,accu_beta enddo diff --git a/src/Determinants/NEEDED_CHILDREN_MODULES b/src/Determinants/NEEDED_CHILDREN_MODULES index 5505ce78..566762ba 100644 --- a/src/Determinants/NEEDED_CHILDREN_MODULES +++ b/src/Determinants/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Integrals_Monoelec Integrals_Bielec \ No newline at end of file +Integrals_Monoelec Integrals_Bielec Hartree_Fock diff --git a/src/MO_Basis/print_mo_in_space.irp.f b/src/MO_Basis/print_mo_in_space.irp.f index 5a2bc297..a5a324ed 100644 --- a/src/MO_Basis/print_mo_in_space.irp.f +++ b/src/MO_Basis/print_mo_in_space.irp.f @@ -35,7 +35,7 @@ program pouet do j = 1, nx ! call give_all_aos_at_r(r,aos_array) call give_all_mos_at_r(r,mos_array) - write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(1)* mos_array(2) + write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(3), mos_array(17), mos_array(23) !write(36,'(100(F16.10,X))') r(1), mos_array(1), mos_array(2), mos_array(4) !write(37,'(100(F16.10,X))') r(1),mos_array(1) * mos_array(2), mos_array(4)*mos_array(2) ! if(val_max.le.aos_array(1) * aos_array(2) )then From 6ebeae0a1017fdd2188bb6fcd6a0e9966b06e5d9 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 30 Aug 2016 18:10:44 +0200 Subject: [PATCH 12/32] MRPT2 new with separated classes --- plugins/MRPT_Utils/H_apply.irp.f | 161 +++++++++ plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 2 + plugins/MRPT_Utils/fock_like_operators.irp.f | 2 - plugins/MRPT_Utils/mrpt_dress.irp.f | 5 + plugins/MRPT_Utils/mrpt_utils.irp.f | 305 +++++++++++++++- scripts/generate_h_apply.py | 55 ++- src/Bitmask/bitmask_cas_routines.irp.f | 345 +++++++++++-------- src/Determinants/H_apply.template.f | 16 + 8 files changed, 729 insertions(+), 162 deletions(-) diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index 18bfc86f..6f17ab05 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -21,6 +21,167 @@ s.data["generate_psi_guess"] = "" s.data["size_max"] = "3072" print s +s = H_apply("mrpt_1h") +s.filter_only_1h() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_1p") +s.filter_only_1p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_1h1p") +s.filter_only_1h1p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_2p") +s.filter_only_2p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_2h") +s.filter_only_2h() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + + +s = H_apply("mrpt_1h2p") +s.filter_only_1h2p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_2h1p") +s.filter_only_2h1p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + +s = H_apply("mrpt_2h2p") +s.filter_only_2h2p() +s.data["parameters"] = ", delta_ij_, Ndet" +s.data["declarations"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["keys_work"] = "call mrpt_dress(delta_ij_,Ndet,i_generator,key_idx,keys_out,N_int,iproc,key_mask)" +s.data["params_post"] += ", delta_ij_, Ndet" +s.data["params_main"] += "delta_ij_, Ndet" +s.data["decls_main"] += """ + integer, intent(in) :: Ndet + double precision, intent(in) :: delta_ij_(Ndet,Ndet,*) +""" +s.data["finalization"] = "" +s.data["copy_buffer"] = "" +s.data["generate_psi_guess"] = "" +s.data["size_max"] = "3072" +print s + END_SHELL diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index 1e2fe8a8..7e4aa80b 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -18,6 +18,8 @@ subroutine routine_3 print *, 'PT2 = ', second_order_pt_new(1) print *, 'E = ', CI_energy print *, 'E+PT2 = ', CI_energy+second_order_pt_new(1) + print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' + print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) end diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index bb561455..44c16da6 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -127,7 +127,6 @@ enddo fock_virt_from_act(i_virt_orb,1) = accu_coulomb + accu_exchange(1) fock_virt_from_act(i_virt_orb,2) = accu_coulomb + accu_exchange(2) - print*, fock_virt_from_act(i_virt_orb,1) , fock_virt_from_act(i_virt_orb,2) enddo END_PROVIDER @@ -160,7 +159,6 @@ fock_virt_total(i_virt_orb,1) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) fock_virt_total(i_virt_orb,2) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) fock_virt_total_spin_trace(i_virt_orb) = 0.5d0 * ( fock_virt_total(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) ) - print*, fock_virt_total_spin_trace(i_virt_orb) enddo END_PROVIDER diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index f0b58d24..c04b14fa 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -71,12 +71,17 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip idx_alpha(j) = idx_miniList(idx_alpha(j)) enddo +! double precision :: ihpsi0,coef_pert +! ihpsi0 = 0.d0 +! coef_pert = 0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e_final) call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) delta_e_array(index_i) = 1.d0/delta_e_final hij_array(index_i) = hialpha + ! ihpsi0 += hialpha * psi_coef(index_i,1) + ! coef_pert += hialpha * psi_coef(index_i,1) * delta_e_array(index_i) enddo do i=1,idx_alpha(0) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 38c33377..19a44640 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -1,22 +1,317 @@ BEGIN_PROVIDER [ double precision, delta_ij, (N_det,N_det,N_states) ] &BEGIN_PROVIDER [ double precision, second_order_pt_new, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_1p, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h1p, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_2p, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_1h2p, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h1p, (N_states) ] +&BEGIN_PROVIDER [ double precision, second_order_pt_new_2h2p, (N_states) ] implicit none BEGIN_DOC ! Dressing matrix in N_det basis END_DOC integer :: i,j,m - delta_ij = 0.d0 - call H_apply_mrpt(delta_ij,N_det) double precision :: accu + double precision, allocatable :: delta_ij_tmp(:,:,:) + + + delta_ij = 0.d0 + + allocate (delta_ij_tmp(N_det,N_det,N_states)) + + + ! 1h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h(delta_ij_tmp,N_det) accu = 0.d0 do i = 1, N_det do j = 1, N_det - accu += delta_ij(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) enddo - write(*,'(1000(F16.10,x))')delta_ij(i,:,:) enddo - print*, 'accu = ',accu + print*, '1h = ',accu + second_order_pt_new_1h(1) = accu + + ! 1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '1p = ',accu + second_order_pt_new_1p(1) = accu + + ! 1h1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '1h1p = ',accu + second_order_pt_new_1h1p(1) = accu + + ! 2h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '2h = ',accu + second_order_pt_new_2h(1) = accu + + ! 2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '2p = ',accu + second_order_pt_new_2p(1) = accu + + ! 1h2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '1h2p = ',accu + second_order_pt_new_1h2p(1) = accu + + ! 2h1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '2h1p = ',accu + second_order_pt_new_2h1p(1) = accu + + ! 2h2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + enddo + enddo + print*, '2h2p = ',accu + second_order_pt_new_2h2p(1) = accu + + ! total + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += delta_ij(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*, 'total= ',accu second_order_pt_new(1) = accu + + +! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) + + END_PROVIDER + BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new, (N_det,N_det,N_states)] + implicit none + integer :: i,j,i_state + do i_state = 1, N_states + do i = 1,N_det + do j = 1,N_det + Hmatrix_dressed_pt2_new(j,i,i_state) = H_matrix_all_dets(j,i) + delta_ij(j,i,i_state) + enddo + enddo + enddo + END_PROVIDER + + + + BEGIN_PROVIDER [double precision, Hmatrix_dressed_pt2_new_symmetrized, (N_det,N_det,N_states)] + implicit none + integer :: i,j,i_state + do i_state = 1, N_states + do i = 1,N_det + do j = i,N_det + Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) = H_matrix_all_dets(j,i) & + + 0.5d0 * ( delta_ij(j,i,i_state) + delta_ij(i,j,i_state) ) + Hmatrix_dressed_pt2_new_symmetrized(i,j,i_state) = Hmatrix_dressed_pt2_new_symmetrized(j,i,i_state) + enddo + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] + &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + implicit none + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + integer :: i_state + double precision :: s2,e_0 + integer :: i,j,k + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + + do j=N_det+1,N_states_diag + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = 0.d0 + enddo + enddo + + if (diag_algorithm == "Davidson") then + + print*, 'Davidson not yet implemented for the dressing ... ' + stop + + else if (diag_algorithm == "Lapack") then + + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + Hmatrix_dressed_pt2_new_symmetrized(1,1,1),N_det,N_det) + CI_electronic_dressed_pt2_new_energy(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) + s2_eigvalues(j) = s2 + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2-expected_s2).le.0.3d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif + enddo + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + enddo + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + if(i_state+i_other_state.gt.n_states_diag)then + exit + endif + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(i_state+i_other_state) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2 + enddo + + deallocate(index_good_state_array,good_state_array) + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_dressed_pt2_new_eigenvectors' + print*,' You should consider more states and maybe ask for diagonalize_s2 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_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) + enddo + endif + deallocate(s2_eigvalues) + else + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2) + do i=1,N_det + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_dressed_pt2_new_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2 + enddo + endif + deallocate(eigenvectors,eigenvalues) + endif + + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] + implicit none + BEGIN_DOC + ! N_states lowest eigenvalues of the CI matrix + END_DOC + + integer :: j + character*(8) :: st + call write_time(output_determinants) + do j=1,N_states_diag + CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion + write(st,'(I4)') j + call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) + enddo + +END_PROVIDER diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index d15118a3..149c03b1 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -18,6 +18,14 @@ filter1h filter1p only_2p_single only_2p_double +only_2h_single +only_2h_double +only_1h_single +only_1h_double +only_1p_single +only_1p_double +only_2h1p_single +only_2h1p_double filter_only_1h1p_single filter_only_1h1p_double filter_only_1h2p_single @@ -197,14 +205,55 @@ class H_apply(object): if (is_a_1p(hole)) cycle """ + def filter_only_2h(self): + self["only_2h_single"] = """ +! ! DIR$ FORCEINLINE + if (is_a_2h(hole).eqv. .False.) cycle + """ + self["only_2h_double"] = """ +! ! DIR$ FORCEINLINE + if ( is_a_2h(key).eqv. .False. )cycle + """ + + def filter_only_1h(self): + self["only_1h_single"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1h(hole) .eqv. .False.) cycle + """ + self["only_1h_double"] = """ +! ! DIR$ FORCEINLINE + if (is_a_1h(key) .eqv. .False.) cycle + """ + + def filter_only_1p(self): + self["only_1p_single"] = """ +! ! DIR$ FORCEINLINE + if ( is_a_1p(hole) .eqv. .False.) cycle + """ + self["only_1p_double"] = """ +! ! DIR$ FORCEINLINE + if ( is_a_1p(key) .eqv. .False.) cycle + """ + + def filter_only_2h1p(self): + self["only_2h1p_single"] = """ +! ! DIR$ FORCEINLINE + if ( is_a_2h1p(hole) .eqv. .False.) cycle + """ + self["only_2h1p_double"] = """ +! ! DIR$ FORCEINLINE + if (is_a_2h1p(key) .eqv. .False.) cycle + """ + + def filter_only_2p(self): self["only_2p_single"] = """ ! ! DIR$ FORCEINLINE - if (.not. is_a_2p(hole)) cycle + if (is_a_2p(hole).eqv. .False.) cycle """ self["only_2p_double"] = """ ! ! DIR$ FORCEINLINE - if (.not. is_a_2p(key)) cycle + if (is_a_2p(key).eqv. .False.) cycle """ @@ -223,7 +272,7 @@ class H_apply(object): ! ! DIR$ FORCEINLINE if (is_a_two_holes_two_particles(hole).eqv..False.) cycle """ - self["filter_only_1h1p_double"] = """ + self["filter_only_2h2p_double"] = """ ! ! DIR$ FORCEINLINE if (is_a_two_holes_two_particles(key).eqv..False.) cycle """ diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 4984d9a8..6619b125 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -1,106 +1,116 @@ +use bitmasks integer function number_of_holes(key_in) +use bitmasks ! function that returns the number of holes in the inact space implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i number_of_holes = 0 + + do i = 1, N_int + number_of_holes = number_of_holes & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) + enddo + return if(N_int == 1)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) else if(N_int == 2)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) else if(N_int == 3)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) else if(N_int == 4)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) else if(N_int == 5)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) else if(N_int == 6)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) else if(N_int == 7)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )& - + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) )& - + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) else if(N_int == 8)then number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) )& - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) )& - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) )& - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) )& - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) )& - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) )& - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) )& - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) )& - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) )& - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) )& - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) )& - + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) )& - + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) else do i = 1, N_int number_of_holes = number_of_holes & - + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) )& - + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) enddo endif end integer function number_of_particles(key_in) +use bitmasks ! function that returns the number of particles in the virtual space implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) @@ -204,6 +214,7 @@ integer function number_of_particles(key_in) end logical function is_a_two_holes_two_particles(key_in) +use bitmasks ! logical function that returns True if the determinant 'key_in' ! belongs to the 2h-2p excitation class of the DDCI space ! this is calculated using the CAS_bitmask that defines the active @@ -221,163 +232,163 @@ logical function is_a_two_holes_two_particles(key_in) i_diff = 0 if(N_int == 1)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) else if(N_int == 2)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) else if(N_int == 3)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) else if(N_int == 4)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) else if(N_int == 5)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) else if(N_int == 6)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) else if(N_int == 7)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) & - + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) & - + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) & + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) else if(N_int == 8)then i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) ) & - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) & + popcnt( iand( iand( xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))), virt_bitmask(1,1) ), virt_bitmask(1,1)) ) & + popcnt( iand( iand( xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1))), virt_bitmask(1,2) ), virt_bitmask(1,2)) ) & - + popcnt( xor( iand(inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), inact_bitmask(2,1)) ) & - + popcnt( xor( iand(inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), inact_bitmask(2,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,1), xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1)))), reunion_of_core_inact_bitmask(2,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(2,2), xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1)))), reunion_of_core_inact_bitmask(2,2)) ) & + popcnt( iand( iand( xor(key_in(2,1),iand(key_in(2,1),cas_bitmask(2,1,1))), virt_bitmask(2,1) ), virt_bitmask(2,1)) ) & + popcnt( iand( iand( xor(key_in(2,2),iand(key_in(2,2),cas_bitmask(2,2,1))), virt_bitmask(2,2) ), virt_bitmask(2,2)) ) & - + popcnt( xor( iand(inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), inact_bitmask(3,1)) ) & - + popcnt( xor( iand(inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), inact_bitmask(3,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,1), xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1)))), reunion_of_core_inact_bitmask(3,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(3,2), xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1)))), reunion_of_core_inact_bitmask(3,2)) ) & + popcnt( iand( iand( xor(key_in(3,1),iand(key_in(3,1),cas_bitmask(3,1,1))), virt_bitmask(3,1) ), virt_bitmask(3,1)) ) & + popcnt( iand( iand( xor(key_in(3,2),iand(key_in(3,2),cas_bitmask(3,2,1))), virt_bitmask(3,2) ), virt_bitmask(3,2)) ) & - + popcnt( xor( iand(inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), inact_bitmask(4,1)) ) & - + popcnt( xor( iand(inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), inact_bitmask(4,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,1), xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1)))), reunion_of_core_inact_bitmask(4,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(4,2), xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1)))), reunion_of_core_inact_bitmask(4,2)) ) & + popcnt( iand( iand( xor(key_in(4,1),iand(key_in(4,1),cas_bitmask(4,1,1))), virt_bitmask(4,1) ), virt_bitmask(4,1)) ) & + popcnt( iand( iand( xor(key_in(4,2),iand(key_in(4,2),cas_bitmask(4,2,1))), virt_bitmask(4,2) ), virt_bitmask(4,2)) ) & - + popcnt( xor( iand(inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), inact_bitmask(5,1)) ) & - + popcnt( xor( iand(inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), inact_bitmask(5,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,1), xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1)))), reunion_of_core_inact_bitmask(5,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(5,2), xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1)))), reunion_of_core_inact_bitmask(5,2)) ) & + popcnt( iand( iand( xor(key_in(5,1),iand(key_in(5,1),cas_bitmask(5,1,1))), virt_bitmask(5,1) ), virt_bitmask(5,1)) ) & + popcnt( iand( iand( xor(key_in(5,2),iand(key_in(5,2),cas_bitmask(5,2,1))), virt_bitmask(5,2) ), virt_bitmask(5,2)) ) & - + popcnt( xor( iand(inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), inact_bitmask(6,1)) ) & - + popcnt( xor( iand(inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), inact_bitmask(6,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,1), xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1)))), reunion_of_core_inact_bitmask(6,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(6,2), xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1)))), reunion_of_core_inact_bitmask(6,2)) ) & + popcnt( iand( iand( xor(key_in(6,1),iand(key_in(6,1),cas_bitmask(6,1,1))), virt_bitmask(6,1) ), virt_bitmask(6,1)) ) & + popcnt( iand( iand( xor(key_in(6,2),iand(key_in(6,2),cas_bitmask(6,2,1))), virt_bitmask(6,2) ), virt_bitmask(6,2)) ) & - + popcnt( xor( iand(inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), inact_bitmask(7,1)) ) & - + popcnt( xor( iand(inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), inact_bitmask(7,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,1), xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1)))), reunion_of_core_inact_bitmask(7,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(7,2), xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1)))), reunion_of_core_inact_bitmask(7,2)) ) & + popcnt( iand( iand( xor(key_in(7,1),iand(key_in(7,1),cas_bitmask(7,1,1))), virt_bitmask(7,1) ), virt_bitmask(7,1)) ) & + popcnt( iand( iand( xor(key_in(7,2),iand(key_in(7,2),cas_bitmask(7,2,1))), virt_bitmask(7,2) ), virt_bitmask(7,2)) ) & - + popcnt( xor( iand(inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), inact_bitmask(8,1)) ) & - + popcnt( xor( iand(inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), inact_bitmask(8,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,1), xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1)))), reunion_of_core_inact_bitmask(8,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(8,2), xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1)))), reunion_of_core_inact_bitmask(8,2)) ) & + popcnt( iand( iand( xor(key_in(8,1),iand(key_in(8,1),cas_bitmask(8,1,1))), virt_bitmask(8,1) ), virt_bitmask(8,1)) ) & + popcnt( iand( iand( xor(key_in(8,2),iand(key_in(8,2),cas_bitmask(8,2,1))), virt_bitmask(8,2) ), virt_bitmask(8,2)) ) @@ -385,8 +396,8 @@ logical function is_a_two_holes_two_particles(key_in) do i = 1, N_int i_diff = i_diff & - + popcnt( xor( iand(inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), inact_bitmask(i,1)) ) & - + popcnt( xor( iand(inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), inact_bitmask(i,2)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) & + + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,2), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1)))), reunion_of_core_inact_bitmask(i,2)) ) & + popcnt( iand( iand( xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1))), virt_bitmask(i,1) ), virt_bitmask(i,1)) ) & + popcnt( iand( iand( xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,2,1))), virt_bitmask(i,2) ), virt_bitmask(i,2)) ) enddo @@ -398,6 +409,7 @@ logical function is_a_two_holes_two_particles(key_in) integer function number_of_holes_verbose(key_in) +use bitmasks ! function that returns the number of holes in the inact space implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) @@ -410,17 +422,17 @@ integer function number_of_holes_verbose(key_in) key_tmp(1,1) = xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1))) key_tmp(1,2) = xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,1,1))) call debug_det(key_tmp,N_int) - key_tmp(1,1) = iand(key_tmp(1,1),inact_bitmask(1,1)) - key_tmp(1,2) = iand(key_tmp(1,2),inact_bitmask(1,2)) + key_tmp(1,1) = iand(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1)) + key_tmp(1,2) = iand(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2)) call debug_det(key_tmp,N_int) - key_tmp(1,1) = xor(key_tmp(1,1),inact_bitmask(1,1)) - key_tmp(1,2) = xor(key_tmp(1,2),inact_bitmask(1,2)) + key_tmp(1,1) = xor(key_tmp(1,1),reunion_of_core_inact_bitmask(1,1)) + key_tmp(1,2) = xor(key_tmp(1,2),reunion_of_core_inact_bitmask(1,2)) call debug_det(key_tmp,N_int) ! number_of_holes_verbose = number_of_holes_verbose + popcnt(key_tmp(1,1)) & ! + popcnt(key_tmp(1,2)) number_of_holes_verbose = number_of_holes_verbose & - + popcnt( xor( iand(inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), inact_bitmask(1,1)) )& - + popcnt( xor( iand(inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), inact_bitmask(1,2)) ) + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& + + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,2), xor(key_in(1,2),iand(key_in(1,2),cas_bitmask(1,2,1)))), reunion_of_core_inact_bitmask(1,2)) ) print*,'----------------------' end @@ -452,6 +464,7 @@ integer function number_of_particles_verbose(key_in) end logical function is_a_1h1p(key_in) +use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -463,6 +476,7 @@ logical function is_a_1h1p(key_in) end logical function is_a_1h2p(key_in) +use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -473,7 +487,20 @@ logical function is_a_1h2p(key_in) end +logical function is_a_2h1p(key_in) +use bitmasks + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_2h1p = .False. + if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.1)then + is_a_2h1p = .True. + endif + +end + logical function is_a_1h(key_in) +use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -485,6 +512,7 @@ logical function is_a_1h(key_in) end logical function is_a_1p(key_in) +use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -496,6 +524,7 @@ logical function is_a_1p(key_in) end logical function is_a_2p(key_in) +use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -506,3 +535,15 @@ logical function is_a_2p(key_in) end +logical function is_a_2h(key_in) +use bitmasks + implicit none + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: number_of_particles, number_of_holes + is_a_2h = .False. + if(number_of_holes(key_in).eq.2 .and. number_of_particles(key_in).eq.0)then + is_a_2h = .True. + endif + +end + diff --git a/src/Determinants/H_apply.template.f b/src/Determinants/H_apply.template.f index f123f9bd..bb095ff4 100644 --- a/src/Determinants/H_apply.template.f +++ b/src/Determinants/H_apply.template.f @@ -179,6 +179,8 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl logical :: is_a_1h logical :: is_a_1p logical :: is_a_2p + logical :: is_a_2h1p + logical :: is_a_2h logical :: b_cycle check_double_excitation = .True. iproc = iproc_in @@ -310,6 +312,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $filter_only_1h2p_double $filter_only_2h2p_double $only_2p_double + $only_2h_double + $only_1h_double + $only_1p_double + $only_2h1p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -361,6 +367,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl $filter_only_1h2p_double $filter_only_2h2p_double $only_2p_double + $only_2h_double + $only_1h_double + $only_1p_double + $only_2h1p_double key_idx += 1 do k=1,N_int keys_out(k,1,key_idx) = key(k,1) @@ -428,6 +438,8 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato integer(bit_kind) :: key_mask(N_int, 2) logical :: check_double_excitation + logical :: is_a_2h1p + logical :: is_a_2h logical :: is_a_1h1p logical :: is_a_1h2p logical :: is_a_1h @@ -508,6 +520,10 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato $filterparticle hole(k_a,ispin) = ibset(hole(k_a,ispin),l_a) $only_2p_single + $only_2h_single + $only_1h_single + $only_1p_single + $only_2h1p_single $filter1h $filter1p $filter2p From dbf894a99a71c4bddf4f21ee5effd01b7bd71773 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 1 Sep 2016 17:43:33 +0200 Subject: [PATCH 13/32] mrpt new with multi state version --- config/ifort.cfg | 2 +- plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 32 +- plugins/MRPT_Utils/energies_cas.irp.f | 167 +++++---- .../energies_cas_spin_averaged.irp.f | 190 ---------- plugins/MRPT_Utils/fock_like_operators.irp.f | 145 ++++---- plugins/MRPT_Utils/mrpt_dress.irp.f | 17 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 79 ++-- plugins/MRPT_Utils/psi_active_prov.irp.f | 337 ++++-------------- src/Bitmask/bitmask_cas_routines.irp.f | 6 - src/Determinants/density_matrix.irp.f | 61 ++-- 10 files changed, 319 insertions(+), 717 deletions(-) delete mode 100644 plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index da414912..a738a83c 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index 7e4aa80b..9ee42820 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -27,43 +27,17 @@ subroutine routine_2 implicit none integer :: i do i = 1, n_core_inact_orb - print*,fock_core_inactive_total(i,1),fock_core_inactive(i) + print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i) enddo double precision :: accu accu = 0.d0 do i = 1, n_act_orb integer :: j_act_orb j_act_orb = list_act(i) - accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb) - print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb),one_body_dm_mo_beta(j_act_orb,j_act_orb) + accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1) + print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) enddo print*,'accu = ',accu end -subroutine routine - implicit none - integer :: i,j - integer :: orb, spin_exc - integer :: hole_particle - double precision, allocatable :: norm_out(:) - allocate(norm_out(N_states_diag)) - - orb = list_virt(10) - hole_particle = -1 - spin_exc = 1 - - call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_det,psi_coef, n_det,psi_det_size,psi_det_size,N_states_diag) - do i = 1, N_det - if(psi_coef(i,1).ne.0.d0)then - print*, '' - call debug_det(psi_det(1,1,i),N_int) - print*, 'coef = ',psi_coef(i,1) - endif - enddo - print*,'norm_out = ',norm_out - - deallocate(norm_out) - -end diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 0c104be6..8644bfa8 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -10,7 +10,7 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] END_PROVIDER -BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2)] +BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin @@ -21,6 +21,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2)] use bitmasks integer :: iorb + integer :: state_target + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) @@ -35,19 +37,18 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2)] psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - integer :: state_target - state_target = 1 - double precision :: energies(n_states_diag) - call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_creat(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1,N_states + call apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2)] +BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin @@ -58,6 +59,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2)] use bitmasks integer :: iorb + integer :: state_target + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) @@ -72,30 +75,18 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2)] psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - integer :: state_target - state_target = 1 - double precision :: energies(n_states_diag) - call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) -! do j = 1, n_det -! print*, 'psi_in_out_coef' -! print*, psi_in_out_coef(j,1) -! call debug_det(psi_in_out(1,1,j),N_int) -! enddo - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) -! print*,'energy_cas_dyall(state_target)' -! print*, energy_cas_dyall(state_target) -! print*,'energies(state_target)' -! print*, energies(state_target) - one_anhil(iorb,ispin) = energy_cas_dyall(state_target) - energies(state_target) -! print*,'one_anhil(iorb,ispin)' -! print*, one_anhil(iorb,ispin) + do state_target = 1, N_states + call apply_exc_to_psi(orb,hole_particle,spin_exc, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin @@ -108,7 +99,6 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2)] integer :: iorb,jorb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -129,12 +119,14 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2)] psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1 , N_states + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -142,7 +134,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2)] END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin @@ -181,7 +173,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2)] call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -189,7 +181,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2)] END_PROVIDER -BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2)] +BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2,N_States)] implicit none integer :: i,j integer :: ispin,jspin @@ -202,7 +194,6 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: iorb,jorb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -223,12 +214,14 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1, N_states + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -236,7 +229,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -251,7 +244,6 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a integer :: iorb,jorb integer :: korb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -278,14 +270,16 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a enddo enddo - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1, N_states + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -295,7 +289,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -310,7 +304,6 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer :: iorb,jorb integer :: korb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -336,14 +329,16 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1, N_states + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -353,7 +348,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a END_PROVIDER -BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -368,7 +363,6 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: iorb,jorb integer :: korb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -394,14 +388,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1, N_states + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -411,7 +407,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 END_PROVIDER -BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2)] +BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin @@ -426,7 +422,6 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: iorb,jorb integer :: korb integer :: state_target - state_target = 1 double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 @@ -452,14 +447,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 psi_in_out(j,2,i) = psi_det(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1, N_states + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo enddo enddo enddo diff --git a/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f b/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f deleted file mode 100644 index f6b542bd..00000000 --- a/plugins/MRPT_Utils/energies_cas_spin_averaged.irp.f +++ /dev/null @@ -1,190 +0,0 @@ - -BEGIN_PROVIDER [ double precision, one_creat_spin_trace, (n_act_orb)] - implicit none - integer :: i - do i = 1, n_act_orb - one_creat_spin_trace(i) = one_creat(i,1) + one_creat(i,2) - one_creat_spin_trace(i) = 0.5d0 * one_creat_spin_trace(i) - enddo -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, one_anhil_spin_trace, (n_act_orb)] - implicit none - integer :: i - do i = 1, n_act_orb - one_anhil_spin_trace(i) = one_anhil(i,1) + one_anhil(i,2) - one_anhil_spin_trace(i) = 0.5d0 * one_anhil_spin_trace(i) - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_creat_spin_trace, (n_act_orb,n_act_orb)] - implicit none - integer :: i,j - integer :: ispin,jspin - double precision :: counting - do i = 1, n_act_orb - do j = 1, n_act_orb - two_creat_spin_trace(j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - two_creat_spin_trace(j,i) += two_creat(j,i,ispin,jspin) - counting += 1.d0 - enddo - enddo - two_creat_spin_trace(j,i) = two_creat_spin_trace(j,i) / counting - enddo - enddo -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_anhil_spin_trace, (n_act_orb,n_act_orb)] - implicit none - integer :: i,j - integer :: ispin,jspin - double precision :: counting - do i = 1, n_act_orb - do j = 1, n_act_orb - two_anhil_spin_trace(j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - two_anhil_spin_trace(j,i) += two_anhil(j,i,ispin,jspin) - counting += 1.d0 - enddo - enddo - two_anhil_spin_trace(j,i) = two_anhil_spin_trace(j,i) / counting - enddo - enddo -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, one_anhil_one_creat_spin_trace, (n_act_orb,n_act_orb)] - implicit none - integer :: i,j - integer :: ispin,jspin - double precision :: counting - do i = 1, n_act_orb - do j = 1, n_act_orb - one_anhil_one_creat_spin_trace(j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - one_anhil_one_creat_spin_trace(j,i) += one_anhil_one_creat(j,i,jspin,ispin) - counting += 1.d0 - enddo - enddo - one_anhil_one_creat_spin_trace(j,i) = one_anhil_one_creat_spin_trace(j,i) / counting - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, two_anhil_one_creat_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k - integer :: ispin,jspin,kspin - double precision :: counting - - do i = 1, n_act_orb - do j = 1, n_act_orb - do k = 1, n_act_orb - two_anhil_one_creat_spin_trace(k,j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - do kspin = 1,2 - two_anhil_one_creat_spin_trace(k,j,i) += two_anhil_one_creat(k,j,i,kspin,jspin,ispin) - counting += 1.d0 - enddo - enddo - two_anhil_one_creat_spin_trace(k,j,i) = two_anhil_one_creat_spin_trace(k,j,i) / counting - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, two_creat_one_anhil_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k - integer :: ispin,jspin,kspin - double precision :: counting - - do i = 1, n_act_orb - do j = 1, n_act_orb - do k = 1, n_act_orb - two_creat_one_anhil_spin_trace(k,j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - do kspin = 1,2 - two_creat_one_anhil_spin_trace(k,j,i) += two_creat_one_anhil(k,j,i,kspin,jspin,ispin) - counting += 1.d0 - enddo - enddo - two_creat_one_anhil_spin_trace(k,j,i) = two_creat_one_anhil_spin_trace(k,j,i) / counting - enddo - enddo - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, three_creat_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k - integer :: ispin,jspin,kspin - double precision :: counting - - do i = 1, n_act_orb - do j = 1, n_act_orb - do k = 1, n_act_orb - three_creat_spin_trace(k,j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - do kspin = 1,2 - three_creat_spin_trace(k,j,i) += three_creat(k,j,i,kspin,jspin,ispin) - counting += 1.d0 - enddo - enddo - three_creat_spin_trace(k,j,i) = three_creat_spin_trace(k,j,i) / counting - enddo - enddo - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, three_anhil_spin_trace, (n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k - integer :: ispin,jspin,kspin - double precision :: counting - - do i = 1, n_act_orb - do j = 1, n_act_orb - do k = 1, n_act_orb - three_anhil_spin_trace(k,j,i) = 0.d0 - counting = 0.d0 - do ispin = 1, 2 - do jspin = 1,2 - do kspin = 1,2 - three_anhil_spin_trace(k,j,i) += three_anhil(k,j,i,kspin,jspin,ispin) - counting += 1.d0 - enddo - enddo - three_anhil_spin_trace(k,j,i) = three_anhil_spin_trace(k,j,i) / counting - enddo - enddo - enddo - enddo - -END_PROVIDER - diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index 44c16da6..5900516e 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -44,7 +44,7 @@ enddo END_PROVIDER - BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2)] + BEGIN_PROVIDER [double precision, fock_core_inactive_from_act, (mo_tot_num,2,N_states)] BEGIN_DOC ! inactive part of the fock operator with contributions only from the active END_DOC @@ -55,39 +55,42 @@ double precision :: coulomb, exchange double precision :: get_mo_bielec_integral_schwartz integer :: j_act_orb,k_act_orb,i_inact_core_orb + integer :: i_state - do i = 1, n_core_inact_orb - accu_coulomb = 0.d0 - accu_exchange = 0.d0 - i_inact_core_orb = list_core_inact(i) - do j = 1, n_act_orb - j_act_orb = list_act(j) - na = one_body_dm_mo_alpha(j_act_orb,j_act_orb) - nb = one_body_dm_mo_beta(j_act_orb,j_act_orb) - ntot = na + nb - coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb) - exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb) - accu_coulomb += ntot * coulomb - accu_exchange(1) += na * exchange - accu_exchange(2) += nb * exchange - do k = j+1, n_act_orb - k_act_orb = list_act(k) - na = one_body_dm_mo_alpha(j_act_orb,k_act_orb) - nb = one_body_dm_mo_beta(j_act_orb,k_act_orb) + do i_state = 1,N_states + do i = 1, n_core_inact_orb + accu_coulomb = 0.d0 + accu_exchange = 0.d0 + i_inact_core_orb = list_core_inact(i) + do j = 1, n_act_orb + j_act_orb = list_act(j) + na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state) + nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state) ntot = na + nb - coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) - exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) - accu_coulomb += 2.d0 * ntot * coulomb - accu_exchange(1) += 2.d0 * na * exchange - accu_exchange(2) += 2.d0 * nb * exchange + coulomb = mo_bielec_integral_jj(i_inact_core_orb,j_act_orb) + exchange = mo_bielec_integral_jj_exchange(i_inact_core_orb,j_act_orb) + accu_coulomb += ntot * coulomb + accu_exchange(1) += na * exchange + accu_exchange(2) += nb * exchange + do k = j+1, n_act_orb + k_act_orb = list_act(k) + na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) + nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) + ntot = na + nb + coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) + exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) + accu_coulomb += 2.d0 * ntot * coulomb + accu_exchange(1) += 2.d0 * na * exchange + accu_exchange(2) += 2.d0 * nb * exchange + enddo enddo + fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb + accu_exchange(1) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb + accu_exchange(2) enddo - fock_core_inactive_from_act(i_inact_core_orb,1) = accu_coulomb + accu_exchange(1) - fock_core_inactive_from_act(i_inact_core_orb,2) = accu_coulomb + accu_exchange(2) enddo END_PROVIDER - BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2)] + BEGIN_PROVIDER [double precision, fock_virt_from_act, (mo_tot_num,2,N_states)] BEGIN_DOC ! virtual part of the fock operator with contributions only from the active END_DOC @@ -98,67 +101,77 @@ double precision :: coulomb, exchange double precision :: get_mo_bielec_integral_schwartz integer :: j_act_orb,i_virt_orb,k_act_orb + integer :: i_state + ! TODO : inverse loop of i_state - do i = 1, n_virt_orb - accu_coulomb = 0.d0 - accu_exchange = 0.d0 - i_virt_orb = list_virt(i) - do j = 1, n_act_orb - j_act_orb = list_act(j) - na = one_body_dm_mo_alpha(j_act_orb,j_act_orb) - nb = one_body_dm_mo_beta(j_act_orb,j_act_orb) - ntot = na + nb - coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb) - exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb) - accu_coulomb += ntot * coulomb - accu_exchange(1) += na * exchange - accu_exchange(2) += nb * exchange - do k = j+1, n_act_orb - k_act_orb = list_act(k) - na = one_body_dm_mo_alpha(j_act_orb,k_act_orb) - nb = one_body_dm_mo_beta(j_act_orb,k_act_orb) + do i_state = 1, N_states + do i = 1, n_virt_orb + accu_coulomb = 0.d0 + accu_exchange = 0.d0 + i_virt_orb = list_virt(i) + do j = 1, n_act_orb + j_act_orb = list_act(j) + na = one_body_dm_mo_alpha(j_act_orb,j_act_orb,i_state) + nb = one_body_dm_mo_beta(j_act_orb,j_act_orb,i_state) ntot = na + nb - coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) - exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) - accu_coulomb += 2.d0 * ntot * coulomb - accu_exchange(1) += 2.d0 * na * exchange - accu_exchange(2) += 2.d0 * nb * exchange + coulomb = mo_bielec_integral_jj(i_virt_orb,j_act_orb) + exchange = mo_bielec_integral_jj_exchange(i_virt_orb,j_act_orb) + accu_coulomb += ntot * coulomb + accu_exchange(1) += na * exchange + accu_exchange(2) += nb * exchange + do k = j+1, n_act_orb + k_act_orb = list_act(k) + na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) + nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) + ntot = na + nb + coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) + exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) + accu_coulomb += 2.d0 * ntot * coulomb + accu_exchange(1) += 2.d0 * na * exchange + accu_exchange(2) += 2.d0 * nb * exchange + enddo enddo + fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb + accu_exchange(1) + fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb + accu_exchange(2) enddo - fock_virt_from_act(i_virt_orb,1) = accu_coulomb + accu_exchange(1) - fock_virt_from_act(i_virt_orb,2) = accu_coulomb + accu_exchange(2) enddo END_PROVIDER - BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2)] -&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num)] + BEGIN_PROVIDER [double precision, fock_core_inactive_total, (mo_tot_num,2,N_states)] +&BEGIN_PROVIDER [double precision, fock_core_inactive_total_spin_trace, (mo_tot_num,N_states)] BEGIN_DOC ! inactive part of the fock operator END_DOC implicit none integer :: i integer :: i_inact_core_orb - do i = 1, n_core_inact_orb - i_inact_core_orb = list_core_inact(i) - fock_core_inactive_total(i_inact_core_orb,1) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1) - fock_core_inactive_total(i_inact_core_orb,2) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2) - fock_core_inactive_total_spin_trace(i_inact_core_orb) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1) + fock_core_inactive_total(i_inact_core_orb,2)) + integer :: i_state + do i_state = 1, N_states + do i = 1, n_core_inact_orb + i_inact_core_orb = list_core_inact(i) + fock_core_inactive_total(i_inact_core_orb,1,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,1,i_state) + fock_core_inactive_total(i_inact_core_orb,2,i_state) = fock_core_inactive(i_inact_core_orb) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state) + fock_core_inactive_total_spin_trace(i_inact_core_orb,i_state) = 0.5d0 * (fock_core_inactive_total(i_inact_core_orb,1,i_state) + fock_core_inactive_total(i_inact_core_orb,2,i_state)) + enddo enddo END_PROVIDER - BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2)] -&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num)] + BEGIN_PROVIDER [double precision, fock_virt_total, (mo_tot_num,2,N_states)] +&BEGIN_PROVIDER [double precision, fock_virt_total_spin_trace, (mo_tot_num,N_states)] BEGIN_DOC ! inactive part of the fock operator END_DOC implicit none integer :: i integer :: i_virt_orb - do i = 1, n_virt_orb - i_virt_orb= list_virt(i) - fock_virt_total(i_virt_orb,1) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) - fock_virt_total(i_virt_orb,2) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) - fock_virt_total_spin_trace(i_virt_orb) = 0.5d0 * ( fock_virt_total(i_virt_orb,1) + fock_virt_total(i_virt_orb,2) ) + integer :: i_state + do i_state = 1, N_states + do i = 1, n_virt_orb + i_virt_orb= list_virt(i) + fock_virt_total(i_virt_orb,1,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,1,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) + fock_virt_total(i_virt_orb,2,i_state) = fock_virt_from_core_inact(i_virt_orb) + fock_virt_from_act(i_virt_orb,2,i_state)+ mo_mono_elec_integral(i_virt_orb,i_virt_orb) + fock_virt_total_spin_trace(i_virt_orb,i_state) = 0.5d0 * ( fock_virt_total(i_virt_orb,1,i_state) + fock_virt_total(i_virt_orb,2,i_state) ) + enddo enddo END_PROVIDER diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index c04b14fa..512158cf 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -30,19 +30,19 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: degree_alpha(psi_det_size) logical :: fullMatch - double precision :: delta_e_array(psi_det_size) + double precision :: delta_e_inv_array(psi_det_size,N_states) double precision :: hij_array(psi_det_size) integer(bit_kind) :: tq(Nint,2,n_selected) integer :: N_tq - double precision :: hialpha + double precision :: hialpha,hij integer :: i_state, i_alpha integer(bit_kind),allocatable :: miniList(:,:,:) integer,allocatable :: idx_miniList(:) integer :: N_miniList, leng - double precision :: delta_e_final,hij_tmp + double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j @@ -76,12 +76,12 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip ! coef_pert = 0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e_final) + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e) call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) - delta_e_array(index_i) = 1.d0/delta_e_final hij_array(index_i) = hialpha - ! ihpsi0 += hialpha * psi_coef(index_i,1) - ! coef_pert += hialpha * psi_coef(index_i,1) * delta_e_array(index_i) + do i_state = 1,N_states + delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) + enddo enddo do i=1,idx_alpha(0) @@ -91,7 +91,8 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip do j = 1, idx_alpha(0) index_j = idx_alpha(j) do i_state=1,N_states - delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_array(index_j) +! standard dressing first order + delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) enddo enddo call omp_unset_lock( psi_ref_bis_lock(index_i)) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 19a44640..3b832b58 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -14,7 +14,8 @@ ! Dressing matrix in N_det basis END_DOC integer :: i,j,m - double precision :: accu + integer :: i_state + double precision :: accu(N_states) double precision, allocatable :: delta_ij_tmp(:,:,:) @@ -27,118 +28,136 @@ delta_ij_tmp = 0.d0 call H_apply_mrpt_1h(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo + enddo + second_order_pt_new_1h(i_state) = accu(i_state) enddo print*, '1h = ',accu - second_order_pt_new_1h(1) = accu ! 1p delta_ij_tmp = 0.d0 call H_apply_mrpt_1p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_1p(i_state) = accu(i_state) + enddo print*, '1p = ',accu - second_order_pt_new_1p(1) = accu ! 1h1p delta_ij_tmp = 0.d0 call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo print*, '1h1p = ',accu - second_order_pt_new_1h1p(1) = accu ! 2h delta_ij_tmp = 0.d0 call H_apply_mrpt_2h(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_2h(i_state) = accu(i_state) + enddo print*, '2h = ',accu - second_order_pt_new_2h(1) = accu ! 2p delta_ij_tmp = 0.d0 call H_apply_mrpt_2p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_2p(i_state) = accu(i_state) + enddo print*, '2p = ',accu - second_order_pt_new_2p(1) = accu ! 1h2p delta_ij_tmp = 0.d0 call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_1h2p(i_state) = accu(i_state) + enddo print*, '1h2p = ',accu - second_order_pt_new_1h2p(1) = accu ! 2h1p delta_ij_tmp = 0.d0 call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_2h1p(i_state) = accu(i_state) + enddo print*, '2h1p = ',accu - second_order_pt_new_2h1p(1) = accu ! 2h2p delta_ij_tmp = 0.d0 call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det do j = 1, N_det - accu += delta_ij_tmp(j,i,1) * psi_coef(i,1) * psi_coef(j,1) - delta_ij(j,i,1) += delta_ij_tmp(j,i,1) + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo enddo + second_order_pt_new_2h2p(i_state) = accu(i_state) + enddo print*, '2h2p = ',accu - second_order_pt_new_2h2p(1) = accu ! total accu = 0.d0 + do i_state = 1, N_states do i = 1, N_det - do j = 1, N_det - accu += delta_ij(j,i,1) * psi_coef(i,1) * psi_coef(j,1) + write(*,'(1000(F16.10,x))')delta_ij(i,:,:) + do j = i_state, N_det + accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) enddo enddo - print*, 'total= ',accu - second_order_pt_new(1) = accu + second_order_pt_new(i_state) = accu(i_state) + print*, 'total= ',accu(i_state) + enddo -! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) END_PROVIDER diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 02d11244..8d705deb 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -152,33 +152,51 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) + BEGIN_DOC + ! routine that returns the delta_e with the Moller Plesset and Dyall operators + ! + ! with det_1 being a determinant from the cas, and det_2 being a perturber + ! + ! Delta_e(det_1,det_2) = sum (hole) epsilon(hole) + sum(part) espilon(part) + delta_e(act) + ! + ! where hole is necessary in the inactive, part necessary in the virtuals + ! + ! and delta_e(act) is obtained from the contracted application of the excitation + ! + ! operator in the active space that lead from det_1 to det_2 + END_DOC implicit none use bitmasks - double precision, intent(out) :: delta_e_final + double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) integer :: i,j,k,l + integer :: i_state integer :: n_holes_spin(2) integer :: n_holes integer :: holes_list(N_int*bit_kind_size,2) - double precision :: delta_e_inactive + double precision :: delta_e_inactive(N_states) integer :: i_hole_inact call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) delta_e_inactive = 0.d0 do i = 1, n_holes_spin(1) i_hole_inact = holes_list(i,1) - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) + do i_state = 1, N_states + delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo enddo do i = 1, n_holes_spin(2) i_hole_inact = holes_list(i,2) - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) + do i_state = 1, N_states + delta_e_inactive(i_state) += fock_core_inactive_total_spin_trace(i_hole_inact,i_state) + enddo enddo - double precision :: delta_e_virt + double precision :: delta_e_virt(N_states) integer :: i_part_virt integer :: n_particles_spin(2) integer :: n_particles @@ -188,12 +206,16 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) delta_e_virt = 0.d0 do i = 1, n_particles_spin(1) i_part_virt = particles_list(i,1) - delta_e_virt += fock_virt_total_spin_trace(i_part_virt) + do i_state = 1, N_states + delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo enddo do i = 1, n_particles_spin(2) i_part_virt = particles_list(i,2) - delta_e_virt += fock_virt_total_spin_trace(i_part_virt) + do i_state = 1, N_states + delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo enddo @@ -203,7 +225,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) integer :: holes_active_list_spin_traced(4*n_act_orb) integer :: particles_active_list(2*n_act_orb,2) integer :: particles_active_list_spin_traced(4*n_act_orb) - double precision :: delta_e_act + double precision :: delta_e_act(N_states) delta_e_act = 0.d0 call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & n_holes_act,n_particles_act,holes_active_list,particles_active_list) @@ -265,14 +287,18 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) ! delta_e_act += one_creat_spin_trace(i_particle_act ) ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) - delta_e_act += one_creat(i_particle_act,ispin) + do i_state = 1, N_states + delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) + enddo else if (n_holes_act == 1 .and. n_particles_act == 0) then ! i_hole_act = holes_active_list_spin_traced(1) ! delta_e_act += one_anhil_spin_trace(i_hole_act ) ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) - delta_e_act += one_anhil(i_hole_act , ispin) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) + enddo else if (n_holes_act == 1 .and. n_particles_act == 1) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -284,7 +310,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) ! first particle jspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) - delta_e_act += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin,i_state) + enddo else if (n_holes_act == 2 .and. n_particles_act == 0) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -294,7 +322,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) i_hole_act = hole_list_practical(2,1) jspin = hole_list_practical(1,2) j_hole_act = hole_list_practical(2,2) - delta_e_act += two_anhil(i_hole_act,j_hole_act,ispin,jspin) + do i_state = 1, N_states + delta_e_act(i_state) += two_anhil(i_hole_act,j_hole_act,ispin,jspin,i_state) + enddo else if (n_holes_act == 0 .and. n_particles_act == 2) then ! i_particle_act = particles_active_list_spin_traced(1) @@ -304,7 +334,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) i_particle_act = particle_list_practical(2,1) jspin = particle_list_practical(1,2) j_particle_act = particle_list_practical(2,2) - delta_e_act += two_creat(i_particle_act,j_particle_act,ispin,jspin) + do i_state = 1, N_states + delta_e_act(i_state) += two_creat(i_particle_act,j_particle_act,ispin,jspin,i_state) + enddo else if (n_holes_act == 2 .and. n_particles_act == 1) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -324,7 +356,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) ! first particle kspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) - delta_e_act += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin) + do i_state = 1, N_states + delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) + enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -342,7 +376,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) kspin = particle_list_practical(1,2) j_particle_act = particle_list_practical(2,2) - delta_e_act += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin) + do i_state = 1, N_states + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) + enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -359,7 +395,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) ! third hole kspin = hole_list_practical(1,3) k_hole_act = hole_list_practical(2,3) - delta_e_act += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin) + do i_state = 1, N_states + delta_e_act(i_state) += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin,i_state) + enddo else if (n_holes_act == 0 .and. n_particles_act == 3) then ! i_particle_act = particles_active_list_spin_traced(1) @@ -376,7 +414,9 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) kspin = particle_list_practical(1,3) k_particle_act = particle_list_practical(2,3) - delta_e_act += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin) + do i_state = 1, N_states + delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state) + enddo else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then @@ -388,265 +428,8 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) !print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) - delta_e_final = delta_e_act + delta_e_inactive - delta_e_virt -!if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0 .or. delta_e_final == 0.d0)then -!if(delta_e_final == 0.d0)then - if(.False.)then - call debug_det(det_1,N_int) - call debug_det(det_2,N_int) - print*, 'n_holes_act,n_particles_act' - print*, n_holes_act,n_particles_act - print*, 'delta_e_act,delta_e_inactive,delta_e_vir' - print*, delta_e_act,delta_e_inactive,delta_e_virt - delta_e_final = -1000.d0 -!stop - - endif - -end - -subroutine get_delta_e_dyall_verbose(det_1,det_2,delta_e_final) - implicit none - use bitmasks - double precision, intent(out) :: delta_e_final - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer :: i,j,k,l - - integer :: n_holes_spin(2) - integer :: n_holes - integer :: holes_list(N_int*bit_kind_size,2) - - - double precision :: delta_e_inactive - integer :: i_hole_inact - - call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) - delta_e_inactive = 0.d0 - do i = 1, n_holes_spin(1) - i_hole_inact = holes_list(i,1) - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) - enddo - - do i = 1, n_holes_spin(2) - i_hole_inact = holes_list(i,2) - delta_e_inactive += fock_core_inactive_total_spin_trace(i_hole_inact) - enddo - - double precision :: delta_e_virt - integer :: i_part_virt - integer :: n_particles_spin(2) - integer :: n_particles - integer :: particles_list(N_int*bit_kind_size,2) - - call give_particles_in_virt_space(det_2,n_particles_spin,n_particles,particles_list) - delta_e_virt = 0.d0 - do i = 1, n_particles_spin(1) - i_part_virt = particles_list(i,1) - delta_e_virt += fock_virt_total_spin_trace(i_part_virt) - enddo - - do i = 1, n_particles_spin(2) - i_part_virt = particles_list(i,2) - delta_e_virt += fock_virt_total_spin_trace(i_part_virt) - enddo - - - integer :: n_holes_spin_act(2),n_particles_spin_act(2) - integer :: n_holes_act,n_particles_act - integer :: holes_active_list(2*n_act_orb,2) - integer :: holes_active_list_spin_traced(4*n_act_orb) - integer :: particles_active_list(2*n_act_orb,2) - integer :: particles_active_list_spin_traced(4*n_act_orb) - double precision :: delta_e_act - delta_e_act = 0.d0 - call give_holes_and_particles_in_active_space(det_1,det_2,n_holes_spin_act,n_particles_spin_act, & - n_holes_act,n_particles_act,holes_active_list,particles_active_list) - integer :: icount,icountbis - integer :: hole_list_practical(2,elec_num_tab(1)+elec_num_tab(2)), particle_list_practical(2,elec_num_tab(1)+elec_num_tab(2)) - icount = 0 - icountbis = 0 - do i = 1, n_holes_spin_act(1) - icount += 1 - icountbis += 1 - hole_list_practical(1,icountbis) = 1 - hole_list_practical(2,icountbis) = holes_active_list(i,1) - holes_active_list_spin_traced(icount) = holes_active_list(i,1) - enddo - do i = 1, n_holes_spin_act(2) - icount += 1 - icountbis += 1 - hole_list_practical(1,icountbis) = 2 - hole_list_practical(2,icountbis) = holes_active_list(i,2) - holes_active_list_spin_traced(icount) = holes_active_list(i,2) - enddo - if(icount .ne. n_holes_act) then - print*,'' - print*, icount, n_holes_act - print * , 'pb in holes_active_list_spin_traced !!' - stop - endif - - icount = 0 - icountbis = 0 - do i = 1, n_particles_spin_act(1) - icount += 1 - icountbis += 1 - particle_list_practical(1,icountbis) = 1 - particle_list_practical(2,icountbis) = particles_active_list(i,1) - particles_active_list_spin_traced(icount) = particles_active_list(i,1) - enddo - do i = 1, n_particles_spin_act(2) - icount += 1 - icountbis += 1 - particle_list_practical(1,icountbis) = 2 - particle_list_practical(2,icountbis) = particles_active_list(i,2) - particles_active_list_spin_traced(icount) = particles_active_list(i,2) - enddo - if(icount .ne. n_particles_act) then - print*, icount, n_particles_act - print * , 'pb in particles_active_list_spin_traced !!' - stop - endif - - - integer :: i_hole_act, j_hole_act, k_hole_act - integer :: i_particle_act, j_particle_act, k_particle_act - - - integer :: ispin,jspin,kspin - if (n_holes_act == 0 .and. n_particles_act == 1) then -! i_particle_act = particles_active_list_spin_traced(1) -! delta_e_act += one_creat_spin_trace(i_particle_act ) - ispin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - delta_e_act += one_creat(i_particle_act,ispin) - - else if (n_holes_act == 1 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! delta_e_act += one_anhil_spin_trace(i_hole_act ) - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - delta_e_act += one_anhil(i_hole_act , ispin) - - else if (n_holes_act == 1 .and. n_particles_act == 1) then -! i_hole_act = holes_active_list_spin_traced(1) -! i_particle_act = particles_active_list_spin_traced(1) -! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act) - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! first particle - jspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - delta_e_act += one_anhil_one_creat(i_particle_act,i_hole_act,jspin,ispin) - - else if (n_holes_act == 2 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(1) -! delta_e_act += two_anhil_spin_trace(i_hole_act,j_hole_act) - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - delta_e_act += two_anhil(i_hole_act,j_hole_act,ispin,jspin) - - else if (n_holes_act == 0 .and. n_particles_act == 2) then -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! delta_e_act += two_creat_spin_trace(i_particle_act,j_particle_act) - ispin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - jspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - delta_e_act += two_creat(i_particle_act,j_particle_act,ispin,jspin) - - else if (n_holes_act == 2 .and. n_particles_act == 1) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(2) -! i_particle_act = particles_active_list_spin_traced(1) -! print*, 'i_hole_act,j_hole_act,i_particle_act' -! print*, i_hole_act,j_hole_act,i_particle_act -! print*, two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) -! delta_e_act += two_anhil_one_creat_spin_trace(i_hole_act,j_hole_act,i_particle_act) - - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! second hole - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - ! first particle - kspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - delta_e_act += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin) - - else if (n_holes_act == 1 .and. n_particles_act == 2) then -! i_hole_act = holes_active_list_spin_traced(1) -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! delta_e_act += two_creat_one_anhil_spin_trace(i_hole_act,i_particle_act,j_particle_act) - - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! first particle - jspin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - ! second particle - kspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - - delta_e_act += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin) - - else if (n_holes_act == 3 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! j_hole_act = holes_active_list_spin_traced(2) -! k_hole_act = holes_active_list_spin_traced(3) -! delta_e_act += three_anhil_spin_trace(i_hole_act,j_hole_act,k_hole_act) - - ! first hole - ispin = hole_list_practical(1,1) - i_hole_act = hole_list_practical(2,1) - ! second hole - jspin = hole_list_practical(1,2) - j_hole_act = hole_list_practical(2,2) - ! third hole - kspin = hole_list_practical(1,3) - k_hole_act = hole_list_practical(2,3) - delta_e_act += three_anhil(i_hole_act,j_hole_act,k_hole_act,ispin,jspin,kspin) - - else if (n_holes_act == 0 .and. n_particles_act == 3) then -! i_particle_act = particles_active_list_spin_traced(1) -! j_particle_act = particles_active_list_spin_traced(2) -! k_particle_act = particles_active_list_spin_traced(3) -! delta_e_act += three_creat_spin_trace(i_particle_act,j_particle_act,k_particle_act) - ! first particle - ispin = particle_list_practical(1,1) - i_particle_act = particle_list_practical(2,1) - ! second particle - jspin = particle_list_practical(1,2) - j_particle_act = particle_list_practical(2,2) - ! second particle - kspin = particle_list_practical(1,3) - k_particle_act = particle_list_practical(2,3) - - delta_e_act += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin) - - endif - -!print*, 'one_anhil_spin_trace' -!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) - - - delta_e_final = delta_e_act + delta_e_inactive - delta_e_virt -!if(delta_e_final .le. -100d0.or.delta_e_final > 0.d0 .or. delta_e_final == 0.d0)then -!if(delta_e_final == 0.d0)then - call debug_det(det_1,N_int) - call debug_det(det_2,N_int) - print*, 'n_holes_act,n_particles_act' - print*, n_holes_act,n_particles_act - print*, 'delta_e_act,delta_e_inactive,delta_e_vir' - print*, delta_e_act,delta_e_inactive,delta_e_virt - delta_e_final = -1000.d0 + do i_state = 1, n_states + delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) + enddo end diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 6619b125..5cd09aa2 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -7,12 +7,6 @@ use bitmasks integer :: i number_of_holes = 0 - do i = 1, N_int - number_of_holes = number_of_holes & - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,1),iand(key_in(i,1),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) )& - + popcnt( xor( iand(reunion_of_core_inact_bitmask(i,1), xor(key_in(i,2),iand(key_in(i,2),cas_bitmask(i,1,1)))), reunion_of_core_inact_bitmask(i,1)) ) - enddo - return if(N_int == 1)then number_of_holes = number_of_holes & + popcnt( xor( iand(reunion_of_core_inact_bitmask(1,1), xor(key_in(1,1),iand(key_in(1,1),cas_bitmask(1,1,1)))), reunion_of_core_inact_bitmask(1,1)) )& diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 2253c33c..118bbdf7 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -1,5 +1,22 @@ - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num) ] + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_average, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_average, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: i + + one_body_dm_mo_alpha_average = 0.d0 + one_body_dm_mo_beta_average = 0.d0 + do i = 1,N_states + one_body_dm_mo_alpha_average(:,:) += one_body_dm_mo_alpha(:,:,i) * state_average_weight(i) + one_body_dm_mo_beta_average(:,:) += one_body_dm_mo_beta(:,:,i) * state_average_weight(i) + enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none BEGIN_DOC ! Alpha and beta one-body density matrix for each state @@ -11,36 +28,31 @@ double precision :: phase integer :: h1,h2,p1,p2,s1,s2, degree integer :: exc(0:2,2,2),n_occ(2) - double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) + double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) - if(only_single_double_dm)then - print*,'ONLY DOUBLE DM' - one_body_dm_mo_alpha = one_body_single_double_dm_mo_alpha - one_body_dm_mo_beta = one_body_single_double_dm_mo_beta - else one_body_dm_mo_alpha = 0.d0 one_body_dm_mo_beta = 0.d0 !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & !$OMP tmp_a, tmp_b, n_occ)& - !$OMP SHARED(psi_det,psi_coef,N_int,N_states,state_average_weight,elec_alpha_num,& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,& !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& !$OMP mo_tot_num) - allocate(tmp_a(mo_tot_num_align,mo_tot_num), tmp_b(mo_tot_num_align,mo_tot_num) ) + allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) ) tmp_a = 0.d0 tmp_b = 0.d0 !$OMP DO SCHEDULE(dynamic) do k=1,N_det call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) * state_average_weight(m) + ck = psi_coef(k,m)*psi_coef(k,m) do l=1,elec_alpha_num j = occ(l,1) - tmp_a(j,j) += ck + tmp_a(j,j,m) += ck enddo do l=1,elec_beta_num j = occ(l,2) - tmp_b(j,j) += ck + tmp_b(j,j,m) += ck enddo enddo do l=1,k-1 @@ -51,28 +63,27 @@ call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase * state_average_weight(m) + ckl = psi_coef(k,m) * psi_coef(l,m) * phase if (s1==1) then - tmp_a(h1,p1) += ckl - tmp_a(p1,h1) += ckl + tmp_a(h1,p1,m) += ckl + tmp_a(p1,h1,m) += ckl else - tmp_b(h1,p1) += ckl - tmp_b(p1,h1) += ckl + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl endif enddo enddo enddo !$OMP END DO NOWAIT !$OMP CRITICAL - one_body_dm_mo_alpha = one_body_dm_mo_alpha + tmp_a + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) !$OMP END CRITICAL !$OMP CRITICAL - one_body_dm_mo_beta = one_body_dm_mo_beta + tmp_b + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) !$OMP END CRITICAL deallocate(tmp_a,tmp_b) !$OMP END PARALLEL - endif END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] @@ -163,7 +174,7 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo, (mo_tot_num_align,mo_tot_num) BEGIN_DOC ! One-body density matrix END_DOC - one_body_dm_mo = one_body_dm_mo_alpha + one_body_dm_mo_beta + one_body_dm_mo = one_body_dm_mo_alpha_average + one_body_dm_mo_beta_average END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,mo_tot_num) ] @@ -171,7 +182,7 @@ BEGIN_PROVIDER [ double precision, one_body_spin_density_mo, (mo_tot_num_align,m BEGIN_DOC ! rho(alpha) - rho(beta) END_DOC - one_body_spin_density_mo = one_body_dm_mo_alpha - one_body_dm_mo_beta + one_body_spin_density_mo = one_body_dm_mo_alpha_average - one_body_dm_mo_beta_average END_PROVIDER subroutine set_natural_mos @@ -246,8 +257,8 @@ END_PROVIDER do l = 1, ao_num do i = 1, mo_tot_num do j = 1, mo_tot_num - mo_alpha = one_body_dm_mo_alpha(j,i) - mo_beta = one_body_dm_mo_beta(j,i) + mo_alpha = one_body_dm_mo_alpha_average(j,i) + mo_beta = one_body_dm_mo_beta_average(j,i) ! if(dabs(dm_mo).le.1.d-10)cycle one_body_dm_ao_alpha(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_alpha one_body_dm_ao_beta(l,k) += mo_coef(k,i) * mo_coef(l,j) * mo_beta From d5a76190ca33a238a6364f0f8d3fcccbd3e3e590 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 7 Sep 2016 14:49:52 +0200 Subject: [PATCH 14/32] Good Dyall Hamiltonian --- config/ifort.cfg | 2 +- plugins/Full_CI/NEEDED_CHILDREN_MODULES | 2 +- plugins/Full_CI/micro_pt2.irp.f | 42 ------------------------ plugins/MRPT_Utils/MRPT_Utils.main.irp.f | 4 +-- plugins/MRPT_Utils/energies_cas.irp.f | 38 ++++++++++----------- plugins/MRPT_Utils/excitations_cas.irp.f | 18 ++++++++++ plugins/Perturbation/pt2_new.irp.f | 10 ------ plugins/loc_cele/NEEDED_CHILDREN_MODULES | 2 +- plugins/loc_cele/loc_cele.irp.f | 9 ++--- src/Determinants/diagonalize_CI.irp.f | 2 ++ 10 files changed, 49 insertions(+), 80 deletions(-) delete mode 100644 plugins/Full_CI/micro_pt2.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index a738a83c..da414912 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index 04ce9e78..a1e61718 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full +Perturbation Selectors_full Generators_full MRPT_Utils diff --git a/plugins/Full_CI/micro_pt2.irp.f b/plugins/Full_CI/micro_pt2.irp.f deleted file mode 100644 index d78a942d..00000000 --- a/plugins/Full_CI/micro_pt2.irp.f +++ /dev/null @@ -1,42 +0,0 @@ -program micro_pt2 - implicit none - BEGIN_DOC -! Helper program to compute the PT2 in distributed mode. - END_DOC - - read_wf = .False. - SOFT_TOUCH read_wf - call provide_everything - call switch_qp_run_to_master - call run_wf - -end - -subroutine provide_everything - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context -end - -subroutine run_wf - use f77_zmq - implicit none - - integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - print *, 'Getting wave function' - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - - call zmq_get_psi(zmq_to_qp_run_socket, 1) - call write_double(6,ci_energy,'Energy') - zmq_state = 'h_apply_fci_pt2' - - call provide_everything - integer :: rc, i - - !$OMP PARALLEL PRIVATE(i) - i = omp_get_thread_num() - call H_apply_FCI_PT2_slave_tcp(i) - !$OMP END PARALLEL - - -end diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f index 9ee42820..13c8228a 100644 --- a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -16,8 +16,8 @@ subroutine routine_3 print *, 'N_det = ', N_det print *, 'N_states = ', N_states print *, 'PT2 = ', second_order_pt_new(1) - print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+second_order_pt_new(1) + print *, 'E = ', CI_energy(1) + print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index 8644bfa8..fb52a719 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] integer :: i double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_det,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -33,8 +33,8 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1,N_states @@ -71,8 +71,8 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states @@ -115,8 +115,8 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1 , N_states @@ -164,8 +164,8 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & @@ -210,8 +210,8 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states @@ -265,8 +265,8 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo @@ -325,8 +325,8 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states @@ -384,8 +384,8 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states @@ -443,8 +443,8 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index acd70e3e..5024967d 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -129,6 +129,24 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj(jorb,iorb) enddo enddo + + ! alpha - core-act + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo + + ! beta - core-act + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo end diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f index 29821a74..efe7f375 100644 --- a/plugins/Perturbation/pt2_new.irp.f +++ b/plugins/Perturbation/pt2_new.irp.f @@ -42,17 +42,7 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij call get_delta_e_dyall(keys(1,1,i_in_key),key,delta_e_final) - if(delta_e_final == 0.d0)then - call get_delta_e_dyall_verbose(keys(1,1,i_in_key),key,delta_e_final) - call debug_det(keys(1,1,i_in_key),N_int) - call debug_det(key,N_int) - stop - endif coef_pert += coef(i_in_coef,1)*hij / delta_e_final -! print*, 'delta_e_final = ',delta_e_final - -! call i_H_j(key,key,Nint,hjj) -! coef_pert += coef(i_in_coef,1)*hij / (CI_electronic_energy(1) - hjj) enddo if (coef_pert * i_H_psi_array(1) > 0.d0)then print*, coef_pert * i_H_psi_array(1) diff --git a/plugins/loc_cele/NEEDED_CHILDREN_MODULES b/plugins/loc_cele/NEEDED_CHILDREN_MODULES index 6731bb70..fbba67dd 100644 --- a/plugins/loc_cele/NEEDED_CHILDREN_MODULES +++ b/plugins/loc_cele/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MO_Basis \ No newline at end of file +MO_Basis Integrals_Bielec Bitmask diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 8a110c05..bb4509e0 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -92,7 +92,7 @@ - nrot(1) = 6 ! number of orbitals to be localized + nrot(1) = 2 ! number of orbitals to be localized integer :: index_rot(1000,1) @@ -101,9 +101,10 @@ cmoref = 0.d0 irot = 0 - do i=1,nrot(1) - irot(i,1) = 19+i - enddo + irot(1,1) = 11 + irot(2,1) = 12 + cmoref(15,1,1) = 1.d0 ! + cmoref(14,2,1) = 1.d0 ! ! ESATRIENE with 3 bonding and anti bonding orbitals ! First bonding orbital for esa diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f index b533bed2..7a506435 100644 --- a/src/Determinants/diagonalize_CI.irp.f +++ b/src/Determinants/diagonalize_CI.irp.f @@ -91,6 +91,8 @@ END_PROVIDER do j=1,N_det call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) s2_eigvalues(j) = s2 + print*, 's2 in lapack',s2 + print*, eigenvalues(j) ! Select at least n_states states with S^2 values closed to "expected_s2" if(dabs(s2-expected_s2).le.0.3d0)then i_state +=1 From a6dced35ac9901815e63a7c729c7bd310725d12d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 8 Sep 2016 12:28:02 +0200 Subject: [PATCH 15/32] strange things in MRPT --- plugins/MRPT_Utils/excitations_cas.irp.f | 153 ++++++++++------------- plugins/MRPT_Utils/psi_active_prov.irp.f | 3 + 2 files changed, 66 insertions(+), 90 deletions(-) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 5024967d..d329831f 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -97,16 +97,31 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) integer :: occ(Nint*bit_kind_size,2) integer :: elec_num_tab_local(2) + double precision :: core_act + double precision :: alpha_alpha + double precision :: alpha_beta + double precision :: beta_beta + double precision :: mono_elec + core_act = 0.d0 + alpha_alpha = 0.d0 + alpha_beta = 0.d0 + beta_beta = 0.d0 + mono_elec = 0.d0 + diag_H_mat_elem_no_elec_check = 0.d0 call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) ! alpha - alpha +! print*, 'elec_num_tab_local(1)',elec_num_tab_local(1) +! print*, 'elec_num_tab_local(2)',elec_num_tab_local(2) do i = 1, elec_num_tab_local(1) iorb = occ(i,1) diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) + alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb) enddo enddo @@ -114,9 +129,11 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) do i = 1, elec_num_tab_local(2) iorb = occ(i,2) diag_H_mat_elem_no_elec_check += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj_anti(jorb,iorb) + beta_beta += mo_bielec_integral_jj_anti(jorb,iorb) enddo enddo @@ -127,8 +144,10 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) do j = 1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check += mo_bielec_integral_jj(jorb,iorb) + alpha_beta += mo_bielec_integral_jj(jorb,iorb) enddo enddo + ! alpha - core-act do i = 1, elec_num_tab_local(1) @@ -136,6 +155,7 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo @@ -145,103 +165,55 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo - -end +! print*,'core_act = ',core_act +! print*,'alpha_alpha = ',alpha_alpha +! print*,'alpha_beta = ',alpha_beta +! print*,'beta_beta = ',beta_beta +! print*,'mono_elec = ',mono_elec -subroutine a_operator_no_check(iorb,ispin,key,hjj,Nint,na,nb) - use bitmasks - implicit none - BEGIN_DOC - ! Needed for diag_H_mat_elem - END_DOC - integer, intent(in) :: iorb, ispin, Nint - integer, intent(inout) :: na, nb - integer(bit_kind), intent(inout) :: key(Nint,2) - double precision, intent(inout) :: hjj - - integer :: occ(Nint*bit_kind_size,2) - integer :: other_spin - integer :: k,l,i - integer :: tmp(2) - - ASSERT (iorb > 0) - ASSERT (ispin > 0) - ASSERT (ispin < 3) - ASSERT (Nint > 0) - - k = ishft(iorb-1,-bit_kind_shift)+1 - ASSERT (k > 0) - l = iorb - ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibclr(key(k,ispin),l) - other_spin = iand(ispin,1)+1 - - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key, occ, tmp, Nint) - na = na-1 - - hjj = hjj - mo_mono_elec_integral(iorb,iorb) - - ! Same spin - do i=1,na - hjj = hjj - mo_bielec_integral_jj_anti(occ(i,ispin),iorb) +! do i = 1, n_core_inact_orb +! iorb = list_core_inact(i) +! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) +! enddo + + +!!!!!!!!!!!! +return +!!!!!!!!!!!! + + + ! alpha - alpha + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) + enddo enddo - - ! Opposite spin - do i=1,nb - hjj = hjj - mo_bielec_integral_jj(occ(i,other_spin),iorb) + + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo + + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) + enddo enddo end - -subroutine ac_operator_no_check(iorb,ispin,key,hjj,Nint,na,nb) - use bitmasks - implicit none - BEGIN_DOC - ! Needed for diag_H_mat_elem - END_DOC - integer, intent(in) :: iorb, ispin, Nint - integer, intent(inout) :: na, nb - integer(bit_kind), intent(inout) :: key(Nint,2) - double precision, intent(inout) :: hjj - - integer :: occ(Nint*bit_kind_size,2) - integer :: other_spin - integer :: k,l,i - - ASSERT (iorb > 0) - ASSERT (ispin > 0) - ASSERT (ispin < 3) - ASSERT (Nint > 0) - - integer :: tmp(2) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key, occ, tmp, Nint) - - k = ishft(iorb-1,-bit_kind_shift)+1 - ASSERT (k > 0) - l = iorb - ishft(k-1,bit_kind_shift)-1 - key(k,ispin) = ibset(key(k,ispin),l) - other_spin = iand(ispin,1)+1 - - hjj = hjj + mo_mono_elec_integral(iorb,iorb) - - print*,'na.nb = ',na,nb - ! Same spin - do i=1,na - hjj = hjj + mo_bielec_integral_jj_anti(occ(i,ispin),iorb) - enddo - - ! Opposite spin - do i=1,nb - hjj = hjj + mo_bielec_integral_jj(occ(i,other_spin),iorb) - enddo - na = na+1 -end - - subroutine i_H_j_dyall(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -399,7 +371,8 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) ! call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij_bis) -! print*, hij_bis,hij +! print*, 'i,j',i,j +! print*, hij accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 8d705deb..cbc44e32 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -8,11 +8,14 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] use bitmasks integer :: i,j,k,l provide cas_bitmask + print*, 'psi_active ' do i = 1, N_det do j = 1, N_int psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) enddo + + call debug_det(psi_active(1,1,i),N_int) enddo END_PROVIDER From 9121d1a60476bef94a10497ee399e0342a8d597c Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 8 Sep 2016 15:48:52 +0200 Subject: [PATCH 16/32] corrected bugs in fock for MRPT --- plugins/MRPT_Utils/fock_like_operators.irp.f | 10 +++---- plugins/MRPT_Utils/mrpt_utils.irp.f | 29 ++++++++++++++------ 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index 5900516e..2074daf6 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -11,8 +11,6 @@ accu = 0.d0 i_inact_core_orb = list_core_inact(i) do j = 1, n_core_inact_orb -! do j = 1, elec_alpha_num -! j_inact_core_orb = j j_inact_core_orb = list_core_inact(j) accu += 2.d0 * mo_bielec_integral_jj(i_inact_core_orb,j_inact_core_orb) & - mo_bielec_integral_jj_exchange(i_inact_core_orb,j_inact_core_orb) @@ -84,8 +82,8 @@ accu_exchange(2) += 2.d0 * nb * exchange enddo enddo - fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb + accu_exchange(1) - fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb + accu_exchange(2) + fock_core_inactive_from_act(i_inact_core_orb,1,i_state) = accu_coulomb - accu_exchange(1) + fock_core_inactive_from_act(i_inact_core_orb,2,i_state) = accu_coulomb - accu_exchange(2) enddo enddo END_PROVIDER @@ -131,8 +129,8 @@ accu_exchange(2) += 2.d0 * nb * exchange enddo enddo - fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb + accu_exchange(1) - fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb + accu_exchange(2) + fock_virt_from_act(i_virt_orb,1,i_state) = accu_coulomb - accu_exchange(1) + fock_virt_from_act(i_virt_orb,2,i_state) = accu_coulomb - accu_exchange(2) enddo enddo END_PROVIDER diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 3b832b58..e298ae67 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -130,19 +130,30 @@ print*, '2h1p = ',accu ! 2h2p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) - accu = 0.d0 +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +!enddo +!second_order_pt_new_2h2p(i_state) = accu(i_state) +!enddo +!print*, '2h2p = ',accu + + double precision :: contrib_2h2p(N_states) + call give_2h2p(contrib_2h2p) do i_state = 1, N_states do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo + delta_ij(i,i,i_state) += contrib_2h2p(i_state) enddo - second_order_pt_new_2h2p(i_state) = accu(i_state) + second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) enddo - print*, '2h2p = ',accu + print*, '2h2p = ',contrib_2h2p(1) + ! total accu = 0.d0 From 9a152ca037c246284c494f5c619e154124a7ce82 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 10 Sep 2016 12:32:33 +0200 Subject: [PATCH 17/32] Beginning new way for computing pt2 --- config/ifort.cfg | 2 +- plugins/MRPT_Utils/excitations_cas.irp.f | 2 -- plugins/MRPT_Utils/mrpt_dress.irp.f | 15 +++++++++++++++ plugins/MRPT_Utils/psi_active_prov.irp.f | 6 ++++-- src/Determinants/slater_rules.irp.f | 12 ++++++++++++ 5 files changed, 32 insertions(+), 5 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index da414912..a738a83c 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 5024967d..03571d5d 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -398,8 +398,6 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe do j = 1, ndet if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) -! call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij_bis) -! print*, hij_bis,hij accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 512158cf..0c8ec98c 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -44,6 +44,8 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: N_miniList, leng double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j + double precision :: phase_array(N_det),phase + integer :: exc(0:2,2,2),degree leng = max(N_det_generators, N_det) @@ -74,11 +76,14 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip ! double precision :: ihpsi0,coef_pert ! ihpsi0 = 0.d0 ! coef_pert = 0.d0 + phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e) call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) hij_array(index_i) = hialpha + call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) +! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -90,6 +95,16 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) +! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) +! if(index_j.ne.index_i)then +! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then +! print*, phase_array(index_j) , phase_array(index_i) ,phase +! call debug_det(psi_det(1,1,index_i),N_int) +! call debug_det(psi_det(1,1,index_j),N_int) +! call debug_det(tq(1,1,i_alpha),N_int) +! stop +! endif +! endif do i_state=1,N_states ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 8d705deb..6fb8219e 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -180,6 +180,8 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) double precision :: delta_e_inactive(N_states) integer :: i_hole_inact + + call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) delta_e_inactive = 0.d0 do i = 1, n_holes_spin(1) @@ -429,7 +431,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) do i_state = 1, n_states - delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) - enddo + delta_e_final(i_state) = delta_e_act(i_state) + delta_e_inactive(i_state) - delta_e_virt(i_state) + enddo end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 735ca8e7..f70fa594 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -749,6 +749,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha + print*,'phase hij = ',phase hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,1), & exc(2,1,1), & @@ -759,6 +760,17 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) + print*,get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) + print*,get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) + else if (exc(0,1,2) == 2) then ! Double beta hij = phase*(get_mo_bielec_integral_schwartz( & From 156cbbdb27cb910f5fc0f9c5cb7ea1bfa79ac004 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 10 Sep 2016 16:51:09 +0200 Subject: [PATCH 18/32] New way pt2 is ok for 2h1p --- plugins/MRPT_Utils/new_way.irp.f | 192 ++++++++++++++++++++++++++++ src/Determinants/slater_rules.irp.f | 91 +++++++++++++ 2 files changed, 283 insertions(+) create mode 100644 plugins/MRPT_Utils/new_way.irp.f diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f new file mode 100644 index 00000000..83831e41 --- /dev/null +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -0,0 +1,192 @@ +subroutine give_2h1p_contrib(matrix_2h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase +!matrix_2h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do j = 1, n_inact_orb ! Second inactive + jorb = list_inact(j) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + enddo + + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,3) + + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) + if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + aorb = list_act(a) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation inactive -- > active + call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin + call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = 0.0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0 + enddo + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + do istate = 1, N_states + delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & + - fock_virt_total_spin_trace(rorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) & + + fock_core_inactive_total_spin_trace(jorb,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif +!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet +!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) + enddo + + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 1 + else + ! Mono beta + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,2)) !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 2 + endif + else + index_orb_act_mono(idx(jdet),1) = -1 + endif + enddo + + integer :: kspin + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > + + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + double precision :: hja + ! you determine the interaction between the excited determinant and the other parent | Jdet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > + ! hja = < det_tmp | H | Jdet > + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,2) - active_int(borb,1) ) + else + hja = phase * active_int(borb,1) + endif + + do istate = 1, N_states + matrix_2h1p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate) + enddo + enddo ! ispin + + else + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do ispin = 1, 2 + do kspin = 1, 2 + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + do istate = 1, N_states + matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin) + enddo + enddo + enddo + enddo + + endif + + enddo + enddo + enddo + enddo + enddo + + + + + +end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index f70fa594..0357fb88 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1237,6 +1237,97 @@ subroutine i_H_psi_SC2_verbose(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_a print*,'------' end +subroutine get_excitation_degree_vector_mono(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants and return only the mono excitations + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + + integer :: i,l,d,m + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (d > 2) then + cycle + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (d > 2) then + cycle + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (d > 2) then + cycle + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = 0 + !DIR$ LOOP COUNT MIN(4) + do m=1,Nint + d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + + popcnt(xor( key1(m,2,i), key2(m,2))) + enddo + if (d > 2) then + cycle + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) From 0ebfef52330f6cac74d251c75407902fb9029659 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 11 Sep 2016 13:13:46 +0200 Subject: [PATCH 19/32] new way works for the 1h2p --- plugins/MRPT_Utils/new_way.irp.f | 205 ++++++++++++++++++++++- plugins/MRPT_Utils/psi_active_prov.irp.f | 4 +- src/Determinants/slater_rules.irp.f | 12 ++ 3 files changed, 217 insertions(+), 4 deletions(-) diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index 83831e41..8cf6ec5f 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -112,8 +112,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a_{b} + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a_{b} index_orb_act_mono(idx(jdet),3) = 1 else ! Mono beta @@ -189,4 +189,205 @@ subroutine give_2h1p_contrib(matrix_2h1p) +end + + +subroutine give_1h2p_contrib(matrix_1h2p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) + integer :: i,v,r,a,b + integer :: iorb, vorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase +!matrix_1h2p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do v = 1, n_virt_orb ! First virtual + vorb = list_virt(v) + do r = 1, n_virt_orb ! Second virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + enddo + + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,3) + + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) + do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) + do a = 1, n_act_orb ! First active + aorb = list_act(a) + if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation active -- > virtual + call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin + call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = 0.0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate) = 0.d0 + enddo + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) + enddo + + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + do istate = 1, N_states + delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & + - fock_virt_total_spin_trace(rorb,istate) & + - fock_virt_total_spin_trace(vorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif +!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet +!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) + enddo + + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 1 + else + ! Mono beta + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 2 + endif + else + index_orb_act_mono(idx(jdet),1) = -1 + endif + enddo + + integer :: kspin + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > + + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + double precision :: hja + ! you determine the interaction between the excited determinant and the other parent | Jdet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > + ! hja = < det_tmp | H | Jdet > + + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,1) - active_int(borb,2) ) + else + hja = phase * active_int(borb,1) + endif + + do istate = 1, N_states + matrix_1h2p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate) + enddo + enddo ! ispin + + else + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + do ispin = 1, 2 + do kspin = 1, 2 + do a = 1, n_act_orb ! First active + aorb = list_act(a) + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + do istate = 1, N_states + matrix_1h2p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate) * perturb_dets_hij(a,kspin,ispin) + enddo + enddo + enddo + enddo + + endif + + enddo + enddo + enddo + enddo + enddo + + + + + end diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index da13ec44..5a60d093 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -8,14 +8,14 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] use bitmasks integer :: i,j,k,l provide cas_bitmask - print*, 'psi_active ' +!print*, 'psi_active ' do i = 1, N_det do j = 1, N_int psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) enddo - call debug_det(psi_active(1,1,i),N_int) +! call debug_det(psi_active(1,1,i),N_int) enddo END_PROVIDER diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 0357fb88..cb4e12b4 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -773,6 +773,18 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) else if (exc(0,1,2) == 2) then ! Double beta + print*,'phase hij = ',phase + print*, get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map ) + print*, get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) + hij = phase*(get_mo_bielec_integral_schwartz( & exc(1,1,2), & exc(2,1,2), & From 8a94e0e9721af070f77c4809e549540ab3b77913 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 15 Sep 2016 18:34:07 +0200 Subject: [PATCH 20/32] working on second order corrections with multi parentage --- .../new_way_second_order_coef.irp.f | 710 ++++++++++++++++++ plugins/MRPT_Utils/print_1h2p.irp.f | 31 + src/Determinants/create_excitations.irp.f | 2 + src/Determinants/slater_rules.irp.f | 156 ++++ 4 files changed, 899 insertions(+) create mode 100644 plugins/MRPT_Utils/new_way_second_order_coef.irp.f create mode 100644 plugins/MRPT_Utils/print_1h2p.irp.f diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f new file mode 100644 index 00000000..d9772675 --- /dev/null +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -0,0 +1,710 @@ +subroutine give_2h1p_contrib_sec_order(matrix_2h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,3) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer(bit_kind) :: det_tmp_j(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase +!matrix_2h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do j = 1, n_inact_orb ! Second inactive + jorb = list_inact(j) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + perturb_dets_phase(a,1,1) = -1000.d0 + perturb_dets_phase(a,1,2) = -1000.d0 + perturb_dets_phase(a,2,2) = -1000.d0 + perturb_dets_phase(a,2,1) = -1000.d0 + enddo + + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,3) + + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) + if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + aorb = list_act(a) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation inactive -- > active + call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin + call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = -1000.d0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + do istate = 1, N_states + delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & + - fock_virt_total_spin_trace(rorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) & + + fock_core_inactive_total_spin_trace(jorb,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,2) - active_int(a,1) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif +!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet +!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,1) = perturb_dets_hij(a,jspin,ispin) / delta_e(a,jspin,istate) + enddo + + enddo + enddo + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!! Second order coefficient : interactions between the perturbers throw the active space + do a = 1, n_act_orb + do jspin = 1, 2 + do ispin = 1, 2 + if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle + ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = iand(perturb_dets(inint,1,a,jspin,ispin),cas_bitmask(inint,1,1)) + det_tmp(inint,2) = iand(perturb_dets(inint,2,a,jspin,ispin),cas_bitmask(inint,1,1)) + enddo + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + do b = 1, n_act_orb + do kspin = jspin , jspin + integer :: degree_scalar + if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp_j(inint,1) = iand(perturb_dets(inint,1,b,kspin,ispin),cas_bitmask(inint,1,1)) + det_tmp_j(inint,2) = iand(perturb_dets(inint,2,b,kspin,ispin),cas_bitmask(inint,1,1)) + enddo + call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) + if (degree_scalar > 2 .or. degree_scalar == 0)cycle + ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > +! print*, '**********************' +! integer(bit_kind) :: det_bis(N_int,2) +! call debug_det(det_tmp,N_int) +! call debug_det(det_tmp_j,N_int) +! do inint = 1, N_int +! det_bis(inint,1) = perturb_dets(inint,1,b,kspin,ispin) +! det_bis(inint,2) = perturb_dets(inint,2,b,kspin,ispin) +! enddo +! call debug_det(det_bis,N_int) + call i_H_j_dyall(det_tmp,det_tmp_j,N_int,hij) + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & + * hij / delta_e(a,jspin,istate) + if(dabs(hij).gt.0.01d0)then + print*,degree_scalar, hij + print*, coef_perturb_from_idet(b,kspin,ispin,istate,1)* hij / delta_e(a,jspin,istate),coef_perturb_from_idet(a,jspin,ispin,istate,1) + + endif + enddo + enddo + enddo + enddo + enddo + enddo + do a = 1, n_act_orb + do jspin = 1, 2 + do ispin = 1, 2 + if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle + do istate = 1, N_states +! print*, coef_perturb_from_idet(a,jspin,ispin,istate,1),coef_perturb_from_idet(a,jspin,ispin,istate,2) + coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(a,jspin,ispin,istate,1) + enddo + enddo + enddo + enddo +! stop +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 1 + else + ! Mono beta + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,2)) !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 2 + endif + else + index_orb_act_mono(idx(jdet),1) = -1 + endif + enddo + + integer :: kspin + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > + + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + double precision :: hja + ! you determine the interaction between the excited determinant and the other parent | Jdet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > + ! hja = < det_tmp | H | Jdet > + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,2) - active_int(borb,1) ) + else + hja = phase * active_int(borb,1) + endif + + do istate = 1, N_states + matrix_2h1p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate,2) + enddo + enddo ! ispin + + else + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do ispin = 1, 2 + do kspin = 1, 2 + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + do istate = 1, N_states + matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate,2) * perturb_dets_hij(a,kspin,ispin) + enddo + enddo + enddo + enddo + + endif + + enddo + enddo + enddo + enddo + enddo + + + + + +end + + +subroutine give_1h2p_contrib_sec_order(matrix_1h2p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) + integer :: i,v,r,a,b + integer :: iorb, vorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states) + double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,2) + logical :: already_generated(n_act_orb,2,2) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer(bit_kind) :: det_tmp_j(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + double precision :: accu_contrib + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,6) + double precision :: delta_e_inactive_virt(N_states) + integer :: kspin + double precision :: delta_e_ja(N_states) + double precision :: hja + double precision :: contrib_hij + accu_contrib = 0.d0 +!matrix_1h2p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do v = 1, n_virt_orb ! First virtual + vorb = list_virt(v) + do r = 1, n_virt_orb ! Second virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + perturb_dets_phase(a,1,1) = -1000.d0 + perturb_dets_phase(a,1,2) = -1000.d0 + perturb_dets_phase(a,2,2) = -1000.d0 + perturb_dets_phase(a,2,1) = -1000.d0 + already_generated(a,1,1) = .False. + already_generated(a,1,2) = .False. + already_generated(a,2,2) = .False. + already_generated(a,2,1) = .False. + enddo + + + do istate = 1, N_states + delta_e_inactive_virt(istate) = & + - fock_virt_total_spin_trace(rorb,istate) & + - fock_virt_total_spin_trace(vorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) + do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) + do a = 1, n_act_orb ! First active + aorb = list_act(a) + do istate = 1, N_states + perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation active -- > virtual + call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin + call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = -1000.0d0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) + enddo + + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + + do istate = 1, N_states + delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then +! print*, degree(jdet) + if(degree(jdet)==1)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 1 + else + ! Mono beta + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 2 + endif + else if(degree(jdet)==2)then + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 1 + ! Mono beta + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),6) = 2 + ! print*, '******************' + ! call debug_det(psi_det(1,1,idet),N_int) + ! call debug_det(psi_det(1,1,idx(jdet)),N_int) + ! print*, 'h1,p1,s1 = ',index_orb_act_mono(idx(jdet),1),index_orb_act_mono(idx(jdet),2), index_orb_act_mono(idx(jdet),3) + ! print*, 'h2,p2,s2 = ',index_orb_act_mono(idx(jdet),4),index_orb_act_mono(idx(jdet),5), index_orb_act_mono(idx(jdet),6) + ! print*, '******************' + ! pause + endif + else + index_orb_act_mono(idx(jdet),1) = -1 + endif + enddo + + + + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + if(degree(jdet) == 1)then + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > + + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + integer ::corb,dorb,i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hib , hab + double precision :: delta_e_ab(N_states) + double precision :: hib_test,hja_test,hab_test + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + do jspin = 1, 2 + if (jspin .ne. kspin)then + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! < idet | H | det_tmp > = phase * (ir|cv) +! call i_H_j(det_tmp,psi_det(1,1,idet),N_int,hib) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(corb,1) - active_int(corb,2)) + else + hib= phase * active_int(corb,1) + endif +! if(hib_test .ne. hib)then +! print*, 'hib_test .ne. hib' +! print*, hib, hib_test +! stop +! endif + + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle + + ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + call i_H_j(det_tmp_bis,det_tmp,N_int,hab) + ! < jdet | H | det_tmp_bis > = phase * (ir|cv) +! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(corb,1) - active_int(corb,2)) + else + hja= phase * (active_int(corb,1)) + endif +! if(hja_test .ne. hja)then +! print*, 'hja_test .ne. hja' +! print*, hja, hja_test +! stop +! endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) + matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & + hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! < det_tmp_bis | H | Jdet > + enddo + enddo ! corb + else + do corb = 1, n_act_orb + if(corb == aorb .or. corb == borb) cycle + if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) +! call i_H_j(det_tmp,psi_det(1,1,idet),N_int,hib) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(corb,1) - active_int(corb,2)) + else + hib= phase * active_int(corb,1) + endif +! if(hib_test .ne. hib)then +! print*, 'hib_test .ne. hib jspin == kspin' +! print*, hib, hib_test +! stop +! endif + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle +! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + call i_H_j(det_tmp_bis,det_tmp,N_int,hab) + ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) +! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(corb,1) - active_int(corb,2)) + else + hja= phase * (active_int(corb,1)) + endif +! if(hja_test .ne. hja)then +! print*, 'hja_test .ne. hja' +! print*, hja, hja_test +! stop +! endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) + matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & + hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! < det_tmp_bis | H | Jdet > + enddo + enddo ! corb + + endif + enddo ! jspin + enddo ! ispin + else +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of double excitations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! call debug_det(psi_det(1,1,idet),N_int) +! call debug_det(psi_det(1,1,idx(jdet)),N_int) +! pause + + + endif + + else + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + do ispin = 1, 2 + do kspin = 1, 2 + do a = 1, n_act_orb ! First active + if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) + do istate = 1, N_states +! matrix_1h2p(idet,idet,istate) += contrib_hij * delta_e(a,kspin,istate) +! perturb_dets_hpsi0(a,kspin,ispin,istate) += psi_coef(idet,istate) * perturb_dets_hij(a,kspin,ispin) +! coef_perturb_from_idet(a,kspin,ispin,istate,1) += psi_coef(idet,istate) & +! * perturb_dets_hij(a,kspin,ispin) * delta_e(a,kspin,istate) + enddo + enddo + enddo + enddo + + endif + + enddo + + + enddo + enddo + enddo + enddo + print* , 'accu_contrib = ',accu_contrib + + + + + +end + + + + + + + +! do a = 1, n_act_orb +! do jspin = 1, 2 +! do ispin = 1, 2 +! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle +! ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > +! do inint = 1, N_int +! det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) +! det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) +! enddo +! do istate = 1, N_states +! coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 +! enddo +! do b = 1, n_act_orb +! do kspin = jspin , jspin +! integer :: degree_scalar +! if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle +! do inint = 1, N_int +! det_tmp_j(inint,1) = perturb_dets(inint,1,b,kspin,ispin) +! det_tmp_j(inint,2) = perturb_dets(inint,2,b,kspin,ispin) +! enddo +! call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) +! if (degree_scalar > 2 .or. degree_scalar == 0)cycle +! ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > +! call i_H_j(det_tmp,det_tmp_j,N_int,hij) +! do istate = 1, N_states +! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & +! * hij / delta_e(a,jspin,istate) +! endif +! enddo +! enddo +! enddo +! enddo +! enddo +! enddo + + + +! do a = 1, n_act_orb +! do jspin = 1, 2 +! do ispin = 1, 2 +! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle +! ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > +! do inint = 1, N_int +! det_tmp(inint,1) = iand(perturb_dets(inint,1,a,jspin,ispin),cas_bitmask(inint,1,1)) +! det_tmp(inint,2) = iand(perturb_dets(inint,2,a,jspin,ispin),cas_bitmask(inint,1,1)) +! enddo +! do istate = 1, N_states +! coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 +! enddo +! do b = 1, n_act_orb +! do kspin = jspin , jspin +! integer :: degree_scalar +! if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle +! do inint = 1, N_int +! det_tmp_j(inint,1) = iand(perturb_dets(inint,1,b,kspin,ispin),cas_bitmask(inint,1,1)) +! det_tmp_j(inint,2) = iand(perturb_dets(inint,2,b,kspin,ispin),cas_bitmask(inint,1,1)) +! enddo +! call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) +! if (degree_scalar > 2 .or. degree_scalar == 0)cycle +! ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > +!! print*, '**********************' +!! integer(bit_kind) :: det_bis(N_int,2) +!! call debug_det(det_tmp,N_int) +!! call debug_det(det_tmp_j,N_int) +!! do inint = 1, N_int +!! det_bis(inint,1) = perturb_dets(inint,1,b,kspin,ispin) +!! det_bis(inint,2) = perturb_dets(inint,2,b,kspin,ispin) +!! enddo +!! call debug_det(det_bis,N_int) +! call i_H_j_dyall(det_tmp,det_tmp_j,N_int,hij) +! do istate = 1, N_states +! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & +! * hij / delta_e(a,jspin,istate) +! if(dabs(hij).gt.0.01d0)then +! print*,degree_scalar, hij +! print*, coef_perturb_from_idet(b,kspin,ispin,istate,1)* hij / delta_e(a,jspin,istate),coef_perturb_from_idet(a,jspin,ispin,istate,1) +! +! endif +! enddo +! enddo +! enddo +! enddo +! enddo +! enddo + +! do a = 1, n_act_orb +! do jspin = 1, 2 +! do ispin = 1, 2 +! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle +! do istate = 1, N_states +! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(a,jspin,ispin,istate,1) +! enddo +! enddo +! enddo +! enddo diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f new file mode 100644 index 00000000..7d2d6c23 --- /dev/null +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -0,0 +1,31 @@ +program print_1h2p + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + double precision,allocatable :: matrix_1h2p(:,:,:) + allocate (matrix_1h2p(N_det,N_det,N_states)) + integer :: i,j,istate + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 + enddo + enddo + enddo + call give_1h2p_contrib_sec_order(matrix_1h2p) + double precision :: accu + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*, 'accu', accu + + deallocate (matrix_1h2p) +end diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index a487cc23..b2a78216 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -31,6 +31,8 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) enddo if(n_elec_tmp .ne. elec_num)then + print*, n_elec_tmp,elec_num + call debug_det(key_in,N_int) i_ok = -1 endif end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index cb4e12b4..01ac8e8d 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1341,6 +1341,162 @@ subroutine get_excitation_degree_vector_mono(key1,key2,degree,Nint,sze,idx) idx(0) = l-1 end +subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants and return only the mono excitations + ! and the connections through exchange integrals + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + + integer :: i,l,d,m + integer :: exchange_1,exchange_2 + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,1),key2(1,2)))) + exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,2),key2(1,2)))) + & + popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,2),key2(2,2)))) + exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & + popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,1),key2(1,2)))) + & + popcnt(xor(iand(key1(2,1,i),key1(2,2,i)),iand(key2(2,1),key2(2,2)))) + & + popcnt(xor(iand(key1(3,1,i),key1(3,2,i)),iand(key2(3,1),key2(3,2)))) + exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & + popcnt(iand(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + & + popcnt(iand(xor(key1(3,1,i),key2(3,1)),xor(key1(3,2,i),key2(3,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = 0 + exchange_1 = 0 + !DIR$ LOOP COUNT MIN(4) + do m=1,Nint + d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + + popcnt(xor( key1(m,2,i), key2(m,2))) + exchange_1 = popcnt(xor(iand(key1(m,1,i),key1(m,2,i)),iand(key2(m,1),key2(m,2)))) + exchange_2 = popcnt(iand(xor(key1(m,1,i),key2(m,1)),xor(key1(m,2,i),key2(m,2)))) + enddo + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) use bitmasks From c2e04c647c9684b6ebcc7424e57dc75ed0b7ad3e Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 15 Sep 2016 21:21:41 +0200 Subject: [PATCH 21/32] Interaction with Dyall Hamiltonian for the third order --- .../new_way_second_order_coef.irp.f | 41 ++++++++++++------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index d9772675..ae356e11 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -291,6 +291,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: delta_e_ja(N_states) double precision :: hja double precision :: contrib_hij + double precision :: fock_operator_local(n_act_orb,n_act_orb,2) accu_contrib = 0.d0 !matrix_1h2p = 0.d0 @@ -393,6 +394,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS !!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator !!!!!!!!!!!!!!!!!!!!!!!!!!!! + integer :: i_hole,i_part do jdet = 1, idx(0) if(idx(jdet).ne.idet)then ! print*, degree(jdet) @@ -400,14 +402,26 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 1 + i_hole = list_act_reverse(exc(1,1,1)) !!! a_a + i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + kspin = 1 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator else ! Mono beta - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} - index_orb_act_mono(idx(jdet),3) = 2 + i_hole = list_act_reverse(exc(1,1,2)) !!! a_a + i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + kspin = 2 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif else if(degree(jdet)==2)then call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) @@ -419,13 +433,6 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} index_orb_act_mono(idx(jdet),6) = 2 - ! print*, '******************' - ! call debug_det(psi_det(1,1,idet),N_int) - ! call debug_det(psi_det(1,1,idx(jdet)),N_int) - ! print*, 'h1,p1,s1 = ',index_orb_act_mono(idx(jdet),1),index_orb_act_mono(idx(jdet),2), index_orb_act_mono(idx(jdet),3) - ! print*, 'h2,p2,s2 = ',index_orb_act_mono(idx(jdet),4),index_orb_act_mono(idx(jdet),5), index_orb_act_mono(idx(jdet),6) - ! print*, '******************' - ! pause endif else index_orb_act_mono(idx(jdet),1) = -1 @@ -481,9 +488,11 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - call i_H_j(det_tmp_bis,det_tmp,N_int,hab) +! call i_H_j(det_tmp_bis,det_tmp,N_int,hab) + hab = fock_operator_local(aorb,borb,kspin) * phase ! < jdet | H | det_tmp_bis > = phase * (ir|cv) ! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) @@ -533,8 +542,10 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} - call i_H_j(det_tmp_bis,det_tmp,N_int,hab) + hab = fock_operator_local(aorb,borb,kspin) * phase +! call i_H_j(det_tmp_bis,det_tmp,N_int,hab) ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) ! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) From fbb1409b352448641c7cc5122f94c7fce5beb671 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 18 Sep 2016 19:46:13 +0200 Subject: [PATCH 22/32] second order for 1h2p with mono excitations --- .../new_way_second_order_coef.irp.f | 603 ++++++++++-------- plugins/MRPT_Utils/print_1h2p.irp.f | 23 +- plugins/MRPT_Utils/second_order_new.irp.f | 303 +++++++++ src/Determinants/create_excitations.irp.f | 4 +- src/Determinants/slater_rules.irp.f | 174 ++++- 5 files changed, 837 insertions(+), 270 deletions(-) create mode 100644 plugins/MRPT_Utils/second_order_new.irp.f diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index ae356e11..5c4b562f 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -19,6 +19,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) double precision :: get_mo_bielec_integral_schwartz double precision :: active_int(n_act_orb,2) double precision :: hij,phase + integer :: index_orb_act_mono(N_det,6) !matrix_2h1p = 0.d0 elec_num_tab_local = 0 @@ -47,10 +48,12 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det,3) do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) +! if(idet == 81)then +! call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) +! endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -109,82 +112,52 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) enddo enddo enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!! Second order coefficient : interactions between the perturbers throw the active space - do a = 1, n_act_orb - do jspin = 1, 2 - do ispin = 1, 2 - if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle - ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = iand(perturb_dets(inint,1,a,jspin,ispin),cas_bitmask(inint,1,1)) - det_tmp(inint,2) = iand(perturb_dets(inint,2,a,jspin,ispin),cas_bitmask(inint,1,1)) - enddo - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 - enddo - do b = 1, n_act_orb - do kspin = jspin , jspin - integer :: degree_scalar - if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle - do inint = 1, N_int - det_tmp_j(inint,1) = iand(perturb_dets(inint,1,b,kspin,ispin),cas_bitmask(inint,1,1)) - det_tmp_j(inint,2) = iand(perturb_dets(inint,2,b,kspin,ispin),cas_bitmask(inint,1,1)) - enddo - call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) - if (degree_scalar > 2 .or. degree_scalar == 0)cycle - ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > -! print*, '**********************' -! integer(bit_kind) :: det_bis(N_int,2) -! call debug_det(det_tmp,N_int) -! call debug_det(det_tmp_j,N_int) -! do inint = 1, N_int -! det_bis(inint,1) = perturb_dets(inint,1,b,kspin,ispin) -! det_bis(inint,2) = perturb_dets(inint,2,b,kspin,ispin) -! enddo -! call debug_det(det_bis,N_int) - call i_H_j_dyall(det_tmp,det_tmp_j,N_int,hij) - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & - * hij / delta_e(a,jspin,istate) - if(dabs(hij).gt.0.01d0)then - print*,degree_scalar, hij - print*, coef_perturb_from_idet(b,kspin,ispin,istate,1)* hij / delta_e(a,jspin,istate),coef_perturb_from_idet(a,jspin,ispin,istate,1) - - endif - enddo - enddo - enddo - enddo - enddo - enddo - do a = 1, n_act_orb - do jspin = 1, 2 - do ispin = 1, 2 - if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle - do istate = 1, N_states -! print*, coef_perturb_from_idet(a,jspin,ispin,istate,1),coef_perturb_from_idet(a,jspin,ispin,istate,2) - coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(a,jspin,ispin,istate,1) - enddo - enddo - enddo - enddo -! stop + + !!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS !!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator -!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + integer :: i_hole,i_part + double precision :: hij_test + double precision :: fock_operator_local(n_act_orb,n_act_orb,2) do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,1)) !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 1 - else - ! Mono beta - index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_a - index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,1,2)) !!! a_{b} - index_orb_act_mono(idx(jdet),3) = 2 + if(degree(jdet)==1)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + i_hole = list_act_reverse(exc(1,1,1)) !!! a_a + i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + kspin = 1 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + else + ! Mono beta + i_hole = list_act_reverse(exc(1,1,2)) !!! a_a + i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + kspin = 2 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + endif + else if(degree(jdet)==2)then + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),3) = 1 + ! Mono beta + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + index_orb_act_mono(idx(jdet),6) = 2 endif else index_orb_act_mono(idx(jdet),1) = -1 @@ -192,56 +165,181 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) enddo integer :: kspin + integer :: corb,i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hib , hab , hja + double precision :: delta_e_ab(N_states) + double precision :: hib_test,hja_test,hab_test do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator - ! are connected by the presence of the perturbers determinants |det_tmp> - aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} - borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} - kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation - ! the determinants Idet and Jdet interact throw the following operator - ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS + if(degree(jdet) == 1)then + ! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + ! ! the determinants Idet and Jdet interact throw the following operator + ! ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > + do jspin = 1, 2 + if (jspin .ne. kspin)then - do ispin = 1, 2 ! you loop on all possible spin for the excitation - ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle + ! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! ! < idet | H | det_tmp > = phase * (ir|cv) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(corb,1) - active_int(corb,2)) + else + hib= phase * active_int(corb,1) + endif + + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - double precision :: hja - ! you determine the interaction between the excited determinant and the other parent | Jdet > - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > - ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,2) - active_int(borb,1) ) - else - hja = phase * active_int(borb,1) + ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + hab = (fock_operator_local(aorb,borb,kspin) ) * phase + if(isnan(hab))then + print*, '1' + stop + endif + ! < jdet | H | det_tmp_bis > = phase * (ir|cv) + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(corb,1) - active_int(corb,2)) + else + hja= phase * (active_int(corb,1)) + endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) + matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + & + hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! ! < det_tmp_bis | H | Jdet > + enddo + enddo ! corb + else + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + do corb = 1, n_act_orb + if(corb == aorb .or. corb == borb) cycle + if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle + ! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(corb,1) - active_int(corb,2)) + else + hib= phase * active_int(corb,1) + endif + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) +! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + hab = fock_operator_local(aorb,borb,kspin) * phase + if(isnan(hab))then + print*, '2' + stop + endif + ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(corb,1) - active_int(corb,2)) + else + hja= phase * (active_int(corb,1)) + endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) + matrix_2h1p(idx(jdet),idet,istate) = matrix_2h1p(idx(jdet),idet,istate) + & + hib / delta_e(corb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! ! < det_tmp_bis | H | Jdet > + enddo + enddo ! corb + endif + enddo + enddo + ! + else !! Double excitation operators + ! + if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then !! spin exchange + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + !!! ! first combination of spin :: | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > + jspin = 2 + aorb = index_orb_act_mono(idx(jdet),1) ! hole of the alpha electron + borb = index_orb_act_mono(idx(jdet),2) ! particle of the alpha electron + if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + enddo + ! | det_tmp > = a^{\dagger}_{aorb,beta} | Idet > + call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(aorb,1) - active_int(aorb,2)) + else + hib= phase * (active_int(aorb,1)) + endif + if(hib .ne. perturb_dets_hij(aorb,jspin,ispin))then + print*, 'pb !!' + print*, 'hib .ne. perturb_dets_hij(aorb,jspin,ispin)' + stop + endif + enddo !! ispin + + else if(index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then !! closed shell double excitation + + else + call get_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,degree_scalar,phase,N_int) + integer :: h1,h2,p1,p2,s1,s2 , degree_scalar + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + print*, h1,p1,h2,p2,s1,s2 + call debug_det(psi_det(1,1,idet),N_int) + call debug_det(psi_det(1,1,idx(jdet)),N_int) + print*, idet,idx(jdet) + print*, 'pb !!!!!!!!!!!!!' + call get_excitation_degree_vector_mono_or_exchange_verbose(psi_det(1,1,1),psi_det(1,1,idet),degree,N_int,N_det,idx) + stop + endif endif - do istate = 1, N_states - matrix_2h1p(idx(jdet),idet,istate) += hja * coef_perturb_from_idet(aorb,kspin,ispin,istate,2) - enddo - enddo ! ispin - else - ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations - ! - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - do ispin = 1, 2 - do kspin = 1, 2 - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - do a = 1, n_act_orb ! First active - do istate = 1, N_states - matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate,2) * perturb_dets_hij(a,kspin,ispin) - enddo - enddo - enddo - enddo - + !! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + !! + !! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + !!do ispin = 1, 2 + !! do kspin = 1, 2 + !! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + !! do a = 1, n_act_orb ! First active + !! do istate = 1, N_states + !! matrix_2h1p(idet,idet,istate) += coef_perturb_from_idet(a,kspin,ispin,istate,2) * perturb_dets_hij(a,kspin,ispin) + !! enddo + !! enddo + !! enddo + !!enddo + ! endif enddo @@ -261,8 +359,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) use bitmasks implicit none double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) - integer :: i,v,r,a,b - integer :: iorb, vorb, rorb, aorb, borb + integer :: i,v,r,a,b,c + integer :: iorb, vorb, rorb, aorb, borb,corb integer :: ispin,jspin integer :: idet,jdet integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) @@ -292,6 +390,9 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: hja double precision :: contrib_hij double precision :: fock_operator_local(n_act_orb,n_act_orb,2) + double precision :: fock_operator_from_core(n_act_orb,n_act_orb) + double precision :: fock_operator_from_virt(n_act_orb,n_act_orb) + double precision :: fock_operator_from_act(n_act_orb,n_act_orb,n_act_orb,2) accu_contrib = 0.d0 !matrix_1h2p = 0.d0 @@ -394,10 +495,11 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS !!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator !!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! integer :: i_hole,i_part + double precision :: hij_test do jdet = 1, idx(0) if(idx(jdet).ne.idet)then -! print*, degree(jdet) if(degree(jdet)==1)then call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then @@ -408,7 +510,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) index_orb_act_mono(idx(jdet),1) = i_hole index_orb_act_mono(idx(jdet),2) = i_part index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),N_int,hij) + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator else @@ -419,7 +521,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) index_orb_act_mono(idx(jdet),1) = i_hole index_orb_act_mono(idx(jdet),2) = i_part index_orb_act_mono(idx(jdet),3) = kspin - call i_H_j_dyall(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),N_int,hij) + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif @@ -439,11 +541,17 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) endif enddo + integer ::dorb,i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hib , hab + double precision :: delta_e_ab(N_states) + double precision :: hib_test,hja_test,hab_test do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - if(degree(jdet) == 1)then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS + if(degree(jdet) == 1)then ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator ! are connected by the presence of the perturbers determinants |det_tmp> aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} @@ -454,11 +562,6 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) do ispin = 1, 2 ! you loop on all possible spin for the excitation ! a^{\dagger}_r a_{i} (ispin) - integer ::corb,dorb,i_ok - integer(bit_kind) :: det_tmp_bis(N_int,2) - double precision :: hib , hab - double precision :: delta_e_ab(N_states) - double precision :: hib_test,hja_test,hab_test if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count do jspin = 1, 2 if (jspin .ne. kspin)then @@ -472,18 +575,12 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! < idet | H | det_tmp > = phase * (ir|cv) -! call i_H_j(det_tmp,psi_det(1,1,idet),N_int,hib) call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else hib= phase * active_int(corb,1) endif -! if(hib_test .ne. hib)then -! print*, 'hib_test .ne. hib' -! print*, hib, hib_test -! stop -! endif ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) @@ -491,21 +588,14 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} -! call i_H_j(det_tmp_bis,det_tmp,N_int,hab) - hab = fock_operator_local(aorb,borb,kspin) * phase + hab = (fock_operator_local(aorb,borb,kspin) ) * phase ! < jdet | H | det_tmp_bis > = phase * (ir|cv) -! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else hja= phase * (active_int(corb,1)) endif -! if(hja_test .ne. hja)then -! print*, 'hja_test .ne. hja' -! print*, hja, hja_test -! stop -! endif do istate = 1, N_states delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & @@ -519,7 +609,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) do corb = 1, n_act_orb if(corb == aorb .or. corb == borb) cycle if(perturb_dets_phase(corb,jspin,ispin).le.-100d0)cycle - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,kspin} a_{iorb,ispin} | Idet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{corb,jspin} a_{iorb,ispin} | Idet > do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) @@ -527,38 +617,25 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) enddo ! < idet | H | det_tmp > = phase * ( (ir|cv) - (iv|cr) ) -! call i_H_j(det_tmp,psi_det(1,1,idet),N_int,hib) call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) if(ispin == jspin)then hib= phase * (active_int(corb,1) - active_int(corb,2)) else hib= phase * active_int(corb,1) endif -! if(hib_test .ne. hib)then -! print*, 'hib_test .ne. hib jspin == kspin' -! print*, hib, hib_test -! stop -! endif ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} | det_tmp > call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) if(i_ok .ne. 1)cycle call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,kspin) * phase -! call i_H_j(det_tmp_bis,det_tmp,N_int,hab) ! < jdet | H | det_tmp_bis > = phase * ( (ir|cv) - (iv|cr) ) -! call i_H_j(det_tmp_bis,psi_det(1,1,idx(jdet)),N_int,hja) call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then hja= phase * (active_int(corb,1) - active_int(corb,2)) else hja= phase * (active_int(corb,1)) endif -! if(hja_test .ne. hja)then -! print*, 'hja_test .ne. hja' -! print*, hja, hja_test -! stop -! endif do istate = 1, N_states delta_e_ab(istate) = delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate) matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & @@ -574,14 +651,114 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) enddo ! ispin else !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of double excitations !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! call debug_det(psi_det(1,1,idet),N_int) -! call debug_det(psi_det(1,1,idx(jdet)),N_int) -! pause + ! a^{\dagger}_r a_{i} (ispin) + aorb = index_orb_act_mono(idx(jdet),4) ! hole of a beta electron + borb = index_orb_act_mono(idx(jdet),5) ! propagation of the hole :: mono excitation of alpha spin + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + ! ! first combination of spin :: | det_tmp > = a_{aorb,beta} | Idet > + jspin = 2 + if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + enddo + call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(borb,1) - active_int(borb,2)) + else + hib= phase * (active_int(borb,1)) + endif + if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then + call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),1,i_ok) + if(i_ok .ne. 1)then + call debug_det(psi_det(1,1,idet),N_int) + call debug_det(psi_det(1,1,idx(jdet)),N_int) + print*, aorb, borb + call debug_det(det_tmp,N_int) + stop + endif + else + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) + endif + + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + if (aorb == borb)then + print*, 'iahaha' + stop + endif + hab = fock_operator_local(aorb,borb,1) * phase + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(borb,1) - active_int(borb,2)) + else + hja= phase * (active_int(borb,1)) + endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate) + matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & + hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! < det_tmp_bis | H | Jdet > + enddo !! istate + + ! ! second combination of spin :: | det_tmp > = a_{aorb,alpha} | Idet > + jspin = 1 + if(perturb_dets_phase(aorb,jspin,ispin).le.-100d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,jspin,ispin) + enddo + call get_double_excitation(det_tmp,psi_det(1,1,idet),exc,phase,N_int) + if(ispin == jspin)then + hib= phase * (active_int(borb,1) - active_int(borb,2)) + else + hib= phase * (active_int(borb,1)) + endif + if( index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then + call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok) + if(i_ok .ne. 1)then + call debug_det(psi_det(1,1,idet),N_int) + call debug_det(psi_det(1,1,idx(jdet)),N_int) + print*, aorb, borb + call debug_det(det_tmp,N_int) + stop + endif + else + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok) + endif + + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} + hab = fock_operator_local(aorb,borb,2) * phase + call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) + if(ispin == jspin)then + hja= phase * (active_int(borb,1) - active_int(borb,2)) + else + hja= phase * (active_int(borb,1)) + endif + do istate = 1, N_states + delta_e_ab(istate) = delta_e(aorb,jspin,istate) + one_anhil_one_creat(borb,aorb,1,1,istate) + matrix_1h2p(idx(jdet),idet,istate) = matrix_1h2p(idx(jdet),idet,istate) + & + hib / delta_e(aorb,jspin,istate) * hab / delta_e_ab(istate) * hja + ! < det_tmp | H | Idet > / delta_E (Idet --> det_tmp ) + ! < det_tmp | H | det_tmp_bis > / delta_E (Idet --> det_tmp --> det_tmp_bis) + ! < det_tmp_bis | H | Jdet > + enddo !! istate + enddo !! ispin - endif + endif !! en of test if jdet is a single or a double excitation of type K_ab - else + else !! jdet is idet ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations ! ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > @@ -603,14 +780,13 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) endif - enddo + enddo !! jdet enddo enddo enddo enddo - print* , 'accu_contrib = ',accu_contrib @@ -618,104 +794,3 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) end - - - - - - -! do a = 1, n_act_orb -! do jspin = 1, 2 -! do ispin = 1, 2 -! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle -! ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > -! do inint = 1, N_int -! det_tmp(inint,1) = perturb_dets(inint,1,a,jspin,ispin) -! det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) -! enddo -! do istate = 1, N_states -! coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 -! enddo -! do b = 1, n_act_orb -! do kspin = jspin , jspin -! integer :: degree_scalar -! if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle -! do inint = 1, N_int -! det_tmp_j(inint,1) = perturb_dets(inint,1,b,kspin,ispin) -! det_tmp_j(inint,2) = perturb_dets(inint,2,b,kspin,ispin) -! enddo -! call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) -! if (degree_scalar > 2 .or. degree_scalar == 0)cycle -! ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > -! call i_H_j(det_tmp,det_tmp_j,N_int,hij) -! do istate = 1, N_states -! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & -! * hij / delta_e(a,jspin,istate) -! endif -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo - - - -! do a = 1, n_act_orb -! do jspin = 1, 2 -! do ispin = 1, 2 -! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle -! ! determinant perturber | det_tmp > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{a,jspin} a_{i,ispin} | Idet > -! do inint = 1, N_int -! det_tmp(inint,1) = iand(perturb_dets(inint,1,a,jspin,ispin),cas_bitmask(inint,1,1)) -! det_tmp(inint,2) = iand(perturb_dets(inint,2,a,jspin,ispin),cas_bitmask(inint,1,1)) -! enddo -! do istate = 1, N_states -! coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 -! enddo -! do b = 1, n_act_orb -! do kspin = jspin , jspin -! integer :: degree_scalar -! if( perturb_dets_phase(b,kspin,ispin) .le. -10.d0)cycle -! do inint = 1, N_int -! det_tmp_j(inint,1) = iand(perturb_dets(inint,1,b,kspin,ispin),cas_bitmask(inint,1,1)) -! det_tmp_j(inint,2) = iand(perturb_dets(inint,2,b,kspin,ispin),cas_bitmask(inint,1,1)) -! enddo -! call get_excitation_degree(det_tmp,det_tmp_j,degree_scalar,N_int) -! if (degree_scalar > 2 .or. degree_scalar == 0)cycle -! ! determinant perturber | det_tmp_j > = a^{\dagger}_{r,ispin} a^{\dagger}_{v,jspin} a_{b,jspin} a_{i,ispin} | Idet > -!! print*, '**********************' -!! integer(bit_kind) :: det_bis(N_int,2) -!! call debug_det(det_tmp,N_int) -!! call debug_det(det_tmp_j,N_int) -!! do inint = 1, N_int -!! det_bis(inint,1) = perturb_dets(inint,1,b,kspin,ispin) -!! det_bis(inint,2) = perturb_dets(inint,2,b,kspin,ispin) -!! enddo -!! call debug_det(det_bis,N_int) -! call i_H_j_dyall(det_tmp,det_tmp_j,N_int,hij) -! do istate = 1, N_states -! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(b,kspin,ispin,istate,1) & -! * hij / delta_e(a,jspin,istate) -! if(dabs(hij).gt.0.01d0)then -! print*,degree_scalar, hij -! print*, coef_perturb_from_idet(b,kspin,ispin,istate,1)* hij / delta_e(a,jspin,istate),coef_perturb_from_idet(a,jspin,ispin,istate,1) -! -! endif -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo - -! do a = 1, n_act_orb -! do jspin = 1, 2 -! do ispin = 1, 2 -! if( perturb_dets_phase(a,jspin,ispin) .le. -10.d0)cycle -! do istate = 1, N_states -! coef_perturb_from_idet(a,jspin,ispin,istate,2) += coef_perturb_from_idet(a,jspin,ispin,istate,1) -! enddo -! enddo -! enddo -! enddo diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f index 7d2d6c23..a03f2659 100644 --- a/plugins/MRPT_Utils/print_1h2p.irp.f +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -17,7 +17,8 @@ subroutine routine enddo enddo enddo - call give_1h2p_contrib_sec_order(matrix_1h2p) + if(.False.)then + call give_1h2p_contrib(matrix_1h2p) double precision :: accu accu = 0.d0 do i = 1, N_det @@ -25,7 +26,25 @@ subroutine routine accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) enddo enddo - print*, 'accu', accu + print*, 'second order ', accu + endif + + if(.True.)then + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 + enddo + enddo + enddo + call give_1h2p_new(matrix_1h2p) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*, 'third order ', accu deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f new file mode 100644 index 00000000..7bfeeb9c --- /dev/null +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -0,0 +1,303 @@ + +subroutine give_1h2p_new(matrix_1h2p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) + integer :: i,v,r,a,b,c + integer :: iorb, vorb, rorb, aorb, borb,corb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states) + double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,2) + logical :: already_generated(n_act_orb,2,2) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer(bit_kind) :: det_tmp_j(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + double precision :: accu_contrib(N_states) + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: delta_e_inv(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,6) + double precision :: delta_e_inactive_virt(N_states) + integer :: kspin + double precision :: delta_e_ja(N_states) + double precision :: hja + double precision :: contrib_hij + double precision :: fock_operator_local(n_act_orb,n_act_orb,2) + double precision :: hij_test + integer ::i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hib , hab + double precision :: delta_e_ab(N_states) + double precision :: hib_test,hja_test,hab_test + integer :: i_hole,i_part + double precision :: hia,hjb + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 + + accu_contrib = 0.d0 +!matrix_1h2p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do v = 1, n_virt_orb ! First virtual + vorb = list_virt(v) + do r = 1, n_virt_orb ! Second virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + perturb_dets_phase(a,1,1) = -1000.d0 + perturb_dets_phase(a,1,2) = -1000.d0 + perturb_dets_phase(a,2,2) = -1000.d0 + perturb_dets_phase(a,2,1) = -1000.d0 + enddo + + + do istate = 1, N_states + delta_e_inactive_virt(istate) = & + - fock_virt_total_spin_trace(rorb,istate) & + - fock_virt_total_spin_trace(vorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_mono_or_exchange(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) + do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) + do a = 1, n_act_orb ! First active + aorb = list_act(a) + do istate = 1, N_states + perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation active -- > virtual + call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin + call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = -1000.0d0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + do istate = 1, N_states + coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 + coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 + enddo + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + + do istate = 1, N_states + delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) + delta_e_inactive_virt(istate) + delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + if(degree(jdet)==1)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + i_hole = list_act_reverse(exc(1,1,1)) !!! a_a + i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + kspin = 1 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + else + ! Mono beta + i_hole = list_act_reverse(exc(1,1,2)) !!! a_a + i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + kspin = 2 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + endif + endif + else + index_orb_act_mono(idx(jdet),1) = -1 + endif + enddo + + + + do jdet = 1, idx(0) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS + if(degree(jdet) == 1)then + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > + + accu_contrib = 0.d0 + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + + ! FIRST ORDER CONTRIBUTION + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hia = phase * (active_int(aorb,1) - active_int(aorb,2) ) + else + hia = phase * active_int(aorb,1) + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,1) - active_int(borb,2) ) + else + hja = phase * active_int(borb,1) + endif + + call i_H_j(det_tmp,psi_det(1,1,idx(jdet)),N_int,hij_test) + if(hij_test .ne. hja)then + print*, 'hij_test .ne. hja' + stop + endif + contrib_hij = hja * hia + do istate = 1, N_states + accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate) + enddo + + !!!! SECOND ORDER CONTRIBTIONS + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > + do jspin = 1, 2 + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hia = perturb_dets_hij(corb,jspin,ispin) + hab = fock_operator_local(aorb,borb,kspin) * phase + + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(jspin == ispin)then + hjb = phase * (active_int(corb,1) - active_int(corb,2) ) + else + hjb = phase * active_int(corb,1) + endif + do istate = 1, N_states + accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) & + *hjb + enddo + enddo + enddo + + + + enddo ! ispin + do istate = 1, N_states + matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate) + enddo + + else if (degree(jdet) == 0)then + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + accu_contrib = 0.d0 + do ispin = 1, 2 + do kspin = 1, 2 + do a = 1, n_act_orb ! First active + if( perturb_dets_phase(a,kspin,ispin) .le. -10.d0)cycle + if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) + do istate = 1, N_states + accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate) + enddo + enddo + enddo + enddo + do istate = 1, N_states + matrix_1h2p(idet,idet,istate) += accu_contrib(istate) + enddo + + endif + enddo !! jdet + + + enddo + enddo + enddo + enddo + + + + + +end + diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index b2a78216..6af49681 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -31,8 +31,8 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) n_elec_tmp += popcnt(key_in(i,1)) + popcnt(key_in(i,2)) enddo if(n_elec_tmp .ne. elec_num)then - print*, n_elec_tmp,elec_num - call debug_det(key_in,N_int) + !print*, n_elec_tmp,elec_num + !call debug_det(key_in,N_int) i_ok = -1 endif end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 01ac8e8d..d153d008 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1367,8 +1367,178 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s do i=1,sze d = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) - exchange_1 = popcnt(xor(iand(key1(1,1,i),key1(1,2,i)),iand(key2(1,1),key2(1,2)))) - exchange_2 = popcnt(iand(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) + exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,2),key2(1,2)))) + & + popcnt(xor(ior(key1(2,1,i),key1(2,2,i)),ior(key2(2,2),key2(2,2)))) + exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & + popcnt(ior(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) + & + popcnt(xor(ior(key1(2,1,i),key1(2,2,i)),ior(key2(2,1),key2(2,2)))) + & + popcnt(xor(ior(key1(3,1,i),key1(3,2,i)),ior(key2(3,1),key2(3,2)))) + exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & + popcnt(ior(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + & + popcnt(ior(xor(key1(3,1,i),key2(3,1)),xor(key1(3,2,i),key2(3,2)))) + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = 0 + exchange_1 = 0 + !DIR$ LOOP COUNT MIN(4) + do m=1,Nint + d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + + popcnt(xor( key1(m,2,i), key2(m,2))) + exchange_1 = popcnt(xor(ior(key1(m,1,i),key1(m,2,i)),ior(key2(m,1),key2(m,2)))) + exchange_2 = popcnt(ior(xor(key1(m,1,i),key2(m,1)),xor(key1(m,2,i),key2(m,2)))) + enddo + if (d > 4)cycle + if (d ==4)then + if(exchange_1 .eq. 0 ) then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + else + cycle + endif +! pause + else + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + endif + enddo + + endif + idx(0) = l-1 +end + +subroutine get_excitation_degree_vector_mono_or_exchange_verbose(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants and return only the mono excitations + ! and the connections through exchange integrals + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + + integer :: i,l,d,m + integer :: exchange_1,exchange_2 + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) + exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + if(i==99)then + integer(bit_kind) :: key_test(N_int,2) + key_test(1,2) = 0_bit_kind + call debug_det(key2,N_int) + key_test(1,1) = ior(key2(1,1),key2(1,2)) + call debug_det(key_test,N_int) + key_test(1,1) = ior(key1(1,1,i),key1(1,2,i)) + call debug_det(key1(1,1,i),N_int) + call debug_det(key_test,N_int) + key_test(1,1) = xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2))) + call debug_det(key_test,N_int) + print*, exchange_1 , exchange_2 + stop + endif if (d > 4)cycle if (d ==4)then if(exchange_1 .eq. 0 ) then From a73461035f3eca2530cf677882c1eba24b9c9f23 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 18 Sep 2016 20:53:28 +0200 Subject: [PATCH 23/32] second order ok for 2h1p --- plugins/MRPT_Utils/print_1h2p.irp.f | 1 + plugins/MRPT_Utils/second_order_new.irp.f | 266 ++++++++++++++++++++-- 2 files changed, 254 insertions(+), 13 deletions(-) diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f index a03f2659..d10e1fb5 100644 --- a/plugins/MRPT_Utils/print_1h2p.irp.f +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -44,6 +44,7 @@ subroutine routine accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) enddo enddo + endif print*, 'third order ', accu deallocate (matrix_1h2p) diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 7bfeeb9c..57439580 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -11,7 +11,6 @@ subroutine give_1h2p_new(matrix_1h2p) double precision :: perturb_dets_phase(n_act_orb,2,2) double precision :: perturb_dets_hij(n_act_orb,2,2) double precision :: perturb_dets_hpsi0(n_act_orb,2,2,N_states) - double precision :: coef_perturb_from_idet(n_act_orb,2,2,N_states,2) logical :: already_generated(n_act_orb,2,2) integer :: inint integer :: elec_num_tab_local(2),acu_elec @@ -27,9 +26,9 @@ subroutine give_1h2p_new(matrix_1h2p) integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) double precision :: delta_e_inv(n_act_orb,2,N_states) + double precision :: delta_e_inactive_virt(N_states) integer :: istate integer :: index_orb_act_mono(N_det,6) - double precision :: delta_e_inactive_virt(N_states) integer :: kspin double precision :: delta_e_ja(N_states) double precision :: hja @@ -88,8 +87,6 @@ subroutine give_1h2p_new(matrix_1h2p) aorb = list_act(a) do istate = 1, N_states perturb_dets_hpsi0(a,jspin,ispin,istate) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 enddo if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int @@ -112,10 +109,6 @@ subroutine give_1h2p_new(matrix_1h2p) if(accu_elec .ne. elec_num_tab_local(jspin))then perturb_dets_phase(a,jspin,ispin) = -1000.0d0 perturb_dets_hij(a,jspin,ispin) = 0.d0 - do istate = 1, N_states - coef_perturb_from_idet(a,jspin,ispin,istate,1) = 0.d0 - coef_perturb_from_idet(a,jspin,ispin,istate,2) = 0.d0 - enddo cycle endif do inint = 1, N_int @@ -215,11 +208,6 @@ subroutine give_1h2p_new(matrix_1h2p) hja = phase * active_int(borb,1) endif - call i_H_j(det_tmp,psi_det(1,1,idx(jdet)),N_int,hij_test) - if(hij_test .ne. hja)then - print*, 'hij_test .ne. hja' - stop - endif contrib_hij = hja * hia do istate = 1, N_states accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate) @@ -294,6 +282,257 @@ subroutine give_1h2p_new(matrix_1h2p) enddo enddo enddo +end + +subroutine give_2h1p_new(matrix_2h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,2,2) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: i_hole,i_part + double precision :: delta_e_inv(n_act_orb,2,N_states) + double precision :: fock_operator_local(n_act_orb,n_act_orb,2) + double precision :: delta_e_inactive_virt(N_states) + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,2,N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,3) + integer :: kspin + double precision :: hij_test + double precision :: accu_contrib(N_states) + double precision :: contrib_hij + double precision :: hja + integer :: corb,i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hia,hjb,hab +!matrix_2h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do j = 1, n_inact_orb ! Second inactive + jorb = list_inact(j) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + ! take all the integral you will need for i,j,r fixed + do a = 1, n_act_orb + aorb = list_act(a) + active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + perturb_dets_phase(a,1,1) = -1000.d0 + perturb_dets_phase(a,1,2) = -1000.d0 + perturb_dets_phase(a,2,2) = -1000.d0 + perturb_dets_phase(a,2,1) = -1000.d0 + enddo + + do istate = 1, N_states + delta_e_inactive_virt(istate) = & + - fock_virt_total_spin_trace(rorb,istate) & + + fock_core_inactive_total_spin_trace(iorb,istate) & + + fock_core_inactive_total_spin_trace(jorb,istate) + enddo + + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) + if(ispin == jspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + aorb = list_act(a) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation inactive -- > active + call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin + call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,jspin)) + enddo + if(accu_elec .ne. elec_num_tab_local(jspin))then + perturb_dets_phase(a,jspin,ispin) = -1000.0d0 + perturb_dets_hij(a,jspin,ispin) = 0.d0 + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) + perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) + enddo + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,jspin,ispin) = phase + do istate = 1, N_states + delta_e(a,jspin,istate) = one_creat(a,jspin,istate) + delta_e_inactive_virt(istate) + delta_e_inv(a,jspin,istate) = 1.d0 / delta_e(a,jspin,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,jspin,ispin) = phase * (active_int(a,1) - active_int(a,2) ) + else + perturb_dets_hij(a,jspin,ispin) = phase * active_int(a,1) + endif +!!!!!!!!!!!!!!!!!!!!!1 Computation of the coefficient at first order coming from idet +!!!!!!!!!!!!!!!!!!!!! for the excitation (i,j)(ispin,jspin) ---> (r,a)(ispin,jspin) + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(degree(jdet)==1)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + i_part = list_act_reverse(exc(1,2,1)) ! a^{\dagger}_{aorb} + i_hole = list_act_reverse(exc(1,1,1)) ! a_{borb} + kspin = 1 + index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 1 + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + else + ! Mono beta + i_part = list_act_reverse(exc(1,2,2)) + i_hole = list_act_reverse(exc(1,1,2)) + kspin = 2 + index_orb_act_mono(idx(jdet),1) = i_part !!! a^{\dagger}_a + index_orb_act_mono(idx(jdet),2) = i_hole !!! a_{b} + index_orb_act_mono(idx(jdet),3) = 2 + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + endif + endif + enddo + + do jdet = 1, idx(0) + ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator + ! are connected by the presence of the perturbers determinants |det_tmp> + if(degree(jdet) == 1)then + aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} + borb = index_orb_act_mono(idx(jdet),2) ! a_{borb} + kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation + ! the determinants Idet and Jdet interact throw the following operator + ! | Jdet > = a_{borb,kspin} a^{\dagger}_{aorb, kspin} | Idet > + + accu_contrib = 0.d0 + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + ! you determine the interaction between the excited determinant and the other parent | Jdet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > + ! hja = < det_tmp | H | Jdet > + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,1) - active_int(borb,2) ) + else + hja = phase * active_int(borb,1) + endif + + + do istate = 1, N_states + accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate) + enddo + !!!! SECOND ORDER CONTRIBUTIONS + !!!! SECOND ORDER CONTRIBTIONS + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,jspin} a_{jorb,jspin} a_{iorb,ispin} | Idet > + do jspin = 1, 2 + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet > + call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok) + if(i_ok .ne. 1)cycle + hia = perturb_dets_hij(corb,jspin,ispin) + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(borb,aorb,kspin) * phase + + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(jspin == ispin)then + hjb = phase * (active_int(corb,1) - active_int(corb,2) ) + else + hjb = phase * active_int(corb,1) + endif + do istate = 1, N_states + accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) & + *hjb + enddo + enddo + enddo + enddo ! ispin + do istate = 1, N_states + matrix_2h1p(idx(jdet),idet,istate) += accu_contrib(istate) + enddo + + else if (degree(jdet) == 0 )then + ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations + ! + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + accu_contrib = 0.d0 + do ispin = 1, 2 + do kspin = 1, 2 + if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + do a = 1, n_act_orb ! First active + contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) + do istate = 1, N_states + accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate) + enddo + enddo + enddo + enddo + do istate =1, N_states + matrix_2h1p(idet,idet,istate) += accu_contrib(istate) + enddo + + endif + + enddo + enddo + enddo + enddo + enddo @@ -301,3 +540,4 @@ subroutine give_1h2p_new(matrix_1h2p) end + From c6b7acbc4e68dc22acaa5e5198c96314392d2311 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 19 Sep 2016 13:38:37 +0200 Subject: [PATCH 24/32] definitive version for the second order of 1h2p and 2h1p --- plugins/MRPT_Utils/second_order_new.irp.f | 419 ++++++++++++++++------ src/Determinants/slater_rules.irp.f | 12 +- 2 files changed, 321 insertions(+), 110 deletions(-) diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 57439580..54b284f6 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -137,7 +137,6 @@ subroutine give_1h2p_new(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) - if(idx(jdet).ne.idet)then if(degree(jdet)==1)then call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then @@ -163,10 +162,17 @@ subroutine give_1h2p_new(matrix_1h2p) fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator endif + else if(degree(jdet)==2)then + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA + index_orb_act_mono(idx(jdet),3) = 1 + ! Mono beta + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA + index_orb_act_mono(idx(jdet),6) = 2 endif - else - index_orb_act_mono(idx(jdet),1) = -1 - endif enddo @@ -185,65 +191,83 @@ subroutine give_1h2p_new(matrix_1h2p) accu_contrib = 0.d0 do ispin = 1, 2 ! you loop on all possible spin for the excitation ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count - - ! FIRST ORDER CONTRIBUTION - - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hia = phase * (active_int(aorb,1) - active_int(aorb,2) ) - else - hia = phase * active_int(aorb,1) + +! if(ispin == kspin .and. vorb.le.rorb)cycle ! condition not to double count + logical :: cycle_same_spin_first_order + cycle_same_spin_first_order = .False. + if(ispin == kspin .and. vorb.le.rorb)then + cycle_same_spin_first_order = .True. endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,1) - active_int(borb,2) ) - else - hja = phase * active_int(borb,1) + if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count + + ! FIRST ORDER CONTRIBUTION + + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + if(perturb_dets_phase(aorb,kspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hia = phase * (active_int(aorb,1) - active_int(aorb,2) ) + else + hia = phase * active_int(aorb,1) + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,1) - active_int(borb,2) ) + else + hja = phase * active_int(borb,1) + endif + + contrib_hij = hja * hia + do istate = 1, N_states + accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate) + enddo endif - - contrib_hij = hja * hia - do istate = 1, N_states - accu_contrib(istate) += contrib_hij * delta_e_inv(aorb,kspin,istate) - enddo - !!!! SECOND ORDER CONTRIBTIONS ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > do jspin = 1, 2 - do corb = 1, n_act_orb - if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > - call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) - if(i_ok .ne. 1)cycle - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hia = perturb_dets_hij(corb,jspin,ispin) - hab = fock_operator_local(aorb,borb,kspin) * phase + logical :: cycle_same_spin_second_order + cycle_same_spin_second_order = .False. + if(ispin == jspin .and. vorb.le.rorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False.)then + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! | det_tmp_bis > = a^{\dagger}_{borb,kspin} a_{aorb,kspin} a_{iorb,ispin} | Idet > + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),kspin,i_ok) + if(i_ok .ne. 1)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hia = perturb_dets_hij(corb,jspin,ispin) + hab = fock_operator_local(aorb,borb,kspin) * phase - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(jspin == ispin)then - hjb = phase * (active_int(corb,1) - active_int(corb,2) ) - else - hjb = phase * active_int(corb,1) - endif - do istate = 1, N_states - accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) & - *hjb + if(dabs(hia).le.1.d-12)cycle + if(dabs(hab).le.1.d-12)cycle + + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(jspin == ispin)then + hjb = phase * (active_int(corb,1) - active_int(corb,2) ) + else + hjb = phase * active_int(corb,1) + endif + if(dabs(hjb).le.1.d-12)cycle + do istate = 1, N_states + accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(aorb,borb,kspin,kspin,istate)) & + *hjb + enddo enddo - enddo + endif enddo @@ -253,6 +277,176 @@ subroutine give_1h2p_new(matrix_1h2p) matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate) enddo + else if (degree(jdet) == 2)then + ! CASE OF THE DOUBLE EXCITATIONS, ONLY THIRD ORDER EFFECTS + accu_contrib = 0.d0 + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{i} (ispin) + ! if it is standard exchange case, the hole ALPHA == the part. BETA + if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),5))then + aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron + borb = index_orb_act_mono(idx(jdet),4) !! the HOLE of the BETA electron + ! first case :: | det_tmp > == a_{borb,\beta} | Idet > + cycle_same_spin_second_order = .False. + if(ispin == 2 .and. vorb.le.rorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. 2 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,borb,2,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,borb,2,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,borb,2,ispin) + enddo + hia = perturb_dets_hij(borb,2,ispin) + if(dabs(hia).le.1.d-12)cycle + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(aorb,borb,1) * phase + + if(dabs(hab).le.1.d-12)cycle + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(ispin == 2)then + hjb = phase * (active_int(aorb,1) - active_int(aorb,2) ) + else if (ispin == 1)then + hjb = phase * active_int(aorb,1) + endif + if(dabs(hjb).le.1.d-12)cycle + do istate = 1, N_states + accu_contrib(istate) += hia * delta_e_inv(borb,2,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + * hab / (delta_e(borb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) & + * hjb + enddo + endif + ! second case :: | det_tmp > == a_{aorb,\alpha} | Idet > + cycle_same_spin_second_order = .False. + if(ispin == 1 .and. vorb.le.rorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. 1 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin) + enddo + hia = perturb_dets_hij(aorb,1,ispin) + if(dabs(hia).le.1.d-12)cycle + call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),2,i_ok) + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(aorb,borb,2) * phase + + if(dabs(hab).le.1.d-12)cycle + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(ispin == 1)then + hjb = phase * (active_int(borb,1) - active_int(borb,2) ) + else if (ispin == 2)then + hjb = phase * active_int(borb,1) + endif + if(dabs(hjb).le.1.d-12)cycle + do istate = 1, N_states + accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + * hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(borb,aorb,2,2,istate)) & + * hjb + enddo + endif + + ! if it is a closed shell double excitation, the hole ALPHA == the hole BETA + else if (index_orb_act_mono(idx(jdet),1) == index_orb_act_mono(idx(jdet),4))then + aorb = index_orb_act_mono(idx(jdet),1) !! the HOLE of the ALPHA electron + borb = index_orb_act_mono(idx(jdet),2) !! the PART of the ALPHA electron + ! first case :: | det_tmp > == a_{aorb,\beta} | Idet > + cycle_same_spin_second_order = .False. + if(ispin == 2 .and. vorb.le.rorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. 2 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,2,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,2,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,2,ispin) + enddo + hia = perturb_dets_hij(aorb,2,ispin) + if(dabs(hia).le.1.d-12)cycle + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),1,i_ok) + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(aorb,borb,1) * phase + + if(dabs(hab).le.1.d-12)cycle + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(ispin == 2)then + hjb = phase * (active_int(borb,1) - active_int(borb,2) ) + else if (ispin == 1)then + hjb = phase * active_int(borb,1) + endif + if(dabs(hjb).le.1.d-12)cycle + do istate = 1, N_states + accu_contrib(istate) += hia * delta_e_inv(aorb,2,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + * hab / (delta_e(aorb,2,istate) + one_anhil_one_creat(aorb,borb,1,1,istate)) & + * hjb + enddo + endif + + ! second case :: | det_tmp > == a_{aorb,\alpha} | Idet > + cycle_same_spin_second_order = .False. + if(ispin == 1 .and. vorb.le.rorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. 1 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,1,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,aorb,1,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,aorb,1,ispin) + enddo + hia = perturb_dets_hij(aorb,1,ispin) + if(dabs(hia).le.1.d-12)cycle + call do_mono_excitation(det_tmp_bis,list_act(aorb),list_act(borb),2,i_ok) + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(aorb,borb,2) * phase + + if(dabs(hab).le.1.d-12)cycle + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(ispin == 1)then + hjb = phase * (active_int(borb,1) - active_int(borb,2) ) + else if (ispin == 2)then + hjb = phase * active_int(borb,1) + endif + if(dabs(hjb).le.1.d-12)cycle + do istate = 1, N_states + accu_contrib(istate) += hia * delta_e_inv(aorb,1,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + * hab / (delta_e(aorb,1,istate) + one_anhil_one_creat(aorb,borb,2,2,istate)) & + * hjb + enddo + endif + + + else + ! one should not fall in this case ... + call debug_det(psi_det(1,1,i),N_int) + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call decode_exc(exc,2,h1,p1,h2,p2,s1,s2) + integer :: h1, p1, h2, p2, s1, s2 + print*, h1, p1, h2, p2, s1, s2 + + print*, 'pb !!! it is a double but not an exchange case ....' + stop + endif + enddo ! ispin + do istate = 1, N_states + matrix_1h2p(idet,idx(jdet),istate) += accu_contrib(istate) + enddo + else if (degree(jdet) == 0)then ! diagonal part of the dressing : interaction of | Idet > with all the perturbers generated by the excitations ! @@ -447,59 +641,77 @@ subroutine give_2h1p_new(matrix_2h1p) accu_contrib = 0.d0 do ispin = 1, 2 ! you loop on all possible spin for the excitation ! a^{\dagger}_r a_{i} (ispin) - if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count - - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) - enddo - ! you determine the interaction between the excited determinant and the other parent | Jdet > - ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > - ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(kspin == ispin)then - hja = phase * (active_int(borb,1) - active_int(borb,2) ) - else - hja = phase * active_int(borb,1) +! if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count + logical :: cycle_same_spin_first_order + cycle_same_spin_first_order = .False. + if(ispin == kspin .and. iorb.le.jorb)then + cycle_same_spin_first_order = .True. endif - + if(ispin .ne. kspin .or. cycle_same_spin_first_order == .False. )then! condition not to double count - do istate = 1, N_states - accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate) - enddo + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,aorb,kspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,aorb,kspin,ispin) + enddo + ! you determine the interaction between the excited determinant and the other parent | Jdet > + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > + ! hja = < det_tmp | H | Jdet > + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(kspin == ispin)then + hja = phase * (active_int(borb,1) - active_int(borb,2) ) + else + hja = phase * active_int(borb,1) + endif +!! if(dabs(hja).le.1.d-10)cycle + + + do istate = 1, N_states + accu_contrib(istate) += hja * perturb_dets_hij(aorb,kspin,ispin) * delta_e_inv(aorb,kspin,istate) + enddo + endif + logical :: cycle_same_spin_second_order !!!! SECOND ORDER CONTRIBUTIONS !!!! SECOND ORDER CONTRIBTIONS ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{corb,jspin} a_{jorb,jspin} a_{iorb,ispin} | Idet > do jspin = 1, 2 - do corb = 1, n_act_orb - if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle - do inint = 1, N_int - det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) - det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) - enddo - ! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet > - call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok) - if(i_ok .ne. 1)cycle - hia = perturb_dets_hij(corb,jspin,ispin) - call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) - hab = fock_operator_local(borb,aorb,kspin) * phase - - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) - if(jspin == ispin)then - hjb = phase * (active_int(corb,1) - active_int(corb,2) ) - else - hjb = phase * active_int(corb,1) - endif - do istate = 1, N_states - accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > - ! | det_tmp > --> | det_tmp_bis > - *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) & - *hjb - enddo - enddo + cycle_same_spin_second_order = .False. + if(ispin == jspin .and. iorb.le.jorb)then + cycle_same_spin_second_order = .True. + endif + if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False. )then! condition not to double count + do corb = 1, n_act_orb + if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + det_tmp_bis(inint,1) = perturb_dets(inint,1,corb,jspin,ispin) + det_tmp_bis(inint,2) = perturb_dets(inint,2,corb,jspin,ispin) + enddo + ! | det_tmp_bis > = a^{\dagger}_{aorb,kspin} a_{borb,kspin} a_{iorb,kspin} | Idet > + call do_mono_excitation(det_tmp_bis,list_act(borb),list_act(aorb),kspin,i_ok) + if(i_ok .ne. 1)cycle + hia = perturb_dets_hij(corb,jspin,ispin) + if(dabs(hia).le.1.d-10)cycle + call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) + hab = fock_operator_local(borb,aorb,kspin) * phase + if(dabs(hab).le.1.d-10)cycle + + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp_bis,exc,phase,N_int) + if(jspin == ispin)then + hjb = phase * (active_int(corb,1) - active_int(corb,2) ) + else + hjb = phase * active_int(corb,1) + endif + if(dabs(hjb).le.1.d-10)cycle + do istate = 1, N_states + accu_contrib(istate)+=hia * delta_e_inv(corb,jspin,istate) & ! | Idet > --> | det_tmp > + ! | det_tmp > --> | det_tmp_bis > + *hab / (delta_e(corb,jspin,istate) + one_anhil_one_creat(borb,aorb,kspin,kspin,istate)) & + *hjb + enddo + enddo ! jspin + endif enddo enddo ! ispin do istate = 1, N_states @@ -516,6 +728,7 @@ subroutine give_2h1p_new(matrix_2h1p) if(ispin == kspin .and. iorb.le.jorb)cycle ! condition not to double count do a = 1, n_act_orb ! First active contrib_hij = perturb_dets_hij(a,kspin,ispin) * perturb_dets_hij(a,kspin,ispin) + if(dabs(contrib_hij).le.1.d-10)cycle do istate = 1, N_states accu_contrib(istate) += contrib_hij * delta_e_inv(a,kspin,istate) enddo diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index d153d008..b1666864 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1353,6 +1353,7 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s integer(bit_kind), intent(in) :: key2(Nint,2) integer, intent(out) :: degree(sze) integer, intent(out) :: idx(0:sze) + integer(bit_kind) :: key_tmp(Nint,2) integer :: i,l,d,m integer :: exchange_1,exchange_2 @@ -1367,15 +1368,12 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s do i=1,sze d = popcnt(xor( key1(1,1,i), key2(1,1))) + & popcnt(xor( key1(1,2,i), key2(1,2))) - exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) - exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) + key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) + if(popcnt(key_tmp(1,1)) .gt.3 .or. popcnt(key_tmp(1,2)) .gt.3 )cycle !! no double excitations of same spin if (d > 4)cycle if (d ==4)then - if(exchange_1 .eq. 0 ) then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then + if(popcnt(xor(key_tmp(1,1),key_tmp(1,2))) == 0)then degree(l) = ishft(d,-1) idx(l) = i l = l+1 From 376e4940db043ea19ed2c040552f387f08a06a52 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 19 Sep 2016 18:06:34 +0200 Subject: [PATCH 25/32] second order works for 2p --- plugins/MRPT_Utils/second_order_new.irp.f | 13 +- plugins/MRPT_Utils/second_order_new_2p.irp.f | 283 +++++++++++++++++++ src/Determinants/slater_rules.irp.f | 2 + 3 files changed, 292 insertions(+), 6 deletions(-) create mode 100644 plugins/MRPT_Utils/second_order_new_2p.irp.f diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 54b284f6..bcd08bf5 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -198,7 +198,8 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == kspin .and. vorb.le.rorb)then cycle_same_spin_first_order = .True. endif - if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count +! if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count + if(cycle_same_spin_first_order == .False. )then ! condition not to double count ! FIRST ORDER CONTRIBUTION @@ -234,7 +235,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == jspin .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False.)then + if(cycle_same_spin_second_order == .False.)then do corb = 1, n_act_orb if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle do inint = 1, N_int @@ -291,7 +292,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. 2 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order == .False.)then ! condition not to double count if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin) @@ -325,7 +326,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. 1 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order == .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) @@ -364,7 +365,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. 2 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order == .False.)then ! condition not to double count if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin) @@ -399,7 +400,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. 1 .or. cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order == .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f new file mode 100644 index 00000000..2e94527c --- /dev/null +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -0,0 +1,283 @@ + +subroutine give_2p_new(matrix_2p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_2p(N_det,N_det,*) + integer :: i,v,r,a,b,c + integer :: iorb, vorb, rorb, aorb, borb,corb + integer :: ispin,jspin + integer :: idet,jdet + integer(bit_kind) :: perturb_dets(N_int,2,n_act_orb,n_act_orb,2,2) + double precision :: perturb_dets_phase(n_act_orb,n_act_orb,2,2) + double precision :: perturb_dets_hij(n_act_orb,n_act_orb,2,2) + double precision :: perturb_dets_hpsi0(n_act_orb,n_act_orb,2,2,N_states) + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer(bit_kind) :: det_tmp_j(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,n_act_orb,2) + double precision :: hij,phase + double precision :: accu_contrib(N_states) + integer :: degree(N_det) + integer :: idx(0:N_det) + double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) + double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) + double precision :: delta_e_inactive_virt(N_states) + integer :: istate + integer :: index_orb_act_mono(N_det,6) + integer :: kspin + double precision :: delta_e_ja(N_states) + double precision :: hja + double precision :: contrib_hij + double precision :: fock_operator_local(n_act_orb,n_act_orb,2) + double precision :: hij_test + integer ::i_ok + integer(bit_kind) :: det_tmp_bis(N_int,2) + double precision :: hib , hab + double precision :: delta_e_ab(N_states) + double precision :: hib_test,hja_test,hab_test + integer :: i_hole,i_part + double precision :: hia,hjb + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 + + accu_contrib = 0.d0 +!matrix_2p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do v = 1, n_virt_orb ! First virtual + vorb = list_virt(v) + do r = 1, n_virt_orb ! Second virtual + rorb = list_virt(r) + ! take all the integral you will need for r,v fixed + do a = 1, n_act_orb + aorb = list_act(a) + do b = 1, n_act_orb + borb = list_act(b) + active_int(a,b,1) = get_mo_bielec_integral_schwartz(aorb,borb,rorb,vorb,mo_integrals_map) ! direct ( a--> r | b--> v ) + active_int(a,b,2) = get_mo_bielec_integral_schwartz(aorb,borb,vorb,rorb,mo_integrals_map) ! exchange ( b--> r | a--> v ) + perturb_dets_phase(a,b,1,1) = -1000.d0 + perturb_dets_phase(a,b,1,2) = -1000.d0 + perturb_dets_phase(a,b,2,2) = -1000.d0 + perturb_dets_phase(a,b,2,1) = -1000.d0 + perturb_dets_phase(b,a,1,1) = -1000.d0 + perturb_dets_phase(b,a,1,2) = -1000.d0 + perturb_dets_phase(b,a,2,2) = -1000.d0 + perturb_dets_phase(b,a,2,1) = -1000.d0 + enddo + enddo + + + do istate = 1, N_states + delta_e_inactive_virt(istate) = & + - fock_virt_total_spin_trace(rorb,istate) & + - fock_virt_total_spin_trace(vorb,istate) + enddo + do idet = 1, N_det +! call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + call get_excitation_degree_vector(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + do ispin = 1, 2 ! spin of the couple a-a^dagger (aorb,rorb) + do jspin = 1, 2 ! spin of the couple a-a^dagger (borb,vorb) + do b = 1, n_act_orb ! First active + borb = list_act(b) + do a = 1, n_act_orb ! First active + aorb = list_act(a) +! if(ispin == 2.and. jspin ==1)then +! perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 +! perturb_dets_hij(a,b,ispin,jspin) = 0.d0 +! cycle ! condition not to double count +! endif + + if(ispin == jspin .and. vorb.le.rorb)then + perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 + perturb_dets_hij(a,b,ispin,jspin) = 0.d0 + cycle ! condition not to double count + endif + if(ispin == jspin .and. aorb.le.borb) then + perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 + perturb_dets_hij(a,b,ispin,jspin) = 0.d0 + cycle ! condition not to double count + endif + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation (aorb,ispin) --> (rorb,ispin) + call clear_bit_to_integer(aorb,det_tmp(1,ispin),N_int) ! hole in "aorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + + ! Do the excitation (borb,jspin) --> (vorb,jspin) + call clear_bit_to_integer(borb,det_tmp(1,jspin),N_int) ! hole in "borb" of spin Jspin + call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin + + ! Check if the excitation is possible or not on psi_det(idet) + accu_elec= 0 + do inint = 1, N_int + accu_elec+= popcnt(det_tmp(inint,1)) + popcnt(det_tmp(inint,2)) + enddo + if(accu_elec .ne. elec_num_tab_local(2)+elec_num_tab_local(1))then + perturb_dets_phase(a,b,ispin,jspin) = -1000.0d0 + perturb_dets_hij(a,b,ispin,jspin) = 0.d0 + cycle + endif + do inint = 1, N_int + perturb_dets(inint,1,a,b,ispin,jspin) = det_tmp(inint,1) + perturb_dets(inint,2,a,b,ispin,jspin) = det_tmp(inint,2) + enddo + + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + perturb_dets_phase(a,b,ispin,jspin) = phase + + do istate = 1, N_states + delta_e(a,b,ispin,jspin,istate) = two_anhil(a,b,ispin,jspin,istate) + delta_e_inactive_virt(istate) + delta_e_inv(a,b,ispin,jspin,istate) = 1.d0 / delta_e(a,b,ispin,jspin,istate) + enddo + if(ispin == jspin)then + perturb_dets_hij(a,b,ispin,jspin) = phase * (active_int(a,b,2) - active_int(a,b,1) ) + else + perturb_dets_hij(a,b,ispin,jspin) = phase * active_int(a,b,1) + endif + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij) + if(hij.ne.perturb_dets_hij(a,b,ispin,jspin))then + print*, active_int(a,b,1) , active_int(b,a,1) + double precision :: hmono,hdouble + call i_H_j_verbose(psi_det(1,1,idet),det_tmp,N_int,hij,hmono,hdouble) + print*, 'pb !! hij.ne.perturb_dets_hij(a,b,ispin,jspin)' + print*, ispin,jspin + print*, aorb,rorb,borb,vorb + print*, hij,perturb_dets_hij(a,b,ispin,jspin) + call debug_det(psi_det(1,1,idet),N_int) + call debug_det(det_tmp,N_int) + stop + endif + enddo ! b + enddo ! a + enddo ! jspin + enddo ! ispin + +!!!!!!!!!!!!!!!!!!!!!!!!!!! determination of the connections between I and the other J determinants mono excited in the CAS +!!!!!!!!!!!!!!!!!!!!!!!!!!!! the determinants I and J must be connected by the following operator +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do jdet = 1, idx(0) + if(degree(jdet)==1)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + i_hole = list_act_reverse(exc(1,1,1)) !!! a_a + i_part = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} + kspin = 1 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + else + ! Mono beta + i_hole = list_act_reverse(exc(1,1,2)) !!! a_a + i_part = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} + kspin = 2 !!! kspin + index_orb_act_mono(idx(jdet),1) = i_hole + index_orb_act_mono(idx(jdet),2) = i_part + index_orb_act_mono(idx(jdet),3) = kspin + call i_H_j_dyall(psi_active(1,1,idet),psi_active(1,1,idx(jdet)),N_int,hij) + fock_operator_local(i_hole,i_part,kspin) = hij * phase ! phase less fock operator + fock_operator_local(i_part,i_hole,kspin) = hij * phase ! phase less fock operator + endif + else if(degree(jdet)==2)then + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA + index_orb_act_mono(idx(jdet),3) = 1 + ! Mono beta + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,1,2)) !!! a_a BETA + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(1,2,2)) !!! a^{\dagger}_{b} BETA + index_orb_act_mono(idx(jdet),6) = 2 + else if (exc(0,1,1) == 2) then + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a ALPHA + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_{b} ALPHA + index_orb_act_mono(idx(jdet),3) = 1 + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(2,1,1)) !!! a_c ALPHA + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,1)) !!! a^{\dagger}_{d} ALPHA + index_orb_act_mono(idx(jdet),6) = 1 + else if (exc(0,1,2) == 2) then + index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,2)) !!! a_a BETA + index_orb_act_mono(idx(jdet),2) = list_act_reverse(exc(2,1,2)) !!! a^{\dagger}_{b} BETA + index_orb_act_mono(idx(jdet),3) = 2 + index_orb_act_mono(idx(jdet),4) = list_act_reverse(exc(1,2,2)) !!! a_c BETA + index_orb_act_mono(idx(jdet),5) = list_act_reverse(exc(2,2,2)) !!! a^{\dagger}_{d} BETA + index_orb_act_mono(idx(jdet),6) = 2 + endif + endif + enddo + + + +! do jdet = 1, idx(0) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE OF THE MONO EXCITATIONS +! if(degree(jdet) == 1)then +! ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator +! ! are connected by the presence of the perturbers determinants |det_tmp> +! aorb = index_orb_act_mono(idx(jdet),1) ! a_{aorb} +! borb = index_orb_act_mono(idx(jdet),2) ! a^{\dagger}_{borb} +! kspin = index_orb_act_mono(idx(jdet),3) ! spin of the excitation +! ! the determinants Idet and Jdet interact throw the following operator +! ! | Jdet > = a^{\dagger}_{borb,kspin} a_{aorb, kspin} | Idet > + +! accu_contrib = 0.d0 + do ispin = 1, 2 ! you loop on all possible spin for the excitation + ! a^{\dagger}_r a_{a} (ispin) + !!!! SECOND ORDER CONTRIBTIONS + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > + do jspin = 1, 2 + if(ispin == 2 .and. jspin ==1)cycle + do b = 1, n_act_orb + do a = 1, n_act_orb + logical :: cycle_same_spin_second_order(2) + cycle_same_spin_second_order(1) = .False. + cycle_same_spin_second_order(2) = .False. + if(perturb_dets_phase(a,b,ispin,jspin).le.-10d0)cycle + if(ispin == jspin .and. vorb.le.rorb)then + cycle_same_spin_second_order(1) = .True. + endif + if(ispin == jspin .and. aorb.le.borb)then + cycle_same_spin_second_order(2) = .True. + endif + do inint = 1, N_int + det_tmp(inint,1) = perturb_dets(inint,1,a,b,ispin,jspin) + det_tmp(inint,2) = perturb_dets(inint,2,a,b,ispin,jspin) + enddo + do jdet = 1, idx(0) +! if(idx(jdet).gt.idet)cycle + do istate = 1, N_states + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij) + matrix_2p(idx(jdet),idet,istate) += hij * perturb_dets_hij(a,b,ispin,jspin) * delta_e_inv(a,b,ispin,jspin,istate) + enddo + enddo ! jdet + enddo ! b + enddo ! a + enddo ! jspin + enddo ! ispin + +! else if (degree(jdet) == 0)then +! +! endif +! enddo !! jdet + + + enddo + enddo + enddo +end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index b1666864..cb96957a 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -747,6 +747,8 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) + print*, 'hij verbose ',hij * phase + print*, 'phase verbose',phase else if (exc(0,1,1) == 2) then ! Double alpha print*,'phase hij = ',phase From 50d1f364e07d5669ae172a74ef8f8ba3d1edb3db Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 20 Sep 2016 12:04:48 +0200 Subject: [PATCH 26/32] Phase problem fixed --- plugins/MRPT_Utils/excitations_cas.irp.f | 52 ++++++++++++++++++++++-- src/Determinants/diagonalize_CI.irp.f | 2 +- 2 files changed, 50 insertions(+), 4 deletions(-) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 6fb2a831..213abf7b 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -21,6 +21,11 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & END_DOC integer :: elec_num_tab_local(2) + integer :: i,j,accu_elec,k + integer :: det_tmp(N_int), det_tmp_bis(N_int) + double precision :: phase + double precision :: norm_factor + elec_num_tab_local = 0 do i = 1, ndet if( psi_in_out_coef (i,1) .ne. 0.d0)then @@ -31,7 +36,6 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & exit endif enddo - integer :: i,j,accu_elec if(hole_particle == 1)then do i = 1, ndet call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) @@ -48,8 +52,28 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & psi_in_out_coef(i,j) = 0.d0 enddo endif + phase = 1.d0 + do k = 1, orb + do j = 1, N_int + det_tmp(j) = 0_bit_kind + enddo + call set_bit_to_integer(k,det_tmp,N_int) + accu_elec = 0 + do j = 1, N_int + det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i))) + accu_elec += popcnt(det_tmp_bis(j)) + enddo + if(accu_elec == 1)then + phase = phase * -1.d0 + endif + enddo + do j = 1, N_states_in + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase + enddo enddo + else if (hole_particle == -1)then + do i = 1, ndet call clear_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) accu_elec = 0 @@ -65,10 +89,30 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & psi_in_out_coef(i,j) = 0.d0 enddo endif + + phase = 1.d0 + do k = 1, orb-1 + do j = 1, N_int + det_tmp(j) = 0_bit_kind + enddo + call set_bit_to_integer(k,det_tmp,N_int) + accu_elec = 0 + do j = 1, N_int + det_tmp_bis(j) = iand(det_tmp(j),(psi_in_out(j,spin_exc,i))) + accu_elec += popcnt(det_tmp_bis(j)) + enddo + if(accu_elec == 1)then + phase = phase * -1.d0 + endif + enddo + do j = 1, N_states_in + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * phase + enddo enddo endif + + norm_out = 0.d0 - double precision :: norm_factor do j = 1, N_states_in do i = 1, ndet norm_out(j) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) @@ -337,7 +381,9 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) enddo endif - hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) + hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) +! hij = phase*(mo_mono_elec_integral(m,p) ) ! + fock_operator_active_from_core_inact(m,p) ) +! hij = 0.d0 case (0) hij = diag_H_mat_elem_no_elec_check(key_i,Nint) diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f index 7a506435..11ec6db5 100644 --- a/src/Determinants/diagonalize_CI.irp.f +++ b/src/Determinants/diagonalize_CI.irp.f @@ -92,7 +92,7 @@ END_PROVIDER call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) s2_eigvalues(j) = s2 print*, 's2 in lapack',s2 - print*, eigenvalues(j) + print*, eigenvalues(j) + nuclear_repulsion ! Select at least n_states states with S^2 values closed to "expected_s2" if(dabs(s2-expected_s2).le.0.3d0)then i_state +=1 From 82a29d560322182e88248d1f0a332ee6d1dd9a6d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 11 Oct 2016 19:03:23 +0200 Subject: [PATCH 27/32] no vvv integrals is ok --- config/ifort.cfg | 2 +- plugins/FOBOCI/dress_simple.irp.f | 12 +- plugins/FOBOCI/fobo_scf.irp.f | 2 +- .../foboci_lmct_mlct_threshold_old.irp.f | 23 +- plugins/FOBOCI/routines_foboci.irp.f | 12 +- plugins/MRPT_Utils/energies_cas.irp.f | 713 ++++++++++++- plugins/MRPT_Utils/excitations_cas.irp.f | 288 ++++- plugins/MRPT_Utils/mrpt_dress.irp.f | 6 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 24 +- plugins/MRPT_Utils/new_way.irp.f | 565 ++++++++++ plugins/MRPT_Utils/psi_active_prov.irp.f | 75 +- plugins/Perturbation/pt2_equations.irp.f | 5 + plugins/Properties/hyperfine_constants.irp.f | 5 + plugins/Selectors_full/zmq.irp.f | 9 +- src/Bitmask/bitmask_cas_routines.irp.f | 21 + src/Bitmask/bitmasks.irp.f | 22 +- src/Determinants/create_excitations.irp.f | 66 ++ src/Determinants/s2.irp.f | 2 +- src/Determinants/slater_rules.irp.f | 134 +-- src/Integrals_Bielec/EZFIO.cfg | 2 +- src/Integrals_Bielec/mo_bi_integrals.irp.f | 992 +++++++++++++++++- src/Utils/map_module.f90 | 23 + 22 files changed, 2838 insertions(+), 165 deletions(-) diff --git a/config/ifort.cfg b/config/ifort.cfg index a738a83c..da414912 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -18,7 +18,7 @@ IRPF90_FLAGS : --ninja --align=32 # 0 : Deactivate # [OPTION] -MODE : DEBUG ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below CACHE : 1 ; Enable cache_compile.py OPENMP : 1 ; Append OpenMP flags diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index 021aa422..8a51c4fe 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -89,11 +89,11 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen end -subroutine is_a_good_candidate(threshold,is_ok,verbose) +subroutine is_a_good_candidate(threshold,is_ok,verbose,exit_loop) use bitmasks implicit none double precision, intent(in) :: threshold - logical, intent(out) :: is_ok + logical, intent(out) :: is_ok,exit_loop logical, intent(in) :: verbose integer :: l,k,m @@ -111,7 +111,7 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose) enddo enddo !call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input) - call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) + call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop) if(do_it_perturbative)then if(is_ok)then N_det = N_det_generators @@ -135,14 +135,14 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose) end -subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose) +subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop) use bitmasks implicit none integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) integer, intent(in) :: Ndet_generators double precision, intent(in) :: threshold logical, intent(in) :: verbose - logical, intent(out) :: is_ok + logical, intent(out) :: is_ok,exit_loop double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states) double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) @@ -151,6 +151,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average logical :: is_a_ref_det(Ndet_generators) + exit_loop = .False. is_a_ref_det = .False. do i = 1, N_det_generators @@ -191,6 +192,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. + exit_loop = .True. return endif endif diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8656b633..0b0902b0 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,6 +1,6 @@ program foboscf implicit none - call run_prepare +!call run_prepare no_oa_or_av_opt = .True. touch no_oa_or_av_opt call routine_fobo_scf diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index e81b3fc1..a072a918 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -38,6 +38,7 @@ subroutine FOBOCI_lmct_mlct_old_thr integer(bit_kind) , allocatable :: psi_singles(:,:,:) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) + logical :: exit_loop allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. @@ -55,7 +56,7 @@ subroutine FOBOCI_lmct_mlct_old_thr print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) - call is_a_good_candidate(threshold_lmct,is_ok,verbose) + call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop) print*,'is_ok = ',is_ok if(.not.is_ok)cycle allocate(dressing_matrix(N_det_generators,N_det_generators)) @@ -161,9 +162,9 @@ subroutine FOBOCI_lmct_mlct_old_thr print*,'--------------------------' ! First set the current generators to the one of restart + call check_symetry(i_particl_osoci,thr,test_sym) call set_generators_to_generators_restart call set_psi_det_to_generators - call check_symetry(i_particl_osoci,thr,test_sym) if(.not.test_sym)cycle print*,'i_particl_osoci= ',i_particl_osoci ! Initialize the bitmask to the restart ones @@ -180,9 +181,15 @@ subroutine FOBOCI_lmct_mlct_old_thr call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) !! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,verbose) + call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop) print*,'is_ok = ',is_ok - if(.not.is_ok)cycle + if(.not. is_ok)then + if(exit_loop)then + exit + else + cycle + endif + endif allocate(dressing_matrix(N_det_generators,N_det_generators)) if(.not.do_it_perturbative)then dressing_matrix = 0.d0 @@ -234,7 +241,7 @@ subroutine FOBOCI_mlct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - logical :: verbose,is_ok + logical :: verbose,is_ok,exit_loop verbose = .False. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -274,7 +281,7 @@ subroutine FOBOCI_mlct_old call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) ! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,verbose) + call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop) print*,'is_ok = ',is_ok is_ok =.True. if(.not.is_ok)cycle @@ -308,7 +315,7 @@ subroutine FOBOCI_lmct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - logical :: verbose,is_ok + logical :: verbose,is_ok,exit_loop verbose = .False. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -346,7 +353,7 @@ subroutine FOBOCI_lmct_old call set_generators_to_psi_det call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) - call is_a_good_candidate(threshold_lmct,is_ok,verbose) + call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop) print*,'is_ok = ',is_ok if(.not.is_ok)cycle ! ! so all the mono excitation on the new generators diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 4aca60d7..3ecd7977 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -212,8 +212,8 @@ subroutine update_density_matrix_osoci integer :: iorb,jorb do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) - one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) + one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) enddo enddo @@ -588,14 +588,14 @@ end integer :: i double precision :: accu_tot,accu_sd print*,'touched the one_body_dm_mo_beta' - one_body_dm_mo_alpha = one_body_dm_mo_alpha_osoci - one_body_dm_mo_beta = one_body_dm_mo_beta_osoci + one_body_dm_mo_alpha_average = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta_average = one_body_dm_mo_beta_osoci touch one_body_dm_mo_alpha one_body_dm_mo_beta accu_tot = 0.d0 accu_sd = 0.d0 do i = 1, mo_tot_num - accu_tot += one_body_dm_mo_alpha(i,i) + one_body_dm_mo_beta(i,i) - accu_sd += one_body_dm_mo_alpha(i,i) - one_body_dm_mo_beta(i,i) + accu_tot += one_body_dm_mo_alpha_average(i,i) + one_body_dm_mo_beta_average(i,i) + accu_sd += one_body_dm_mo_alpha_average(i,i) - one_body_dm_mo_beta_average(i,i) enddo print*,'accu_tot = ',accu_tot print*,'accu_sdt = ',accu_sd diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index fb52a719..ac399ce7 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -10,14 +10,28 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] END_PROVIDER +BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] + implicit none + integer :: i + double precision :: energies(N_states_diag) + do i = 1, N_states + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + energy_cas_dyall_no_exchange(i) = energies(i) + print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,N_det) - double precision :: psi_in_out_coef(N_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) use bitmasks integer :: iorb @@ -45,6 +59,7 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -54,9 +69,10 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: ispin integer :: orb, hole_particle,spin_exc double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb integer :: state_target @@ -83,6 +99,7 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -93,9 +110,10 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target @@ -131,6 +149,7 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -141,9 +160,10 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target @@ -178,6 +198,7 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -188,10 +209,11 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target double precision :: energies(n_states_diag) @@ -205,23 +227,28 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) + do state_target = 1, N_states + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + if(orb_i == orb_j .and. ispin .ne. jspin)then + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + else + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + endif enddo - enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - enddo enddo enddo enddo @@ -229,6 +256,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 END_PROVIDER + BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j @@ -237,9 +265,10 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb @@ -286,6 +315,7 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -297,9 +327,10 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb @@ -345,6 +376,7 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -356,9 +388,10 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb @@ -404,6 +437,7 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER @@ -415,9 +449,10 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k double precision :: norm_out(N_states_diag) - integer(bit_kind) :: psi_in_out(N_int,2,n_det) - double precision :: psi_in_out_coef(n_det,N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb @@ -463,5 +498,617 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo enddo enddo + deallocate(psi_in_out,psi_in_out_coef) END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt, (n_inact_orb,n_virt_orb,N_States)] +&BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_norm, (n_inact_orb,n_virt_orb,N_States,2)] + implicit none + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + + integer :: iorb,jorb,i_ok + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) + double precision :: energies_alpha_beta(N_states,2) + + + double precision :: thresh_norm + + thresh_norm = 1.d-10 + + + + do vorb = 1,n_virt_orb + orb_v = list_virt(vorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) + norm = 0.d0 + norm_bis = 0.d0 + do ispin = 1,2 + do state_target =1 , N_states + one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 + enddo + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + print*, orb_i,orb_v + call debug_det(psi_in_out,N_int) + print*, 'pb, i_ok ne 0 !!!' + endif + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + do j = 1, n_states + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + enddo + enddo + do j = 1, N_states + if (dabs(norm(j,ispin)) .le. thresh_norm)then + norm(j,ispin) = 0.d0 + norm_no_inv(j,ispin) = norm(j,ispin) + one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 + else + norm_no_inv(j,ispin) = norm(j,ispin) + one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) + norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) + endif + enddo + do i = 1, N_det + do j = 1, N_states + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) + norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + enddo + do state_target = 1, N_states + energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) +! energies_alpha_beta(state_target, ispin) = 0.d0 + if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + energies_alpha_beta(state_target, ispin) += energies(state_target) + endif + enddo + enddo ! ispin + do state_target = 1, N_states + if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then +! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & +! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & +! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & + /( norm_bis(state_target,1) + norm_bis(state_target,2) ) + else + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 + endif + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_States)] + implicit none + integer :: i,iorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + double precision :: norm_out(N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + + integer :: jorb,i_ok,aorb,orb_a + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: norm(N_states,2),norm_no_inv(N_states,2) + double precision :: energies_alpha_beta(N_states,2) + double precision :: norm_alpha_beta(N_states,2) + + double precision :: thresh_norm + + thresh_norm = 1.d-10 + + do aorb = 1,n_act_orb + orb_a = list_act(aorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) + do state_target = 1, N_states + one_anhil_inact(iorb,aorb,state_target) = 0.d0 + enddo + norm_alpha_beta = 0.d0 + norm = 0.d0 + norm_bis = 0.d0 + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) + if(i_ok.ne.1)then + do j = 1, n_states + psi_in_out_coef(i,j) = 0.d0 + enddo + else + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + do j = 1, n_states + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + enddo + endif + enddo + do j = 1, N_states + if (dabs(norm(j,ispin)) .le. thresh_norm)then + norm(j,ispin) = 0.d0 + norm_no_inv(j,ispin) = norm(j,ispin) + else + norm_no_inv(j,ispin) = norm(j,ispin) + norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) + endif + enddo + double precision :: norm_bis(N_states,2) + do i = 1, N_det + do j = 1, N_states + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) + norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = iand(psi_in_out(j,1,i),cas_bitmask(j,1,1)) + psi_in_out(j,2,i) = iand(psi_in_out(j,2,i),cas_bitmask(j,1,1)) + enddo + enddo + do state_target = 1, N_states + energies_alpha_beta(state_target, ispin) = 0.d0 + if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + energies_alpha_beta(state_target, ispin) += energies(state_target) + endif + enddo + enddo ! ispin + do state_target = 1, N_states + if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then + one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & + /( norm_bis(state_target,1) + norm_bis(state_target,2) ) + else + one_anhil_inact(iorb,aorb,state_target) = 0.d0 + endif +! print*, '********' +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) +! print*, one_anhil_inact(iorb,aorb,state_target) +! print*, one_creat(aorb,1,state_target) + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_States)] + implicit none + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + + integer :: iorb,jorb,i_ok,aorb,orb_a + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: norm(N_states,2),norm_no_inv(N_states,2) + double precision :: energies_alpha_beta(N_states,2) + double precision :: norm_alpha_beta(N_states,2) + + double precision :: thresh_norm + + thresh_norm = 1.d-10 + + do aorb = 1,n_act_orb + orb_a = list_act(aorb) + do vorb = 1, n_virt_orb + orb_v = list_virt(vorb) + do state_target = 1, N_states + one_creat_virt(aorb,vorb,state_target) = 0.d0 + enddo + norm_alpha_beta = 0.d0 + norm = 0.d0 + norm_bis = 0.d0 + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + do j = 1, n_states + psi_in_out_coef(i,j) = 0.d0 + enddo + else + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + do j = 1, n_states + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + enddo + endif + enddo + do j = 1, N_states + if (dabs(norm(j,ispin)) .le. thresh_norm)then + norm(j,ispin) = 0.d0 + norm_no_inv(j,ispin) = norm(j,ispin) + else + norm_no_inv(j,ispin) = norm(j,ispin) + norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) + endif + enddo + double precision :: norm_bis(N_states,2) + do i = 1, N_det + do j = 1, N_states + psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) + norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = iand(psi_in_out(j,1,i),cas_bitmask(j,1,1)) + psi_in_out(j,2,i) = iand(psi_in_out(j,2,i),cas_bitmask(j,1,1)) + enddo + enddo + do state_target = 1, N_states + energies_alpha_beta(state_target, ispin) = 0.d0 + if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) +! print*, energies(state_target) + energies_alpha_beta(state_target, ispin) += energies(state_target) + endif + enddo + enddo ! ispin + do state_target = 1, N_states + if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then + one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & + /( norm_bis(state_target,1) + norm_bis(state_target,2) ) + else + one_creat_virt(aorb,vorb,state_target) = 0.d0 + endif +! print*, '********' +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) +! print*, one_creat_virt(aorb,vorb,state_target) +! print*, one_anhil(aorb,1,state_target) + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] +&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] + implicit none + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: delta_e_inact_virt(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1)) + + integer :: iorb,jorb,i_ok + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: energies_alpha_beta(N_states,2) + + + double precision :: accu(N_states),norm + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + + corr_e_from_1h1p = 0.d0 + do vorb = 1,n_virt_orb + orb_v = list_virt(vorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) +! print*, '---------------------------------------------------------------------------' + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & + - fock_virt_total_spin_trace(orb_v,j) + enddo + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + print*, orb_i,orb_v + call debug_det(psi_in_out,N_int) + print*, 'pb, i_ok ne 0 !!!' + endif + interact_psi0(i) = 0.d0 + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + interact_psi0(i) += hij * psi_coef(j,1) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) + diag_elem(i) = hij + enddo + do state_target = 1, N_states + ! Building the Hamiltonian matrix + H_matrix(1,1) = energy_cas_dyall(state_target) + do i = 1, N_det + ! interaction with psi0 + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + ! diagonal elements + H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) +! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) + do j = i+1, N_det + call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) + H_matrix(i+1,j+1) = hij !0.d0 ! + H_matrix(j+1,i+1) = hij !0.d0 ! + enddo + enddo + print*, '***' + do i = 1, N_det+1 + write(*,'(100(F16.10,X))')H_matrix(i,:) + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) + norm = 0.d0 + do i = 1, N_det + psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) +!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then + if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then +! if(dabs(interact_psi0(i)) .gt. 1.d-8)then + delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) +! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) + amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) + else + amplitudes_alpha_beta(i,ispin) = 0.d0 + delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) + endif +!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) + norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) + enddo + print*, 'Coef ' + write(*,'(100(X,F16.10))')psi_coef(1:N_det,state_target) + write(*,'(100(X,F16.10))')psi_in_out_coef(:,state_target) + double precision :: coef_tmp(N_det) + do i = 1, N_det + coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) + enddo + write(*,'(100(X,F16.10))')coef_tmp(:) + print*, 'naked interactions' + write(*,'(100(X,F16.10))')interact_psi0(:) + print*, '' + + print*, 'norm ',norm + norm = 1.d0/(norm) + accu(state_target) = 0.d0 + do i = 1, N_det + accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) + do j = i+1, N_det + accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) + enddo + enddo + accu(state_target) = accu(state_target) * norm + print*, delta_e_inact_virt(state_target) + print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) + print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) + + enddo + enddo ! ispin + do state_target = 1, N_states + do i = 1, N_det + one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & + ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) + enddo + enddo + print*, '***' + write(*,'(100(X,F16.10))') + write(*,'(100(X,F16.10))')delta_e_alpha_beta(:,2) + ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) + ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) + print*, '---------------------------------------------------------------------------' + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) + print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) + +END_PROVIDER + +subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) + double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: delta_e_inact_virt(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) + double precision, allocatable :: delta_e_det(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) + allocate (delta_e_det(N_det,N_det)) + + integer :: iorb,jorb,i_ok + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: energies_alpha_beta(N_states,2) + double precision :: lamda_pt2(N_det) + + + double precision :: accu(N_states),norm + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + double precision :: coef_array(N_states) + double precision :: coef_perturb(N_det) + double precision :: coef_perturb_bis(N_det) + + do vorb = 1,n_virt_orb + orb_v = list_virt(vorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & + - fock_virt_total_spin_trace(orb_v,j) + enddo + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + print*, orb_i,orb_v + call debug_det(psi_in_out,N_int) + print*, 'pb, i_ok ne 0 !!!' + endif + interact_psi0(i) = 0.d0 + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + interact_cas(i,j) = hij + interact_psi0(i) += hij * psi_coef(j,1) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) + diag_elem(i) = hij + enddo + do state_target = 1, N_states + ! Building the Hamiltonian matrix + H_matrix(1,1) = energy_cas_dyall(state_target) + do i = 1, N_det + ! interaction with psi0 + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + ! diagonal elements + H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) +! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) + do j = i+1, N_det + call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) + H_matrix(i+1,j+1) = hij !0.d0 ! + H_matrix(j+1,i+1) = hij !0.d0 ! + enddo + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) + + do i = 1, N_det + psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) + coef_perturb(i) = 0.d0 + do j = 1, N_det + coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) + enddo + coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) + if(dabs(interact_psi0(i)) .gt. 1.d-12)then + lamda_pt2(i) = psi_in_out_coef(i,state_target) / interact_psi0(i) + else + lamda_pt2(i) =energy_cas_dyall(state_target) - H_matrix(i+1,i+1) + endif + enddo + if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then + print*, '' + do i = 1, N_det+1 + write(*,'(100(F16.10))') H_matrix(i,:) + enddo + accu = 0.d0 + do i = 1, N_det + accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) + enddo + print*, '' + print*, 'e corr diagonal ',accu(state_target) + accu = 0.d0 + do i = 1, N_det + accu(state_target) += coef_perturb(i) * interact_psi0(i) + enddo + print*, 'e corr perturb ',accu(state_target) + accu = 0.d0 + do i = 1, N_det + accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) + enddo + print*, 'e corr perturb EN',accu(state_target) + print*, '' + print*, 'coef diagonalized' + write(*,'(100(F16.10,X))')psi_in_out_coef(:,state_target) + print*, 'coef_perturb' + write(*,'(100(F16.10,X))')coef_perturb(:) + print*, 'coef_perturb EN' + write(*,'(100(F16.10,X))')coef_perturb_bis(:) + endif + integer :: k + do k = 1, N_det + do i = 1, N_det + matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) + do j = i+1, N_det + matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) + matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) + enddo + enddo + enddo + enddo + enddo ! ispin + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues,interact_cas) + deallocate(delta_e_det) +end diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 213abf7b..805070f7 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -382,8 +382,6 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) -! hij = phase*(mo_mono_elec_integral(m,p) ) ! + fock_operator_active_from_core_inact(m,p) ) -! hij = 0.d0 case (0) hij = diag_H_mat_elem_no_elec_check(key_i,Nint) @@ -422,3 +420,289 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe energies(state_target) = accu deallocate(psi_coef_tmp) end + + +double precision function coulomb_value_no_check(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer :: i, j, iorb, jorb + integer :: occ(Nint*bit_kind_size,2) + integer :: elec_num_tab_local(2) + + double precision :: core_act + double precision :: alpha_alpha + double precision :: alpha_beta + double precision :: beta_beta + double precision :: mono_elec + core_act = 0.d0 + alpha_alpha = 0.d0 + alpha_beta = 0.d0 + beta_beta = 0.d0 + mono_elec = 0.d0 + + coulomb_value_no_check = 0.d0 + call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) + call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) + ! alpha - alpha + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + do j = i+1, elec_num_tab_local(1) + jorb = occ(j,1) + coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb) + alpha_alpha += mo_bielec_integral_jj_anti(jorb,iorb) + enddo + enddo + + ! beta - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = i+1, elec_num_tab_local(2) + jorb = occ(j,2) + coulomb_value_no_check += mo_bielec_integral_jj_anti(jorb,iorb) + beta_beta += mo_bielec_integral_jj_anti(jorb,iorb) + enddo + enddo + + + ! alpha - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, elec_num_tab_local(1) + jorb = occ(j,1) + coulomb_value_no_check += mo_bielec_integral_jj(jorb,iorb) + alpha_beta += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + +end + +subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_schwartz + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_no_elec_check_no_exchange, phase,phase_2 + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,2,2) .and. exc(1,2,1) == exc(1,1,2))then + hij = 0.d0 + else + hij = phase*get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) + + case (0) + hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) + end select +end + + +double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer :: i, j, iorb, jorb + integer :: occ(Nint*bit_kind_size,2) + integer :: elec_num_tab_local(2) + + double precision :: core_act_exchange(2) + core_act_exchange = 0.d0 + diag_H_mat_elem_no_elec_check_no_exchange = 0.d0 + call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) + call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) + ! alpha - alpha + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + ! beta - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(2) + jorb = occ(j,2) + diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - core-act + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo + + ! beta - core-act + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo + +end + +subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) + use bitmasks + implicit none + integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target + integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) + double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) + double precision, intent(out) :: energies(N_states_in) + + integer :: i,j + double precision :: hij,accu + energies = 0.d0 + accu = 0.d0 + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(ndet)) + + do i = 1, ndet + psi_coef_tmp(i) = psi_in_coef(i,state_target) + enddo + + double precision :: hij_bis + do i = 1, ndet + if(psi_coef_tmp(i)==0.d0)cycle + do j = 1, ndet + if(psi_coef_tmp(j)==0.d0)cycle + call i_H_j_dyall_no_exchange(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) + accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij + enddo + enddo + energies(state_target) = accu + deallocate(psi_coef_tmp) +end diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 0c8ec98c..275af0e4 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -79,8 +79,12 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),delta_e) call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + double precision :: coef_array(N_states) + do i_state = 1, N_states + coef_array(i_state) = psi_coef(index_i,i_state) + enddo + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) hij_array(index_i) = hialpha call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) ! phase_array(index_i) = phase diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index e298ae67..c1da3670 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -57,6 +57,9 @@ ! 1h1p delta_ij_tmp = 0.d0 call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) + double precision :: e_corr_from_1h1p_singles(N_states) +!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) +!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) accu = 0.d0 do i_state = 1, N_states do i = 1, N_det @@ -69,6 +72,23 @@ enddo print*, '1h1p = ',accu + ! 1h1p third order + delta_ij_tmp = 0.d0 + call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) +!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) +!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p(3)',accu + ! 2h delta_ij_tmp = 0.d0 call H_apply_mrpt_2h(delta_ij_tmp,N_det) @@ -101,6 +121,7 @@ ! 1h2p delta_ij_tmp = 0.d0 +!call give_1h2p_contrib(delta_ij_tmp) call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states @@ -116,6 +137,7 @@ ! 2h1p delta_ij_tmp = 0.d0 +!call give_2h1p_contrib(delta_ij_tmp) call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) accu = 0.d0 do i_state = 1, N_states @@ -159,7 +181,7 @@ accu = 0.d0 do i_state = 1, N_states do i = 1, N_det - write(*,'(1000(F16.10,x))')delta_ij(i,:,:) +! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) do j = i_state, N_det accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) enddo diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index 8cf6ec5f..09016ab0 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -391,3 +391,568 @@ subroutine give_1h2p_contrib(matrix_1h2p) end + + +subroutine give_1h1p_contrib(matrix_1h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_inact_virt(N_states) + integer :: kspin,degree_scalar +!matrix_1h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & + - fock_virt_total_spin_trace(rorb,j) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + do jdet = 1, idx(0) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + double precision :: himono,delta_e(N_states),coef_mono(N_states) + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + + do state_target = 1, N_states +! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) + delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) + coef_mono(state_target) = himono / delta_e(state_target) + enddo + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + ! Mono beta + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(ispin == jspin )then + hij = -get_mo_bielec_integral_schwartz(iorb,aorb,rorb,borb,mo_integrals_map) & + + get_mo_bielec_integral_schwartz(iorb,aorb,borb,rorb,mo_integrals_map) + else + hij = get_mo_bielec_integral_schwartz(iorb,borb,rorb,aorb,mo_integrals_map) + endif + hij = hij * phase + double precision :: hij_test + integer :: state_target + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + if(dabs(hij - hij_test).gt.1.d-10)then + print*, 'ahah pb !!' + print*, 'hij .ne. hij_test' + print*, hij,hij_test + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + print*, ispin, jspin + print*,iorb,borb,rorb,aorb + print*, phase + call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + stop + endif + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) + enddo + else + do state_target = 1, N_states + matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) + enddo + endif + enddo + enddo + + + + enddo + enddo + enddo +end + +subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb,s,sorb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2) + integer(bit_kind) :: det_pert(N_int,2,n_inact_orb,n_virt_orb,2) + double precision :: coef_det_pert(n_inact_orb,n_virt_orb,2,N_states,2) + double precision :: delta_e_det_pert(n_inact_orb,n_virt_orb,2,N_states) + double precision :: hij_det_pert(n_inact_orb,n_virt_orb,2,N_states) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_inact_virt(N_states) + integer :: kspin,degree_scalar +!matrix_1h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + double precision :: himono,delta_e(N_states),coef_mono(N_states) + integer :: state_target + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) = 0.d0 + coef_det_pert(i,r,ispin,state_target,2) = 0.d0 + enddo + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & + - fock_virt_total_spin_trace(rorb,j) + enddo + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + do inint = 1, N_int + det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) + det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) + enddo + do state_target = 1, N_states + delta_e_det_pert(i,r,ispin,state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) + coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target) + enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + enddo ! ispin + enddo ! rorb + enddo ! iorb + + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do inint = 1, N_int + det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) + det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) + enddo + do j = 1, n_inact_orb ! First inactive + jorb = list_inact(j) + do s = 1, n_virt_orb ! First virtual + sorb = list_virt(s) + do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r) + if(i==j.and.r==s.and.ispin==jspin)cycle + do inint = 1, N_int + det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin) + det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin) + enddo + call i_H_j(det_tmp_bis,det_tmp,N_int,himono) + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,2) += & + coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target) + enddo + enddo + enddo + enddo + enddo ! ispin + enddo ! rorb + enddo ! iorb + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) + enddo + + do inint = 1, N_int + det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) + det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) + enddo + do jdet = 1, idx(0) +! + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + double precision :: hij_test + hij_test = 0.d0 + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + enddo + else + hij_test = 0.d0 + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) + do state_target = 1, N_states + matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + enddo + endif + enddo + enddo + enddo + enddo + + enddo ! idet +end + + +subroutine give_1p_sec_order_singles_contrib(matrix_1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb,s,sorb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2),det_tmp_bis(N_int,2) + integer(bit_kind) :: det_pert(N_int,2,n_act_orb,n_virt_orb,2) + double precision :: coef_det_pert(n_act_orb,n_virt_orb,2,N_states,2) + double precision :: delta_e_det_pert(n_act_orb,n_virt_orb,2,N_states) + double precision :: hij_det_pert(n_act_orb,n_virt_orb,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_act_virt(N_states) + integer :: kspin,degree_scalar +!matrix_1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + double precision :: himono,delta_e(N_states),coef_mono(N_states) + integer :: state_target + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do i = 1, n_act_orb ! First active + iorb = list_act(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) = 0.d0 + coef_det_pert(i,r,ispin,state_target,2) = 0.d0 + enddo + do j = 1, N_states + delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) + enddo + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation active -- > virtual + call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) + integer :: i_ok + if(i_ok .ne.1)then + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) = -1.d+10 + coef_det_pert(i,r,ispin,state_target,2) = -1.d+10 + hij_det_pert(i,r,ispin) = 0.d0 + enddo + do inint = 1, N_int + det_pert(inint,1,i,r,ispin) = 0_bit_kind + det_pert(inint,2,i,r,ispin) = 0_bit_kind + enddo + cycle + endif + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + do inint = 1, N_int + det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) + det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) + enddo + do state_target = 1, N_states + delta_e_det_pert(i,r,ispin,state_target) = one_creat_virt(i,r,state_target) + delta_e_act_virt(state_target) + coef_det_pert(i,r,ispin,state_target,1) = himono / delta_e_det_pert(i,r,ispin,state_target) + hij_det_pert(i,r,ispin) = himono + enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + enddo ! ispin + enddo ! rorb + enddo ! iorb + +! do i = 1, n_act_orb ! First active +! do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) +! if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle +! iorb = list_act(i) +! do r = 1, n_virt_orb ! First virtual +! rorb = list_virt(r) +! do inint = 1, N_int +! det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) +! det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) +! enddo +! do j = 1, n_act_orb ! First active +! do jspin = 1, 2 ! spin of the couple a-a^dagger (i,r) +! if(coef_det_pert(j,1,jspin,1,1) == -1.d+10)cycle +! jorb = list_act(j) +! do s = 1, n_virt_orb ! First virtual +! sorb = list_virt(s) +! if(i==j.and.r==s.and.ispin==jspin)cycle +! do inint = 1, N_int +! det_tmp_bis(inint,1) = det_pert(inint,1,j,s,jspin) +! det_tmp_bis(inint,2) = det_pert(inint,2,j,s,jspin) +! enddo +! call i_H_j(det_tmp_bis,det_tmp,N_int,himono) +! do state_target = 1, N_states +! coef_det_pert(i,r,ispin,state_target,2) += & +! coef_det_pert(j,s,jspin,state_target,1) * himono / delta_e_det_pert(i,r,ispin,state_target) +! enddo +! enddo +! enddo +! enddo +! enddo ! ispin +! enddo ! rorb +! enddo ! iorb + + do i = 1, n_act_orb ! First active + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + if(coef_det_pert(i,1,ispin,1,1) == -1.d+10)cycle + iorb = list_act(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) +! do state_target = 1, N_states +! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) +! enddo + do inint = 1, N_int + det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) + det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) + enddo + do jdet = 1,N_det + double precision :: coef_array(N_states),hij_test + call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + do state_target = 1, N_states +! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) + matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) + enddo + enddo + enddo + enddo + enddo + + enddo ! idet +end + + + +subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral_schwartz + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_inact_virt(N_states) + integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) + double precision :: pert_det_coef(n_act_orb,n_act_orb,2,N_states) + integer :: kspin,degree_scalar + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 + double precision :: hidouble,delta_e(N_states) +!matrix_1h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & + - fock_virt_total_spin_trace(rorb,j) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + do ispin = 1, 2 + jspin = other_spin(ispin) + do a = 1, n_act_orb + aorb = list_act(a) + do b = 1, n_act_orb + borb = list_act(b) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) + integer :: i_ok,corb,dorb + call do_mono_excitation(det_tmp,iorb,aorb,ispin,i_ok) + if(i_ok .ne. 1)then + do state_target = 1, N_states + pert_det_coef(a,b,ispin,state_target) = -100000.d0 + enddo + do inint = 1, N_int + pert_det(inint,1,a,b,ispin) = 0_bit_kind + pert_det(inint,2,a,b,ispin) = 0_bit_kind + enddo + cycle + endif + call do_mono_excitation(det_tmp,borb,rorb,jspin,i_ok) + if(i_ok .ne. 1)then + do state_target = 1, N_states + pert_det_coef(a,b,ispin,state_target) = -100000.d0 + enddo + do inint = 1, N_int + pert_det(inint,1,a,b,ispin) = 0_bit_kind + pert_det(inint,2,a,b,ispin) = 0_bit_kind + enddo + cycle + endif + do inint = 1, N_int + pert_det(inint,1,a,b,ispin) = det_tmp(inint,1) + pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) + enddo + + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) + do state_target = 1, N_states + delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) + pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) + matrix_1h1p(idet,idet,state_target) += hidouble * pert_det_coef(a,b,ispin,state_target) + enddo + enddo + enddo + enddo + do jdet = 1, idx(0) + if(idx(jdet).ne.idet)then + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + integer :: c,d,state_target + integer(bit_kind) :: det_tmp_bis(N_int,2) + ! excitation from I --> J + ! (a->c) (alpha) + (b->d) (beta) + aorb = exc(1,1,1) + corb = exc(1,2,1) + c = list_act_reverse(corb) + borb = exc(1,1,2) + dorb = exc(1,2,2) + d = list_act_reverse(dorb) + ispin = 1 + jspin = 2 + do inint = 1, N_int + det_tmp(inint,1) = pert_det(inint,1,c,d,1) + det_tmp(inint,2) = pert_det(inint,2,c,d,1) + det_tmp_bis(inint,1) = pert_det(inint,1,c,d,2) + det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) + enddo + double precision :: hjdouble_1,hjdouble_2 + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) + enddo + endif + enddo + + + + enddo + enddo + enddo + + + + + +end + + diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 5a60d093..b4c7e6f4 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -14,8 +14,6 @@ BEGIN_PROVIDER [integer(bit_kind), psi_active, (N_int,2,psi_det_size)] psi_active(j,1,i) = iand(psi_det(j,1,i),cas_bitmask(j,1,1)) psi_active(j,2,i) = iand(psi_det(j,2,i),cas_bitmask(j,1,1)) enddo - -! call debug_det(psi_active(1,1,i),N_int) enddo END_PROVIDER @@ -154,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end -subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) +subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) BEGIN_DOC ! routine that returns the delta_e with the Moller Plesset and Dyall operators ! @@ -172,6 +170,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) use bitmasks double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: coef_array(N_states),hij integer :: i,j,k,l integer :: i_state @@ -292,23 +291,52 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) ! delta_e_act += one_creat_spin_trace(i_particle_act ) ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) - do i_state = 1, N_states - delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) - enddo + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_inact_reverse(h1) + i_part = list_act_reverse(p1) + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) + enddo + else if (degree == 2)then + do i_state = 1, N_states + delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) + enddo + endif else if (n_holes_act == 1 .and. n_particles_act == 0) then ! i_hole_act = holes_active_list_spin_traced(1) ! delta_e_act += one_anhil_spin_trace(i_hole_act ) ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) - do i_state = 1, N_states - delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) - enddo + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_act_reverse(h1) + i_part = list_virt_reverse(p1) + do i_state = 1, N_states + if(isnan(one_creat_virt(i_hole,i_part,i_state)))then + print*, i_hole,i_part,i_state + call debug_det(det_1,N_int) + call debug_det(det_2,N_int) + stop + endif + delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) + enddo + else if (degree == 2)then + do i_state = 1, N_states + delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) + enddo + endif else if (n_holes_act == 1 .and. n_particles_act == 1) then ! i_hole_act = holes_active_list_spin_traced(1) ! i_particle_act = particles_active_list_spin_traced(1) ! delta_e_act += one_anhil_one_creat_spin_trace(i_hole_act,i_particle_act) + ! first hole ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) @@ -422,6 +450,34 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) do i_state = 1, N_states delta_e_act(i_state) += three_creat(i_particle_act,j_particle_act,k_particle_act,ispin,jspin,kspin,i_state) enddo + + else if (n_holes_act .eq. 0 .and. n_particles_act .eq.0)then + integer :: degree + integer(bit_kind) :: det_1_active(N_int,2) + integer :: h1,h2,p1,p2,s1,s2 + integer :: exc(0:2,2,2) + integer :: i_hole, i_part + double precision :: phase + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree == 1)then +! call debug_det(det_1,N_int) + call get_excitation(det_1,det_2,exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + i_hole = list_inact_reverse(h1) + i_part = list_virt_reverse(p1) + do i_state = 1, N_states +! if(one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1).gt.1.d-10)then +! print*, hij, one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) +! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) & +! * coef_array(i_state)* hij*coef_array(i_state)* hij *one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) +! print*, coef_array(i_state)* hij*coef_array(i_state)* hij,one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1), & +! coef_array(i_state)* hij*coef_array(i_state)* hij *one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) +! else + delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) +! endif + enddo + endif + else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then @@ -438,3 +494,4 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) enddo end + diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 2621a9c6..c284e01e 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -192,6 +192,11 @@ subroutine pt2_moller_plesset ($arguments) endif do i =1,N_st H_pert_diag(i) = h +! if(dabs(i_H_psi_array(i)).gt.1.d-8)then +! print*, i_H_psi_array(i) +! call debug_det(det_pert,N_int) +! print*, h1,p1,h2,p2,s1,s2 +! endif c_pert(i) = i_H_psi_array(i) *delta_e e_2_pert(i) = c_pert(i) * i_H_psi_array(i) enddo diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index e31b3ba4..de14da9f 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -102,6 +102,11 @@ END_PROVIDER conversion_factor_gauss_hcc(3) = 619.9027742370165d0 conversion_factor_cm_1_hcc(3) = 579.4924475562677d0 + ! boron + conversion_factor_mhz_hcc(5) = 1434.3655101868d0 + conversion_factor_gauss_hcc(5) = 511.817264334d0 + conversion_factor_cm_1_hcc(5) = 478.4528336953d0 + ! carbon conversion_factor_mhz_hcc(6) = 1124.18303629792945d0 conversion_factor_gauss_hcc(6) = 401.136570647523058d0 diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 952e5c06..9f6f616c 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -98,7 +98,14 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id) if (N_det_selectors_read > 0) then N_det_selectors = N_det_selectors_read endif - SOFT_TOUCH psi_det psi_coef N_det_selectors N_det_generators + SOFT_TOUCH psi_det psi_coef N_det_selectors N_det_generators psi_coef_generators psi_det_generators +! n_det_generators +! n_det_selectors +! psi_coef +! psi_coef_generators +! psi_det +! psi_det_generators + end diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 5cd09aa2..961be5df 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -541,3 +541,24 @@ use bitmasks end +logical function is_i_in_virtual(i) +use bitmasks + implicit none + integer,intent(in) :: i + integer(bit_kind) :: key(N_int) + integer :: k,j + integer :: accu + is_i_in_virtual = .False. + key= 0_bit_kind + k = ishft(i-1,-bit_kind_shift)+1 + j = i-ishft(k-1,bit_kind_shift)-1 + key(k) = ibset(key(k),j) + accu = 0 + do k = 1, N_int + accu += popcnt(iand(key(k),virt_bitmask(k,1))) + enddo + if(accu .ne. 0)then + is_i_in_virtual = .True. + endif + +end diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index c52ed837..964c4ed8 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -37,7 +37,7 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] enddo END_PROVIDER -BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] + BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] implicit none integer :: i do i=1,N_int @@ -473,17 +473,33 @@ END_PROVIDER BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] +&BEGIN_PROVIDER [ integer, n_core_inact_act_orb ] implicit none BEGIN_DOC ! Reunion of the core, inactive and active bitmasks END_DOC integer :: i,j + n_core_inact_act_orb = 0 do i = 1, N_int reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),cas_bitmask(i,1,1)) reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),cas_bitmask(i,1,1)) + n_core_inact_act_orb +=popcnt(reunion_of_core_inact_act_bitmask(i,1)) enddo END_PROVIDER + BEGIN_PROVIDER [ integer, list_core_inact_act, (n_core_inact_act_orb)] +&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_tot_num)] + implicit none + integer :: occ_inact(N_int*bit_kind_size) + integer :: itest,i + occ_inact = 0 + call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int) + list_inact_reverse = 0 + do i = 1, n_core_inact_act_orb + list_core_inact_act(i) = occ_inact(i) + list_core_inact_act_reverse(occ_inact(i)) = i + enddo +END_PROVIDER @@ -543,8 +559,8 @@ END_PROVIDER integer :: i,j n_core_orb = 0 do i = 1, N_int - core_bitmask(i,1) = xor(closed_shell_ref_bitmask(i,1),reunion_of_cas_inact_bitmask(i,1)) - core_bitmask(i,2) = xor(closed_shell_ref_bitmask(i,2),reunion_of_cas_inact_bitmask(i,2)) + core_bitmask(i,1) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,1),virt_bitmask(i,1))) + core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1))) n_core_orb += popcnt(core_bitmask(i,1)) enddo print*,'n_core_orb = ',n_core_orb diff --git a/src/Determinants/create_excitations.irp.f b/src/Determinants/create_excitations.irp.f index 6af49681..71301dbc 100644 --- a/src/Determinants/create_excitations.irp.f +++ b/src/Determinants/create_excitations.irp.f @@ -37,6 +37,72 @@ subroutine do_mono_excitation(key_in,i_hole,i_particle,ispin,i_ok) endif end +subroutine do_spin_flip(key_in,i_flip,ispin,i_ok) + implicit none + BEGIN_DOC + ! flip the spin ispin in the orbital i_flip + ! on key_in + ! ispin = 1 == alpha + ! ispin = 2 == beta + ! i_ok = 1 == the flip is possible + ! i_ok = -1 == the flip is not possible + END_DOC + integer, intent(in) :: i_flip,ispin + integer(bit_kind), intent(inout) :: key_in(N_int,2) + integer, intent(out) :: i_ok + integer :: k,j,i + integer(bit_kind) :: key_tmp(N_int,2) + i_ok = -1 + key_tmp = 0_bit_kind + k = ishft(i_flip-1,-bit_kind_shift)+1 + j = i_flip-ishft(k-1,bit_kind_shift)-1 + key_tmp(k,1) = ibset(key_tmp(k,1),j) + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 + if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then + ! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip" + key_in(k,ispin) = ibclr(key_in(k,ispin),j) ! destroy the electron ispin in the orbital i_flip + key_in(k,other_spin(ispin)) = ibset(key_in(k,other_spin(ispin)),j) ! create an electron of spin other_spin in the same orbital + i_ok = 1 + else + return + endif + + + +end + +logical function is_spin_flip_possible(key_in,i_flip,ispin) + implicit none + BEGIN_DOC + ! returns .True. if the spin-flip of spin ispin in the orbital i_flip is possible + ! on key_in + END_DOC + integer, intent(in) :: i_flip,ispin + integer(bit_kind), intent(in) :: key_in(N_int,2) + integer :: k,j,i + integer(bit_kind) :: key_tmp(N_int,2) + is_spin_flip_possible = .False. + key_tmp = 0_bit_kind + k = ishft(i_flip-1,-bit_kind_shift)+1 + j = i_flip-ishft(k-1,bit_kind_shift)-1 + key_tmp(k,1) = ibset(key_tmp(k,1),j) + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 + if(popcnt(iand(key_tmp(k,1),key_in(k,ispin))) == 1 .and. popcnt(iand(key_tmp(k,1),key_in(k,other_spin(ispin)))) == 0 )then + ! There is a spin "ispin" in the orbital i_flip AND There is no electron of opposit spin in the same orbital "i_flip" + is_spin_flip_possible = .True. + return + else + return + endif + + + +end + subroutine set_bit_to_integer(i_physical,key,Nint) use bitmasks implicit none diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 9810b219..344e0160 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -334,7 +334,7 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,psi_coefs_inout,n,nmax_keys,nma accu_precision_of_diag = 0.d0 do i = 1, nstates do j = i+1, nstates - if( ( dabs(s2(i,i) - s2(j,j)) .le.1.d-10 ) .and. (dabs(s2(i,j) + dabs(s2(i,j)))) .le.1.d-10) then + if( ( dabs(s2(i,i) - s2(j,j)) .le.0.5d0 ) ) then s2(i,j) = 0.d0 s2(j,i) = 0.d0 endif diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index cb96957a..7f0e7e57 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1389,6 +1389,55 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s l = l+1 endif enddo + else + + print*, 'get_excitation_degree_vector_mono_or_exchange not yet implemented for N_int > 1 ...' + stop + + endif + idx(0) = l-1 +end + + + + +subroutine get_excitation_degree_vector_double_alpha_beta(key1,key2,degree,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Applies get_excitation_degree to an array of determinants and return only the mono excitations + ! and the connections through exchange integrals + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: degree(sze) + integer, intent(out) :: idx(0:sze) + integer(bit_kind) :: key_tmp(Nint,2) + + integer :: i,l,d,m + integer :: degree_alpha, degree_beta + + ASSERT (Nint > 0) + ASSERT (sze > 0) + + l=1 + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + d = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + if (d .ne.4)cycle + key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) + key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) + degree_alpha = popcnt(key_tmp(1,1)) + degree_beta = popcnt(key_tmp(1,2)) + if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin + degree(l) = ishft(d,-1) + idx(l) = i + l = l+1 + enddo else if (Nint==2) then !DIR$ LOOP COUNT (1000) @@ -1397,29 +1446,17 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s popcnt(xor( key1(1,2,i), key2(1,2))) + & popcnt(xor( key1(2,1,i), key2(2,1))) + & popcnt(xor( key1(2,2,i), key2(2,2))) - exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,2),key2(1,2)))) + & - popcnt(xor(ior(key1(2,1,i),key1(2,2,i)),ior(key2(2,2),key2(2,2)))) - exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & - popcnt(ior(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then + if (d .ne.4)cycle + key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) + key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) + key_tmp(2,1) = xor(key1(2,1,i),key2(2,1)) + key_tmp(2,2) = xor(key1(2,2,i),key2(2,2)) + degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) + degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) + if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin degree(l) = ishft(d,-1) idx(l) = i l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif enddo else if (Nint==3) then @@ -1432,31 +1469,19 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s popcnt(xor( key1(2,2,i), key2(2,2))) + & popcnt(xor( key1(3,1,i), key2(3,1))) + & popcnt(xor( key1(3,2,i), key2(3,2))) - exchange_1 = popcnt(xor(ior(key1(1,1,i),key1(1,2,i)),ior(key2(1,1),key2(1,2)))) + & - popcnt(xor(ior(key1(2,1,i),key1(2,2,i)),ior(key2(2,1),key2(2,2)))) + & - popcnt(xor(ior(key1(3,1,i),key1(3,2,i)),ior(key2(3,1),key2(3,2)))) - exchange_2 = popcnt(ior(xor(key1(1,1,i),key2(1,1)),xor(key1(1,2,i),key2(1,2)))) + & - popcnt(ior(xor(key1(2,1,i),key2(2,1)),xor(key1(2,2,i),key2(2,2)))) + & - popcnt(ior(xor(key1(3,1,i),key2(3,1)),xor(key1(3,2,i),key2(3,2)))) - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then + if (d .ne.4)cycle + key_tmp(1,1) = xor(key1(1,1,i),key2(1,1)) + key_tmp(1,2) = xor(key1(1,2,i),key2(1,2)) + key_tmp(2,1) = xor(key1(2,1,i),key2(2,1)) + key_tmp(2,2) = xor(key1(2,2,i),key2(2,2)) + key_tmp(3,1) = xor(key1(3,1,i),key2(3,1)) + key_tmp(3,2) = xor(key1(3,2,i),key2(3,2)) + degree_alpha = popcnt(key_tmp(1,1)) + popcnt(key_tmp(2,1)) + popcnt(key_tmp(3,1)) + degree_beta = popcnt(key_tmp(1,2)) + popcnt(key_tmp(2,2)) + popcnt(key_tmp(3,2)) + if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin degree(l) = ishft(d,-1) idx(l) = i l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif enddo else @@ -1464,39 +1489,26 @@ subroutine get_excitation_degree_vector_mono_or_exchange(key1,key2,degree,Nint,s !DIR$ LOOP COUNT (1000) do i=1,sze d = 0 - exchange_1 = 0 !DIR$ LOOP COUNT MIN(4) do m=1,Nint d = d + popcnt(xor( key1(m,1,i), key2(m,1))) & + popcnt(xor( key1(m,2,i), key2(m,2))) - exchange_1 = popcnt(xor(ior(key1(m,1,i),key1(m,2,i)),ior(key2(m,1),key2(m,2)))) - exchange_2 = popcnt(ior(xor(key1(m,1,i),key2(m,1)),xor(key1(m,2,i),key2(m,2)))) + key_tmp(m,1) = xor(key1(m,1,i),key2(m,1)) + key_tmp(m,2) = xor(key1(m,2,i),key2(m,2)) + degree_alpha = popcnt(key_tmp(m,1)) + degree_beta = popcnt(key_tmp(m,2)) enddo - if (d > 4)cycle - if (d ==4)then - if(exchange_1 .eq. 0 ) then + if(degree_alpha .gt.3 .or. degree_beta .gt.3 )cycle !! no double excitations of same spin degree(l) = ishft(d,-1) idx(l) = i l = l+1 - else if (exchange_1 .eq. 2 .and. exchange_2.eq.2)then - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - else - cycle - endif -! pause - else - degree(l) = ishft(d,-1) - idx(l) = i - l = l+1 - endif enddo endif idx(0) = l-1 end + subroutine get_excitation_degree_vector_mono_or_exchange_verbose(key1,key2,degree,Nint,sze,idx) use bitmasks implicit none diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index feed02c1..04d58236 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -10,7 +10,7 @@ type: logical doc: If True, do not compute the bielectronic integrals when 4 indices are virtual interface: ezfio,provider,ocaml default: False -ezfio_name: None +ezfio_name: no_vvvv_integrals [disk_access_mo_integrals] type: Disk_access diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 3557772d..dae73a01 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -22,6 +22,7 @@ end BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] implicit none integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) BEGIN_DOC ! If True, the map of MO bielectronic integrals is provided @@ -39,44 +40,128 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] if(no_vvvv_integrals)then integer :: i,j,k,l +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 4 + ! + print*, '' + print*, '' do i = 1,N_int mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,3) - mask_ijkl(i,4) = core_inact_act_bitmask_4(i,4) - enddo - call add_integrals_to_map(mask_ijkl) - ! (core+inact+act) ^ 3 (virt) ^1 - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,3) - mask_ijkl(i,4) = virt_bitmask(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) enddo call add_integrals_to_map(mask_ijkl) + call set_integrals_exchange_jj_into_map + call set_integrals_jj_into_map +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 2 (virt) ^2 + ! = J_iv + print*, '' + print*, '' do i = 1,N_int mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,2) - mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,2) = virt_bitmask(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + + ! (core+inact+act) ^ 2 (virt) ^2 + ! = (iv|iv) + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! + print*, '' + print*, '' + do i = 1,N_int + mask_ijk(i,1) = virt_bitmask(i,1) + mask_ijk(i,2) = virt_bitmask(i,1) + mask_ijk(i,3) = virt_bitmask(i,1) + enddo + call add_integrals_to_map_three_indices(mask_ijk) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! + ! (core+inact+act) ^ 3 (virt) ^1 + ! + print*, '' + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) mask_ijkl(i,4) = virt_bitmask(i,1) enddo call add_integrals_to_map(mask_ijkl) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 1 (virt) ^3 + ! + print*, '' + print*, '' do i = 1,N_int mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) mask_ijkl(i,2) = virt_bitmask(i,1) mask_ijkl(i,3) = virt_bitmask(i,1) mask_ijkl(i,4) = virt_bitmask(i,1) enddo - call add_integrals_to_map(mask_ijkl) - + call add_integrals_to_map_no_exit_34(mask_ijkl) + else call add_integrals_to_map(full_ijkl_bitmask_4) endif END_PROVIDER +subroutine set_integrals_jj_into_map + use bitmasks + implicit none + integer :: i,j,n_integrals,i0,j0 + double precision :: buffer_value(mo_tot_num * mo_tot_num) + integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) + n_integrals = 0 + do j0 = 1, n_virt_orb + j = list_virt(j0) + do i0 = j0, n_virt_orb + i = list_virt(i0) + n_integrals += 1 +! mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) + call mo_bielec_integrals_index(i,j,i,j,buffer_i(n_integrals)) + buffer_value(n_integrals) = mo_bielec_integral_vv_from_ao(i,j) + enddo + enddo + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + call map_unique(mo_integrals_map) +end + +subroutine set_integrals_exchange_jj_into_map + use bitmasks + implicit none + integer :: i,j,n_integrals,i0,j0 + double precision :: buffer_value(mo_tot_num * mo_tot_num) + integer(key_kind) :: buffer_i(mo_tot_num*mo_tot_num) + n_integrals = 0 + do j0 = 1, n_virt_orb + j = list_virt(j0) + do i0 = j0+1, n_virt_orb + i = list_virt(i0) + n_integrals += 1 + call mo_bielec_integrals_index(i,j,j,i,buffer_i(n_integrals)) + buffer_value(n_integrals) = mo_bielec_integral_vv_exchange_from_ao(i,j) + enddo + enddo + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + call map_unique(mo_integrals_map) + +end + subroutine add_integrals_to_map(mask_ijkl) use bitmasks implicit none @@ -115,6 +200,672 @@ subroutine add_integrals_to_map(mask_ijkl) !Get list of MOs for i,j,k and l !------------------------------- + allocate(list_ijkl(mo_tot_num,4)) + call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) + call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) + call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) + call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) + character*(2048) :: output(1) + print*, 'i' + call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,1)) + enddo + if(j==0)then + return + endif + + print*, 'j' + call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,2)) + enddo + if(j==0)then + return + endif + + print*, 'k' + call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,3)) + enddo + if(j==0)then + return + endif + + print*, 'l' + call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,4)) + enddo + if(j==0)then + return + endif + + size_buffer = min(ao_num*ao_num*ao_num,16000000) + print*, 'Providing the molecular integrals ' + print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& + ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' + + call wall_time(wall_1) + call cpu_time(cpu_1) + double precision :: accu_bis + accu_bis = 0.d0 + + !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & + !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& + !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & + !$OMP wall_0,thread_num,accu_bis) & + !$OMP DEFAULT(NONE) & + !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& + !$OMP mo_coef_transp, & + !$OMP mo_coef_transp_is_built, list_ijkl, & + !$OMP mo_coef_is_built, wall_1, & + !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map) + n_integrals = 0 + wall_0 = wall_1 + allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & + bielec_tmp_1(mo_tot_num_align), & + bielec_tmp_0(ao_num,ao_num), & + bielec_tmp_0_idx(ao_num), & + bielec_tmp_2(mo_tot_num_align, n_j), & + buffer_i(size_buffer), & + buffer_value(size_buffer) ) + + thread_num = 0 +!$ thread_num = omp_get_thread_num() + !$OMP DO SCHEDULE(guided) + do l1 = 1,ao_num +!IRP_IF COARRAY +! if (mod(l1-this_image(),num_images()) /= 0 ) then +! cycle +! endif +!IRP_ENDIF + !DEC$ VECTOR ALIGNED + bielec_tmp_3 = 0.d0 + do k1 = 1,ao_num + !DEC$ VECTOR ALIGNED + bielec_tmp_2 = 0.d0 + do j1 = 1,ao_num + call get_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + enddo + do j1 = 1,ao_num + kmax = 0 + do i1 = 1,ao_num + c = bielec_tmp_0(i1,j1) + if (c == 0.d0) then + cycle + endif + kmax += 1 + bielec_tmp_0(kmax,j1) = c + bielec_tmp_0_idx(kmax) = i1 + enddo + + if (kmax==0) then + cycle + endif + + !DEC$ VECTOR ALIGNED + bielec_tmp_1 = 0.d0 + ii1=1 + do ii1 = 1,kmax-4,4 + i1 = bielec_tmp_0_idx(ii1) + i2 = bielec_tmp_0_idx(ii1+1) + i3 = bielec_tmp_0_idx(ii1+2) + i4 = bielec_tmp_0_idx(ii1+3) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + & + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & + mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & + mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & + mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) + enddo ! i + enddo ! ii1 + + i2 = ii1 + do ii1 = i2,kmax + i1 = bielec_tmp_0_idx(ii1) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + enddo ! i + enddo ! ii1 + c = 0.d0 + + do i = list_ijkl(1,1), list_ijkl(n_i,1) + c = max(c,abs(bielec_tmp_1(i))) + if (c>mo_integrals_threshold) exit + enddo + if ( c < mo_integrals_threshold ) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + c = mo_coef_transp(j,j1) + if (abs(c) < thr_coef) then + cycle + endif + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) + enddo ! i + enddo ! j + enddo !j1 + if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then + cycle + endif + + + do k0 = 1, n_k + k = list_ijkl(k0,3) + c = mo_coef_transp(k,k1) + if (abs(c) < thr_coef) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + do i = list_ijkl(1,1), k + bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) + enddo!i + enddo !j + + enddo !k + enddo !k1 + + + + do l0 = 1,n_l + l = list_ijkl(l0,4) + c = mo_coef_transp(l,l1) + if (abs(c) < thr_coef) then + cycle + endif + j1 = ishft((l*l-l),-1) + do j0 = 1, n_j +! print*, 'l :: j0',l + j = list_ijkl(j0,2) +! print*, 'j :: 2',j + if (j > l) then +! print*, 'j>l' +! print*, j,l + exit + endif + j1 += 1 + do k0 = 1, n_k + k = list_ijkl(k0,3) +! print*, 'l :: k0',l +! print*, 'k :: 3',j + i1 = ishft((k*k-k),-1) + if (i1<=j1) then + continue + else +! print*, 'k>l' +! print*, k,l + exit + endif + bielec_tmp_1 = 0.d0 + do i0 = 1, n_i + i = list_ijkl(i0,1) +! print*, 'l :: i0',l +! print*, 'i :: 1',i + if (i>k) then +! print*, 'i>k' +! print*, i,k + exit + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) +! i1+=1 + enddo + +! do i = 1, min(k,j1-i1+list_ijkl(1,1)) +! do i = 1, min(k,j1-i1+list_ijkl(1,1)-1) + do i0 = 1, n_i + i = list_ijkl(i0,1) + if(i> min(k,j1-i1+list_ijkl(1,1)-1))then +! if (i>k) then !min(k,j1-i1) + exit + endif +! print*, i,j,k,l +! print*, k,j1,i1,j1-i1 + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + cycle + endif +! print*, i,j,k,l + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) +! if(i==12.and.k==12 .and.j==12.and.l==12)then +! print*, i,j,k,l,buffer_i(n_integrals) +! accu_bis += buffer_value(n_integrals) +! print*, buffer_value(n_integrals),accu_bis +! endif + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo + enddo + enddo + enddo + + call wall_time(wall_2) + if (thread_num == 0) then + if (wall_2 - wall_0 > 1.d0) then + wall_0 = wall_2 + print*, 100.*float(l1)/float(ao_num), '% in ', & + wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' + endif + endif + enddo + !$OMP END DO NOWAIT + deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) + + integer :: index_needed + + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL +!IRP_IF COARRAY +! print*, 'Communicating the map' +! call communicate_mo_integrals() +!IRP_ENDIF + call map_unique(mo_integrals_map) + + call wall_time(wall_2) + call cpu_time(cpu_2) + integer*8 :: get_mo_map_size, mo_map_size + mo_map_size = get_mo_map_size() + + deallocate(list_ijkl) + + + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' + print*,' Number of MO integrals: ', mo_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + + integer(map_size_kind) :: map_idx + map_idx = ishft(106,map_shift) +! call get_cache_map_verbose(mo_integrals_map,map_idx) + + if (write_mo_integrals) then + call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") + endif + +end + + +subroutine add_integrals_to_map_three_indices(mask_ijk) + use bitmasks + implicit none + + BEGIN_DOC + ! Adds integrals to tha MO map according to some bitmask + END_DOC + + integer(bit_kind), intent(in) :: mask_ijk(N_int,3) + + integer :: i,j,k,l + integer :: i0,j0,k0,l0 + double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 + + integer, allocatable :: list_ijkl(:,:) + integer :: n_i, n_j, n_k, n_l + integer, allocatable :: bielec_tmp_0_idx(:) + real(integral_kind), allocatable :: bielec_tmp_0(:,:) + double precision, allocatable :: bielec_tmp_1(:) + double precision, allocatable :: bielec_tmp_2(:,:) + double precision, allocatable :: bielec_tmp_3(:,:,:) + !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 + + integer :: n_integrals + integer :: size_buffer + integer(key_kind),allocatable :: buffer_i(:) + real(integral_kind),allocatable :: buffer_value(:) + real :: map_mb + + integer :: i1,j1,k1,l1, ii1, kmax, thread_num + integer :: i2,i3,i4 + double precision,parameter :: thr_coef = 1.d-10 + + PROVIDE ao_bielec_integrals_in_map mo_coef + + !Get list of MOs for i,j,k and l + !------------------------------- + + allocate(list_ijkl(mo_tot_num,4)) + call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int ) + call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int ) + call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int ) + character*(2048) :: output(1) + print*, 'i' + call bitstring_to_str( output(1), mask_ijk(1,1), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijk(i,1)) + enddo + if(j==0)then + return + endif + + print*, 'j' + call bitstring_to_str( output(1), mask_ijk(1,2), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijk(i,2)) + enddo + if(j==0)then + return + endif + + print*, 'k' + call bitstring_to_str( output(1), mask_ijk(1,3), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijk(i,3)) + enddo + if(j==0)then + return + endif + + size_buffer = min(ao_num*ao_num*ao_num,16000000) + print*, 'Providing the molecular integrals ' + print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& + ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' + + call wall_time(wall_1) + call cpu_time(cpu_1) + double precision :: accu_bis + accu_bis = 0.d0 + !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & + !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& + !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & + !$OMP wall_0,thread_num,accu_bis) & + !$OMP DEFAULT(NONE) & + !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& + !$OMP mo_coef_transp, & + !$OMP mo_coef_transp_is_built, list_ijkl, & + !$OMP mo_coef_is_built, wall_1, & + !$OMP mo_coef,mo_integrals_threshold,mo_integrals_map) + n_integrals = 0 + wall_0 = wall_1 + allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & + bielec_tmp_1(mo_tot_num_align), & + bielec_tmp_0(ao_num,ao_num), & + bielec_tmp_0_idx(ao_num), & + bielec_tmp_2(mo_tot_num_align, n_j), & + buffer_i(size_buffer), & + buffer_value(size_buffer) ) + + thread_num = 0 +!$ thread_num = omp_get_thread_num() + !$OMP DO SCHEDULE(guided) + do l1 = 1,ao_num +!IRP_IF COARRAY +! if (mod(l1-this_image(),num_images()) /= 0 ) then +! cycle +! endif +!IRP_ENDIF + !DEC$ VECTOR ALIGNED + bielec_tmp_3 = 0.d0 + do k1 = 1,ao_num + !DEC$ VECTOR ALIGNED + bielec_tmp_2 = 0.d0 + do j1 = 1,ao_num + call get_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + enddo + do j1 = 1,ao_num + kmax = 0 + do i1 = 1,ao_num + c = bielec_tmp_0(i1,j1) + if (c == 0.d0) then + cycle + endif + kmax += 1 + bielec_tmp_0(kmax,j1) = c + bielec_tmp_0_idx(kmax) = i1 + enddo + + if (kmax==0) then + cycle + endif + + !DEC$ VECTOR ALIGNED + bielec_tmp_1 = 0.d0 + ii1=1 + do ii1 = 1,kmax-4,4 + i1 = bielec_tmp_0_idx(ii1) + i2 = bielec_tmp_0_idx(ii1+1) + i3 = bielec_tmp_0_idx(ii1+2) + i4 = bielec_tmp_0_idx(ii1+3) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + & + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & + mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & + mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & + mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) + enddo ! i + enddo ! ii1 + + i2 = ii1 + do ii1 = i2,kmax + i1 = bielec_tmp_0_idx(ii1) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + enddo ! i + enddo ! ii1 + c = 0.d0 + + do i = list_ijkl(1,1), list_ijkl(n_i,1) + c = max(c,abs(bielec_tmp_1(i))) + if (c>mo_integrals_threshold) exit + enddo + if ( c < mo_integrals_threshold ) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + c = mo_coef_transp(j,j1) + if (abs(c) < thr_coef) then + cycle + endif + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) + enddo ! i + enddo ! j + enddo !j1 + if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then + cycle + endif + + + do k0 = 1, n_k + k = list_ijkl(k0,3) + c = mo_coef_transp(k,k1) + if (abs(c) < thr_coef) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + do i = list_ijkl(1,1), k + bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) + enddo!i + enddo !j + + enddo !k + enddo !k1 + + + + do l0 = 1,n_j + l = list_ijkl(l0,2) + c = mo_coef_transp(l,l1) + if (abs(c) < thr_coef) then + cycle + endif + j1 = ishft((l*l-l),-1) + j0 = l0 + j = list_ijkl(j0,2) + j1 += 1 + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) +! if (i1<=j1) then +! continue +! else +! exit +! endif + bielec_tmp_1 = 0.d0 + do i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then + exit + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + enddo + +! do i = 1, min(k,j1-i1+list_ijkl(1,1)) +! do i = 1, min(k,j1-i1+list_ijkl(1,1)-1) + do i0 = 1, n_i + i = list_ijkl(i0,1) +! if(i> min(k,j1-i1+list_ijkl(1,1)-1))then + if (i==k) then !min(k,j1-i1) + cycle + endif +! print*, i,j,k,l +! print*, k,j1,i1,j1-i1 + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + cycle + endif +! print*, i,j,k,l + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) +! if(i==12.and.k==12 .and.j==12.and.l==12)then +! print*, i,j,k,l,buffer_i(n_integrals) +! accu_bis += buffer_value(n_integrals) +! print*, buffer_value(n_integrals),accu_bis +! endif + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo + enddo + enddo + + call wall_time(wall_2) + if (thread_num == 0) then + if (wall_2 - wall_0 > 1.d0) then + wall_0 = wall_2 + print*, 100.*float(l1)/float(ao_num), '% in ', & + wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' + endif + endif + enddo + !$OMP END DO NOWAIT + deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) + + integer :: index_needed + + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL +!IRP_IF COARRAY +! print*, 'Communicating the map' +! call communicate_mo_integrals() +!IRP_ENDIF + call map_unique(mo_integrals_map) + + call wall_time(wall_2) + call cpu_time(cpu_2) + integer*8 :: get_mo_map_size, mo_map_size + mo_map_size = get_mo_map_size() + + deallocate(list_ijkl) + + + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' + print*,' Number of MO integrals: ', mo_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + + integer(map_size_kind) :: map_idx + map_idx = ishft(106,map_shift) +! call get_cache_map_verbose(mo_integrals_map,map_idx) + + if (write_mo_integrals) then + call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") + endif + + + +end + + +subroutine add_integrals_to_map_no_exit_34(mask_ijkl) + use bitmasks + implicit none + + BEGIN_DOC + ! Adds integrals to tha MO map according to some bitmask + END_DOC + + integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) + + integer :: i,j,k,l + integer :: i0,j0,k0,l0 + double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 + + integer, allocatable :: list_ijkl(:,:) + integer :: n_i, n_j, n_k, n_l + integer, allocatable :: bielec_tmp_0_idx(:) + real(integral_kind), allocatable :: bielec_tmp_0(:,:) + double precision, allocatable :: bielec_tmp_1(:) + double precision, allocatable :: bielec_tmp_2(:,:) + double precision, allocatable :: bielec_tmp_3(:,:,:) + !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 + + integer :: n_integrals + integer :: size_buffer + integer(key_kind),allocatable :: buffer_i(:) + real(integral_kind),allocatable :: buffer_value(:) + real :: map_mb + + integer :: i1,j1,k1,l1, ii1, kmax, thread_num + integer :: i2,i3,i4 + double precision,parameter :: thr_coef = 1.d-10 + + PROVIDE ao_bielec_integrals_in_map mo_coef + + !Get list of MOs for i,j,k and l + !------------------------------- + allocate(list_ijkl(mo_tot_num,4)) call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) @@ -268,11 +1019,6 @@ subroutine add_integrals_to_map(mask_ijkl) do k0 = 1, n_k k = list_ijkl(k0,3) i1 = ishft((k*k-k),-1) - if (i1<=j1) then - continue - else - exit - endif bielec_tmp_1 = 0.d0 do i0 = 1, n_i i = list_ijkl(i0,1) @@ -282,7 +1028,12 @@ subroutine add_integrals_to_map(mask_ijkl) bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) enddo - do i = 1, min(k,j1-i1) + do i0 = 1, n_i + i = list_ijkl(i0,1) + if(i> k)then + exit + endif + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle endif @@ -345,8 +1096,6 @@ end - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_jj_from_ao, (mo_tot_num_align,mo_tot_num) ] &BEGIN_PROVIDER [ double precision, mo_bielec_integral_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] &BEGIN_PROVIDER [ double precision, mo_bielec_integral_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] @@ -478,6 +1227,155 @@ end mo_bielec_integral_jj_anti_from_ao = mo_bielec_integral_jj_from_ao - mo_bielec_integral_jj_exchange_from_ao +END_PROVIDER + + BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_from_ao, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_vv_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! mo_bielec_integral_vv_from_ao(i,j) = J_ij + ! mo_bielec_integral_vv_exchange_from_ao(i,j) = J_ij + ! mo_bielec_integral_vv_anti_from_ao(i,j) = J_ij - K_ij + ! but only for the virtual orbitals + END_DOC + + integer :: i,j,p,q,r,s + integer :: i0,j0 + double precision :: c + real(integral_kind) :: integral + integer :: n, pp + real(integral_kind), allocatable :: int_value(:) + integer, allocatable :: int_idx(:) + + double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) + + if (.not.do_direct_integrals) then + PROVIDE ao_bielec_integrals_in_map mo_coef + endif + + mo_bielec_integral_vv_from_ao = 0.d0 + mo_bielec_integral_vv_exchange_from_ao = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr + + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE (i0,j0,i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & + !$OMP iqrs, iqsr,iqri,iqis) & + !$OMP SHARED(n_virt_orb,mo_tot_num,list_virt,mo_coef_transp,mo_tot_num_align,ao_num,& + !$OMP ao_integrals_threshold,do_direct_integrals) & + !$OMP REDUCTION(+:mo_bielec_integral_vv_from_ao,mo_bielec_integral_vv_exchange_from_ao) + + allocate( int_value(ao_num), int_idx(ao_num), & + iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),& + iqsr(mo_tot_num_align,ao_num) ) + + !$OMP DO SCHEDULE (guided) + do s=1,ao_num + do q=1,ao_num + + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i = list_virt(i0) + iqrs(i,j) = 0.d0 + iqsr(i,j) = 0.d0 + enddo + enddo + + if (do_direct_integrals) then + double precision :: ao_bielec_integral + do r=1,ao_num + call compute_ao_bielec_integrals(q,r,s,ao_num,int_value) + do p=1,ao_num + integral = int_value(p) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i = list_virt(i0) + iqrs(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + call compute_ao_bielec_integrals(q,s,r,ao_num,int_value) + do p=1,ao_num + integral = int_value(p) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i =list_virt(i0) + iqsr(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + enddo + + else + + do r=1,ao_num + call get_ao_bielec_integrals_non_zero(q,r,s,ao_num,int_value,int_idx,n) + do pp=1,n + p = int_idx(pp) + integral = int_value(pp) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i =list_virt(i0) + iqrs(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + call get_ao_bielec_integrals_non_zero(q,s,r,ao_num,int_value,int_idx,n) + do pp=1,n + p = int_idx(pp) + integral = int_value(pp) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i = list_virt(i0) + iqsr(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + enddo + endif + iqis = 0.d0 + iqri = 0.d0 + do r=1,ao_num + !DIR$ VECTOR ALIGNED + do i0=1,n_virt_orb + i = list_virt(i0) + iqis(i) += mo_coef_transp(i,r) * iqrs(i,r) + iqri(i) += mo_coef_transp(i,r) * iqsr(i,r) + enddo + enddo + do i0=1,n_virt_orb + i= list_virt(i0) + !DIR$ VECTOR ALIGNED + do j0=1,n_virt_orb + j = list_virt(j0) + c = mo_coef_transp(j,q)*mo_coef_transp(j,s) + mo_bielec_integral_vv_from_ao(j,i) += c * iqis(i) + mo_bielec_integral_vv_exchange_from_ao(j,i) += c * iqri(i) + enddo + enddo + + enddo + enddo + !$OMP END DO NOWAIT + deallocate(iqrs,iqsr,int_value,int_idx) + !$OMP END PARALLEL + + mo_bielec_integral_vv_anti_from_ao = mo_bielec_integral_vv_from_ao - mo_bielec_integral_vv_exchange_from_ao +! print*, '**********' +! do i0 =1, n_virt_orb +! i = list_virt(i0) +! print*, mo_bielec_integral_vv_from_ao(i,i) +! enddo +! print*, '**********' + + END_PROVIDER @@ -495,16 +1393,48 @@ END_PROVIDER double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map - mo_bielec_integral_jj = 0.d0 mo_bielec_integral_jj_exchange = 0.d0 - do j=1,mo_tot_num - do i=1,mo_tot_num - mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) - mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) - mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) + + if(.not.no_vvvv_integrals)then + do j=1,mo_tot_num + do i=1,mo_tot_num + mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) + mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) + mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) + enddo + enddo + else + integer :: j0,i0 + do j0=1,n_core_inact_act_orb + j = list_core_inact_act(j0) + do i0=1,n_core_inact_act_orb + i = list_core_inact_act(i0) + mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) + mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) + mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) enddo - enddo + enddo + do j0 = 1, n_virt_orb + j = list_virt(j0) + do i0 = 1, n_virt_orb + i = list_virt(i0) + mo_bielec_integral_jj(i,j) = mo_bielec_integral_vv_from_ao(i,j) + mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) + mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) + enddo + do i0=1,n_core_inact_act_orb + i = list_core_inact_act(i0) + mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) + mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) + mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) + mo_bielec_integral_jj(j,i) = mo_bielec_integral_jj(i,j) + mo_bielec_integral_jj_exchange(j,i) = mo_bielec_integral_jj_exchange(i,j) + mo_bielec_integral_jj_anti(j,i) = mo_bielec_integral_jj_anti(i,j) + enddo + enddo + + endif END_PROVIDER @@ -518,7 +1448,7 @@ BEGIN_PROVIDER [ double precision, mo_bielec_integral_schwartz,(mo_tot_num,mo_to do i=1,mo_tot_num do k=1,mo_tot_num - mo_bielec_integral_schwartz(k,i) = dsqrt(mo_bielec_integral_jj(k,i)) + mo_bielec_integral_schwartz(k,i) = 1.d10 enddo enddo diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 47adc83e..af2af34f 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -484,6 +484,7 @@ subroutine map_get(map, key, value) integer(map_size_kind) :: idx_cache integer(cache_map_size_kind) :: idx + ! index in tha pointers array idx_cache = ishft(key,map_shift) !DIR$ FORCEINLINE call cache_map_get_interval(map%map(idx_cache), key, value, 1, map%map(idx_cache)%n_elements,idx) @@ -853,3 +854,25 @@ subroutine get_cache_map(map,map_idx,keys,values,n_elements) enddo end + +subroutine get_cache_map_verbose(map,map_idx) + use map_module + implicit none + type (map_type), intent(in) :: map + integer(map_size_kind), intent(in) :: map_idx + integer(cache_map_size_kind) :: n_elements + integer(key_kind) :: keys(2**16) + double precision :: values(2**16) + integer(cache_map_size_kind) :: i + integer(key_kind) :: shift + + shift = ishft(map_idx,-map_shift) + + n_elements = map%map(map_idx)%n_elements + do i=1,n_elements + keys(i) = map%map(map_idx)%key(i) + shift + values(i) = map%map(map_idx)%value(i) + print*, ',key,values',keys(i),values(i) + enddo + +end From bd91472407467433d7c44d78638bae1086dfcd37 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 12 Oct 2016 21:29:15 +0200 Subject: [PATCH 28/32] selected integrals is ok --- plugins/FOBOCI/dress_simple.irp.f | 17 -- plugins/FOBOCI/fobo_scf.irp.f | 2 +- src/Integrals_Bielec/EZFIO.cfg | 9 +- src/Integrals_Bielec/mo_bi_integrals.irp.f | 180 +++++++++++---------- 4 files changed, 108 insertions(+), 100 deletions(-) diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index 8a51c4fe..74759362 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -58,24 +58,7 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa) f = 1.d0/(E_ref-haa) -! if(second_order_h)then lambda_i = f -! else -! ! You write the new Hamiltonian matrix -! do k = 1, Ndet_generators -! H_matrix_tmp(k,Ndet_generators+1) = H_array(k) -! H_matrix_tmp(Ndet_generators+1,k) = H_array(k) -! enddo -! H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa -! ! Then diagonalize it -! call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) -! ! Then you extract the effective denominator -! accu = 0.d0 -! do k = 1, Ndet_generators -! accu += eigenvectors(k,1) * H_array(k) -! enddo -! lambda_i = eigenvectors(Ndet_generators+1,1)/accu -! endif do k=1,idx(0) contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i delta_ij_generators_(idx(k), idx(k)) += contrib diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 0b0902b0..8656b633 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,6 +1,6 @@ program foboscf implicit none -!call run_prepare + call run_prepare no_oa_or_av_opt = .True. touch no_oa_or_av_opt call routine_fobo_scf diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 04d58236..01b87fc1 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -7,11 +7,18 @@ ezfio_name: direct [no_vvvv_integrals] type: logical -doc: If True, do not compute the bielectronic integrals when 4 indices are virtual +doc: If True, computes all integrals except for the integrals having 4 virtual index interface: ezfio,provider,ocaml default: False ezfio_name: no_vvvv_integrals +[no_ivvv_integrals] +type: logical +doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual index and 1 belonging to the core inactive active orbitals +interface: ezfio,provider,ocaml +default: False +ezfio_name: no_ivvv_integrals + [disk_access_mo_integrals] type: Disk_access doc: Read/Write MO integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index dae73a01..85fdde10 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -52,8 +52,6 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) enddo call add_integrals_to_map(mask_ijkl) - call set_integrals_exchange_jj_into_map - call set_integrals_jj_into_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 2 (virt) ^2 ! = J_iv @@ -100,18 +98,20 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] mask_ijkl(i,4) = virt_bitmask(i,1) enddo call add_integrals_to_map(mask_ijkl) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 1 (virt) ^3 ! print*, '' print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_no_exit_34(mask_ijkl) + if(.not.no_ivvv_integrals)then + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = virt_bitmask(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map_no_exit_34(mask_ijkl) + endif else call add_integrals_to_map(full_ijkl_bitmask_4) @@ -524,7 +524,8 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 integer, allocatable :: list_ijkl(:,:) - integer :: n_i, n_j, n_k, n_l + integer :: n_i, n_j, n_k + integer :: m integer, allocatable :: bielec_tmp_0_idx(:) real(integral_kind), allocatable :: bielec_tmp_0(:,:) double precision, allocatable :: bielec_tmp_1(:) @@ -594,12 +595,12 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call cpu_time(cpu_1) double precision :: accu_bis accu_bis = 0.d0 - !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & + !$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & !$OMP wall_0,thread_num,accu_bis) & !$OMP DEFAULT(NONE) & - !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& + !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,mo_tot_num_align,& !$OMP mo_coef_transp, & !$OMP mo_coef_transp_is_built, list_ijkl, & !$OMP mo_coef_is_built, wall_1, & @@ -723,56 +724,75 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) if (abs(c) < thr_coef) then cycle endif - j1 = ishft((l*l-l),-1) - j0 = l0 - j = list_ijkl(j0,2) - j1 += 1 do k0 = 1, n_k k = list_ijkl(k0,3) i1 = ishft((k*k-k),-1) -! if (i1<=j1) then -! continue -! else -! exit -! endif bielec_tmp_1 = 0.d0 - do i0 = 1, n_i - i = list_ijkl(i0,1) - if (i>k) then + j0 = l0 + j = list_ijkl(j0,2) + do i0 = 1, n_i + i = list_ijkl(i0,1) +! if(m==2)then +! if(i==j .and. j == k)cycle +! endif + if (i>k) then + exit + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + enddo + + do i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then !min(k,j1-i1) exit - endif - bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - enddo - -! do i = 1, min(k,j1-i1+list_ijkl(1,1)) -! do i = 1, min(k,j1-i1+list_ijkl(1,1)-1) - do i0 = 1, n_i - i = list_ijkl(i0,1) -! if(i> min(k,j1-i1+list_ijkl(1,1)-1))then - if (i==k) then !min(k,j1-i1) - cycle - endif -! print*, i,j,k,l -! print*, k,j1,i1,j1-i1 - if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + endif + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + if(i==k .and. j==l .and. i.ne.j)then + buffer_value(n_integrals) = buffer_value(n_integrals) *0.5d0 + endif + !DEC$ FORCEINLINE + call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo + enddo + enddo + + do l0 = 1,n_j + l = list_ijkl(l0,2) + c = mo_coef_transp(l,l1) + if (abs(c) < thr_coef) then + cycle + endif + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + bielec_tmp_1 = 0.d0 + j0 = k0 + j = list_ijkl(k0,2) + i0 = l0 + i = list_ijkl(i0,2) + if (k==l) then cycle endif -! print*, i,j,k,l + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + n_integrals += 1 buffer_value(n_integrals) = bielec_tmp_1(i) !DEC$ FORCEINLINE call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) -! if(i==12.and.k==12 .and.j==12.and.l==12)then -! print*, i,j,k,l,buffer_i(n_integrals) -! accu_bis += buffer_value(n_integrals) -! print*, buffer_value(n_integrals),accu_bis -! endif if (n_integrals == size_buffer) then call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& real(mo_integrals_threshold,integral_kind)) n_integrals = 0 endif - enddo enddo enddo @@ -823,8 +843,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") endif - - end @@ -1396,7 +1414,7 @@ END_PROVIDER mo_bielec_integral_jj = 0.d0 mo_bielec_integral_jj_exchange = 0.d0 - if(.not.no_vvvv_integrals)then +! if(.not.no_vvvv_integrals)then do j=1,mo_tot_num do i=1,mo_tot_num mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) @@ -1404,37 +1422,37 @@ END_PROVIDER mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) enddo enddo - else - integer :: j0,i0 - do j0=1,n_core_inact_act_orb - j = list_core_inact_act(j0) - do i0=1,n_core_inact_act_orb - i = list_core_inact_act(i0) - mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) - mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) - mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) - enddo - enddo - do j0 = 1, n_virt_orb - j = list_virt(j0) - do i0 = 1, n_virt_orb - i = list_virt(i0) - mo_bielec_integral_jj(i,j) = mo_bielec_integral_vv_from_ao(i,j) - mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) - mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) - enddo - do i0=1,n_core_inact_act_orb - i = list_core_inact_act(i0) - mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) - mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) - mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) - mo_bielec_integral_jj(j,i) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(j,i) = mo_bielec_integral_jj_exchange(i,j) - mo_bielec_integral_jj_anti(j,i) = mo_bielec_integral_jj_anti(i,j) - enddo - enddo - - endif +!else +! integer :: j0,i0 +! do j0=1,n_core_inact_act_orb +! j = list_core_inact_act(j0) +! do i0=1,n_core_inact_act_orb +! i = list_core_inact_act(i0) +! mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) +! mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) +! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) +! enddo +! enddo +! do j0 = 1, n_virt_orb +! j = list_virt(j0) +! do i0 = 1, n_virt_orb +! i = list_virt(i0) +! mo_bielec_integral_jj(i,j) = mo_bielec_integral_vv_from_ao(i,j) +! mo_bielec_integral_jj_exchange(i,j) = mo_bielec_integral_vv_exchange_from_ao(i,j) +! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) +! enddo +! do i0=1,n_core_inact_act_orb +! i = list_core_inact_act(i0) +! mo_bielec_integral_jj(i,j) = get_mo_bielec_integral(i,j,i,j,mo_integrals_map) +! mo_bielec_integral_jj_exchange(i,j) = get_mo_bielec_integral(i,j,j,i,mo_integrals_map) +! mo_bielec_integral_jj_anti(i,j) = mo_bielec_integral_jj(i,j) - mo_bielec_integral_jj_exchange(i,j) +! mo_bielec_integral_jj(j,i) = mo_bielec_integral_jj(i,j) +! mo_bielec_integral_jj_exchange(j,i) = mo_bielec_integral_jj_exchange(i,j) +! mo_bielec_integral_jj_anti(j,i) = mo_bielec_integral_jj_anti(i,j) +! enddo +! enddo +! +!endif END_PROVIDER From 124d918021e3e71c2d3b91edd70f56ce0336a401 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 2 Nov 2016 16:01:01 +0100 Subject: [PATCH 29/32] forgotten files --- plugins/FOBOCI/EZFIO.cfg | 13 +- plugins/FOBOCI/SC2_1h1p.irp.f | 202 +++++++- plugins/FOBOCI/all_singles.irp.f | 25 +- plugins/FOBOCI/create_1h_or_1p.irp.f | 4 + plugins/FOBOCI/dress_simple.irp.f | 160 +++++- plugins/FOBOCI/fobo_scf.irp.f | 14 +- .../foboci_lmct_mlct_threshold_old.irp.f | 459 ++++++++++++++---- plugins/FOBOCI/generators_restart_save.irp.f | 2 + plugins/FOBOCI/hcc_1h1p.irp.f | 16 +- plugins/FOBOCI/routines_foboci.irp.f | 46 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 28 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 71 ++- plugins/Perturbation/EZFIO.cfg | 2 +- plugins/Perturbation/pt2_equations.irp.f | 54 +++ plugins/Properties/hyperfine_constants.irp.f | 5 + plugins/Selectors_no_sorted/selectors.irp.f | 1 + plugins/loc_cele/loc_exchange_int.irp.f | 110 +++++ plugins/loc_cele/loc_exchange_int_act.irp.f | 45 ++ plugins/loc_cele/loc_exchange_int_inact.irp.f | 45 ++ plugins/loc_cele/loc_exchange_int_virt.irp.f | 47 ++ src/Determinants/EZFIO.cfg | 13 + src/Determinants/H_apply.irp.f | 1 - src/Determinants/davidson.irp.f | 9 +- src/Determinants/diagonalize_CI.irp.f | 25 +- src/Determinants/occ_pattern.irp.f | 43 +- src/Determinants/slater_rules.irp.f | 194 +++++++- src/Determinants/utils.irp.f | 42 +- src/Integrals_Bielec/EZFIO.cfg | 23 + src/Integrals_Bielec/ao_bi_integrals.irp.f | 2 + src/Integrals_Bielec/integrals_3_index.irp.f | 22 + src/Integrals_Bielec/map_integrals.irp.f | 67 +++ src/Integrals_Bielec/mo_bi_integrals.irp.f | 65 ++- src/Utils/LinearAlgebra.irp.f | 15 + 33 files changed, 1585 insertions(+), 285 deletions(-) create mode 100644 plugins/loc_cele/loc_exchange_int.irp.f create mode 100644 plugins/loc_cele/loc_exchange_int_act.irp.f create mode 100644 plugins/loc_cele/loc_exchange_int_inact.irp.f create mode 100644 plugins/loc_cele/loc_exchange_int_virt.irp.f create mode 100644 src/Integrals_Bielec/integrals_3_index.irp.f diff --git a/plugins/FOBOCI/EZFIO.cfg b/plugins/FOBOCI/EZFIO.cfg index 88189608..9b9f7d71 100644 --- a/plugins/FOBOCI/EZFIO.cfg +++ b/plugins/FOBOCI/EZFIO.cfg @@ -19,10 +19,15 @@ default: 0.00001 [do_it_perturbative] type: logical -doc: if true, you do the FOBOCI calculation perturbatively +doc: if true, when a given 1h or 1p determinant is not selected because of its perturbation estimate, then if its coefficient is lower than threshold_perturbative, it is acounted in the FOBOCI differential density matrices interface: ezfio,provider,ocaml default: .False. +[threshold_perturbative] +type: double precision +doc: when do_it_perturbative is True, threshold_perturbative select if a given determinant ia selected or not for beign taken into account in the FOBO-SCF treatment. In practive, if the coefficient is larger then threshold_perturbative it means that it not selected as the perturbation should not be too importan. A value of 0.01 is in general OK. +interface: ezfio,provider,ocaml +default: 0.001 [speed_up_convergence_foboscf] type: logical @@ -49,3 +54,9 @@ doc: if true, you do all 2p type excitation on the LMCT interface: ezfio,provider,ocaml default: .True. +[selected_fobo_ci] +type: logical +doc: if true, for each CI step you will run a CIPSI calculation that stops at pt2_max +interface: ezfio,provider,ocaml +default: .False. + diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index d347c6e5..6f6156f4 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -158,6 +158,7 @@ subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,conve ! 1/2 \sum_{ir,js} c_{ir}^{sigma} c_{js}^{sigma} ! diag_H_elements(index_hf) += total_corr_e_2h2p + return c_ref = c_ref * c_ref print*,'diag_H_elements(index_hf) = ',diag_H_elements(index_hf) do i = 1, n_singles @@ -186,6 +187,186 @@ subroutine dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,conve end + +subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) + use bitmasks + implicit none + BEGIN_DOC + ! CISD+SC2 method :: take off all the disconnected terms of a ROHF+1h1p (selected or not) + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(inout) :: u_in(dim_in,N_st) + double precision, intent(out) :: diag_H_elements(dim_in) + double precision, intent(in) :: convergence + + integer :: i,j,k,l + integer :: r,s,i0,j0,r0,s0 + integer :: n_singles + integer :: index_singles(sze),hole_particles_singles(sze,3) + integer :: n_doubles + integer :: index_doubles(sze),hole_particles_doubles(sze,2) + integer :: index_hf + double precision :: e_corr_singles(mo_tot_num,2) + double precision :: e_corr_doubles(mo_tot_num) + double precision :: e_corr_singles_total(2) + double precision :: e_corr_doubles_1h1p + + integer :: exc(0:2,2,2),degree + integer :: h1,h2,p1,p2,s1,s2 + integer :: other_spin(2) + double precision :: phase + integer(bit_kind) :: key_tmp(N_int,2) + integer :: i_ok + double precision :: phase_single_double,phase_double_hf,get_mo_bielec_integral_schwartz + double precision :: hij,c_ref,contrib + integer :: iorb + + other_spin(1) = 2 + other_spin(2) = 1 + + n_singles = 0 + n_doubles = 0 + do i = 1,sze + call get_excitation(ref_bitmask,dets_in(1,1,i),exc,degree,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call i_H_j(dets_in(1,1,i),dets_in(1,1,i),N_int,hij) + diag_H_elements(i) = hij + if(degree == 0)then + index_hf = i + else if (degree == 1)then + n_singles +=1 + index_singles(n_singles) = i + ! h1 = inactive orbital of the hole + hole_particles_singles(n_singles,1) = h1 + ! p1 = virtual orbital of the particle + hole_particles_singles(n_singles,2) = p1 + ! s1 = spin of the electron excited + hole_particles_singles(n_singles,3) = s1 + else if (degree == 2)then + n_doubles +=1 + index_doubles(n_doubles) = i + ! h1 = inactive orbital of the hole (beta of course) + hole_particles_doubles(n_doubles,1) = h1 + ! p1 = virtual orbital of the particle (alpha of course) + hole_particles_doubles(n_doubles,2) = p2 + else + print*,'PB !! found out other thing than a single or double' + print*,'stopping ..' + stop + endif + enddo + double precision :: delta_e + double precision :: coef_ijrs + diag_H_elements = 0.d0 + do i0 = 1, n_core_inact_orb + i= list_core_inact(i0) + do j0 = i0+1, n_core_inact_orb + j = list_core_inact(j0) + print*, i,j + do r0 = 1, n_virt_orb + r = list_virt(r0) + do s0 = r0+1, n_virt_orb + s = list_virt(s0) + !!! alpha (i-->r) / beta (j-->s) + s1 = 1 + s2 = 2 + key_tmp = ref_bitmask + call do_mono_excitation(key_tmp,i,r,s1,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call do_mono_excitation(key_tmp,j,s,s2,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call i_H_j(ref_bitmask, key_tmp, N_int,hij) + delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) + coef_ijrs = hij/delta_e + do k = 1, n_singles + l = index_singles(k) + call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) + diag_H_elements(l) += coef_ijrs * hij + enddo + !if(i>j.and.r>s)then + !! alpha (i-->r) / alpha (j-->s) + s1 = 1 + s2 = 1 + key_tmp = ref_bitmask + call do_mono_excitation(key_tmp,i,r,s1,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call do_mono_excitation(key_tmp,j,s,s2,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call i_H_j(ref_bitmask, key_tmp, N_int,hij) + delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) + coef_ijrs = hij/delta_e + do k = 1, n_singles + l = index_singles(k) + call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) + diag_H_elements(l) += coef_ijrs * hij + enddo + !! beta (i-->r) / beta (j-->s) + s1 = 2 + s2 = 2 + key_tmp = ref_bitmask + call do_mono_excitation(key_tmp,i,r,s1,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call do_mono_excitation(key_tmp,j,s,s2,i_ok) + if(i_ok .ne.1)then + print*, 'pb !!' + stop + endif + call i_H_j(ref_bitmask, key_tmp, N_int,hij) + delta_e = Fock_matrix_diag_mo(i) + Fock_matrix_diag_mo(j) - Fock_matrix_diag_mo(r) - Fock_matrix_diag_mo(s) + coef_ijrs = hij/delta_e + do k = 1, n_singles + l = index_singles(k) + call i_H_j(dets_in(1,1,l), key_tmp, N_int,hij) + diag_H_elements(l) += coef_ijrs * hij + enddo + !endif + enddo + enddo + enddo + enddo + c_ref = 1.d0/u_in(index_hf,1) + do k = 1, n_singles + l = index_singles(k) + diag_H_elements(0) -= diag_H_elements(l) + enddo +! do k = 1, n_doubles +! l = index_doubles(k) +! diag_H_elements(0) += diag_H_elements(l) +! enddo + + +end + + subroutine dressing_1h1p_full(dets_in,u_in,H_matrix,dim_in,sze,N_st,Nint,convergence) use bitmasks implicit none @@ -478,11 +659,13 @@ subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,c double precision, intent(inout) :: u_in(dim_in,N_st) double precision, intent(out) :: energies(N_st) double precision, intent(out) :: diag_H_elements(dim_in) + double precision :: extra_diag_H_elements(dim_in) double precision, intent(in) :: convergence integer :: i,j,iter do iter = 1, 1 - call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) - if(sze<=N_det_max_jacobi)then +! call dressing_1h1p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Nint,convergence) + call dressing_1h1p_by_2h2p(dets_in,u_in,extra_diag_H_elements,dim_in,sze,N_st,Nint,convergence) +! if(sze<=N_det_max_jacobi)then double precision, allocatable :: eigenvectors(:,:), eigenvalues(:),H_matrix_tmp(:,:) allocate (H_matrix_tmp(size(H_matrix_all_dets,1),sze),eigenvalues(sze),eigenvectors(size(H_matrix_all_dets,1),sze)) do j=1,sze @@ -490,9 +673,14 @@ subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,c H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) enddo enddo - do i = 1,sze - H_matrix_tmp(i,i) = diag_H_elements(i) + H_matrix_tmp(1,1) += extra_diag_H_elements(1) + do i = 2,sze + H_matrix_tmp(1,i) += extra_diag_H_elements(i) + H_matrix_tmp(i,1) += extra_diag_H_elements(i) enddo + !do i = 1,sze + ! H_matrix_tmp(i,i) = diag_H_elements(i) + !enddo call lapack_diag(eigenvalues,eigenvectors, & H_matrix_tmp,size(H_matrix_all_dets,1),sze) do j=1,min(N_states_diag,sze) @@ -502,9 +690,9 @@ subroutine SC2_1h1p(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,c energies(j) = eigenvalues(j) enddo deallocate (H_matrix_tmp, eigenvalues, eigenvectors) - else - call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) - endif +! else +! call davidson_diag_hjj(dets_in,u_in,diag_H_elements,energies,dim_in,sze,N_st,Nint,output_determinants) +! endif print*,'E = ',energies(1) + nuclear_repulsion enddo diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 0594e56e..2968ab90 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -1,13 +1,25 @@ -subroutine all_single +subroutine all_single(e_pt2) implicit none + double precision, intent(in) :: e_pt2 integer :: i,k double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) integer :: N_st, degree double precision,allocatable :: E_before(:) N_st = N_states allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) - selection_criterion = 0.d0 - soft_touch selection_criterion + if(.not.selected_fobo_ci)then + selection_criterion = 0.d0 + soft_touch selection_criterion + else + selection_criterion = 0.1d0 + selection_criterion_factor = 0.01d0 + selection_criterion_min = selection_criterion + soft_touch selection_criterion + endif + print*, 'e_pt2 = ',e_pt2 + pt2_max = 0.15d0 * e_pt2 + soft_touch pt2_max + print*, 'pt2_max = ',pt2_max threshold_davidson = 1.d-9 soft_touch threshold_davidson davidson_criterion i = 0 @@ -17,6 +29,8 @@ subroutine all_single print*,'pt2_max = ',pt2_max print*,'N_det_generators = ',N_det_generators pt2=-1.d0 + print*, 'ref_bitmask_energy =',ref_bitmask_energy + print*, 'CI_expectation_value =',CI_expectation_value(1) E_before = ref_bitmask_energy print*,'Initial Step ' @@ -29,7 +43,7 @@ subroutine all_single print*,'S^2 = ',CI_eigenvectors_s2(i) enddo n_det_max = 100000 - do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) + do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > dabs(pt2_max)) i += 1 print*,'-----------------------' print*,'i = ',i @@ -39,6 +53,8 @@ subroutine all_single print*,'E = ',CI_energy(1) print*,'pt2 = ',pt2(1) print*,'E+PT2 = ',E_before + pt2(1) + print*,'pt2_max = ',pt2_max + print*, maxval(abs(pt2(1:N_st))) > dabs(pt2_max) if(N_states_diag.gt.1)then print*,'Variational Energy difference' do i = 2, N_st @@ -53,7 +69,6 @@ subroutine all_single endif E_before = CI_energy !!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO - exit enddo ! threshold_davidson = 1.d-8 ! soft_touch threshold_davidson davidson_criterion diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index 140ed504..41ec7b6c 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -68,7 +68,9 @@ subroutine create_restart_and_1h(i_hole) SOFT_TOUCH N_det psi_det psi_coef logical :: found_duplicates + if(n_act_orb.gt.1)then call remove_duplicates_in_psi_det(found_duplicates) + endif end subroutine create_restart_and_1p(i_particle) @@ -213,6 +215,8 @@ subroutine create_restart_1h_1p(i_hole,i_part) SOFT_TOUCH N_det psi_det psi_coef logical :: found_duplicates + if(n_act_orb.gt.1)then call remove_duplicates_in_psi_det(found_duplicates) + endif end diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index 74759362..e6521c76 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -72,20 +72,21 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen end -subroutine is_a_good_candidate(threshold,is_ok,verbose,exit_loop) +subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) use bitmasks implicit none double precision, intent(in) :: threshold - logical, intent(out) :: is_ok,exit_loop + double precision, intent(out):: e_pt2 + logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative logical, intent(in) :: verbose integer :: l,k,m double precision,allocatable :: dressed_H_matrix(:,:) - double precision,allocatable :: psi_coef_diagonalized_tmp(:,:) + double precision, allocatable :: psi_coef_diagonalized_tmp(:,:) integer(bit_kind), allocatable :: psi_det_generators_input(:,:,:) + double precision :: hij - allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators)) - allocate(psi_coef_diagonalized_tmp(N_det_generators,N_states)) + allocate(psi_det_generators_input(N_int,2,N_det_generators),dressed_H_matrix(N_det_generators,N_det_generators),psi_coef_diagonalized_tmp(N_det_generators,N_states)) dressed_H_matrix = 0.d0 do k = 1, N_det_generators do l = 1, N_int @@ -94,9 +95,20 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose,exit_loop) enddo enddo !call H_apply_dressed_pert(dressed_H_matrix,N_det_generators,psi_det_generators_input) - call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop) - if(do_it_perturbative)then - if(is_ok)then + call dress_H_matrix_from_psi_det_input(psi_det_generators_input,N_det_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative) +!do m = 1, N_states +! do k = 1, N_det_generators +! do l = 1, N_int +! psi_selectors(l,1,k) = psi_det_generators_input(l,1,k) +! psi_selectors(l,2,k) = psi_det_generators_input(l,2,k) +! enddo +! psi_selectors_coef(k,m) = psi_coef_diagonalized_tmp(k,m) +! enddo +!enddo +!soft_touch psi_selectors psi_selectors_coef +!if(do_it_perturbative)then + print*, 'is_ok_perturbative',is_ok_perturbative + if(is_ok.or.is_ok_perturbative)then N_det = N_det_generators do m = 1, N_states do k = 1, N_det_generators @@ -105,11 +117,19 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose,exit_loop) psi_det(l,2,k) = psi_det_generators_input(l,2,k) enddo psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) + print*, 'psi_coef(k,m)',psi_coef(k,m) + enddo + enddo + soft_touch psi_det psi_coef N_det + e_pt2 = 0.d0 + do m =1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators_input(1,1,m),psi_det_generators_input(1,1,l),N_int,hij) ! Fill the zeroth order H matrix + e_pt2 += (dressed_H_matrix(m,l) - hij)* psi_coef_diagonalized_tmp(m,1)* psi_coef_diagonalized_tmp(l,1) enddo enddo - touch psi_coef psi_det N_det endif - endif +!endif deallocate(psi_det_generators_input,dressed_H_matrix,psi_coef_diagonalized_tmp) @@ -118,14 +138,14 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose,exit_loop) end -subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop) +subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_generators,is_ok,psi_coef_diagonalized_tmp, dressed_H_matrix,threshold,verbose,exit_loop,is_ok_perturbative) use bitmasks implicit none integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators) integer, intent(in) :: Ndet_generators double precision, intent(in) :: threshold logical, intent(in) :: verbose - logical, intent(out) :: is_ok,exit_loop + logical, intent(out) :: is_ok,exit_loop,is_ok_perturbative double precision, intent(out) :: psi_coef_diagonalized_tmp(Ndet_generators,N_states) double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) @@ -309,10 +329,124 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener exit endif enddo + if(.not.is_ok)then + is_ok_perturbative = .True. + do i = 1, Ndet_generators + if(is_a_ref_det(i))cycle + do k = 1, N_states + print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative + if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then + is_ok_perturbative = .False. + exit + endif + enddo + if(.not.is_ok_perturbative)then + exit + endif + enddo + endif if(verbose)then - print*,'is_ok = ',is_ok + print*,'is_ok = ',is_ok + print*,'is_ok_perturbative = ',is_ok_perturbative endif end +subroutine fill_H_apply_buffer_no_selection_first_order_coef(n_selected,det_buffer,Nint,iproc) + use bitmasks + implicit none + BEGIN_DOC + ! Fill the H_apply buffer with determiants for CISD + END_DOC + + integer, intent(in) :: n_selected, Nint, iproc + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k + integer :: new_size + PROVIDE H_apply_buffer_allocated + call omp_set_lock(H_apply_buffer_lock(1,iproc)) + new_size = H_apply_buffer(iproc)%N_det + n_selected + if (new_size > H_apply_buffer(iproc)%sze) then + call resize_h_apply_buffer(max(2*H_apply_buffer(iproc)%sze,new_size),iproc) + endif + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + do i=1,n_selected + do j=1,N_int + H_apply_buffer(iproc)%det(j,1,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,1,i) + H_apply_buffer(iproc)%det(j,2,i+H_apply_buffer(iproc)%N_det) = det_buffer(j,2,i) + enddo + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num) + enddo + double precision :: i_H_psi_array(N_states),h,diag_H_mat_elem_fock,delta_e + do i=1,N_selected + call i_H_psi(det_buffer(1,1,i),psi_selectors,psi_selectors_coef,N_int,N_det_selectors,psi_selectors_size,N_states,i_H_psi_array) + call i_H_j(det_buffer(1,1,i),det_buffer(1,1,i),N_int,h) + do j=1,N_states + delta_e = -1.d0 /(h - CI_expectation_value(j)) + H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = i_H_psi_array(j) * delta_e + enddo + enddo + H_apply_buffer(iproc)%N_det = new_size + do i=1,H_apply_buffer(iproc)%N_det + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num) + ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i))) == elec_beta_num) + enddo + call omp_unset_lock(H_apply_buffer_lock(1,iproc)) +end + + + +subroutine make_s2_eigenfunction_first_order + implicit none + integer :: i,j,k + integer :: smax, s + integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) + integer :: N_det_new + integer, parameter :: bufsze = 1000 + logical, external :: is_in_wavefunction + + allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) + smax = 1 + N_det_new = 0 + + do i=1,N_occ_pattern + call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) + s += 1 + if (s > smax) then + deallocate(d) + allocate ( d(N_int,2,s) ) + smax = s + endif + call occ_pattern_to_dets(psi_occ_pattern(1,1,i),d,s,elec_alpha_num,N_int) + do j=1,s + if (.not. is_in_wavefunction(d(1,1,j), N_int) ) then + N_det_new += 1 + do k=1,N_int + det_buffer(k,1,N_det_new) = d(k,1,j) + det_buffer(k,2,N_det_new) = d(k,2,j) + enddo + if (N_det_new == bufsze) then + call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) + N_det_new = 0 + endif + endif + enddo + enddo + + if (N_det_new > 0) then + call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + endif + + deallocate(d,det_buffer) + + call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') + +end + diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8656b633..8a709154 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -1,8 +1,13 @@ program foboscf implicit none - call run_prepare +!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Read" )then +! disk_access_ao_integrals = "Write" +! touch disk_access_ao_integrals +!endif +!print*, 'disk_access_ao_integrals',disk_access_ao_integrals no_oa_or_av_opt = .True. touch no_oa_or_av_opt + call run_prepare call routine_fobo_scf call save_mos @@ -10,8 +15,8 @@ end subroutine run_prepare implicit none - no_oa_or_av_opt = .False. - touch no_oa_or_av_opt +! no_oa_or_av_opt = .False. +! touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -27,6 +32,7 @@ subroutine routine_fobo_scf print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i + print*, 'ao_bielec_integrals_in_map = ',ao_bielec_integrals_in_map print*,'*******************************************************************************' print*,'*******************************************************************************' if(speed_up_convergence_foboscf)then @@ -46,7 +52,7 @@ subroutine routine_fobo_scf soft_touch threshold_lmct threshold_mlct endif endif - call FOBOCI_lmct_mlct_old_thr + call FOBOCI_lmct_mlct_old_thr(i) call save_osoci_natural_mos call damping_SCF call diag_inactive_virt_and_update_mos diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index a072a918..46ca9662 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -1,7 +1,8 @@ -subroutine FOBOCI_lmct_mlct_old_thr +subroutine FOBOCI_lmct_mlct_old_thr(iter) use bitmasks implicit none + integer, intent(in) :: iter integer :: i,j,k,l integer(bit_kind),allocatable :: unpaired_bitmask(:,:) integer, allocatable :: occ(:,:) @@ -10,7 +11,7 @@ subroutine FOBOCI_lmct_mlct_old_thr logical :: test_sym double precision :: thr,hij double precision, allocatable :: dressing_matrix(:,:) - logical :: verbose,is_ok + logical :: verbose,is_ok,is_ok_perturbative verbose = .True. thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) @@ -46,89 +47,45 @@ subroutine FOBOCI_lmct_mlct_old_thr i_hole_osoci = list_inact(i) print*,'--------------------------' ! First set the current generators to the one of restart - call set_generators_to_generators_restart - call set_psi_det_to_generators call check_symetry(i_hole_osoci,thr,test_sym) if(.not.test_sym)cycle + call set_generators_to_generators_restart + call set_psi_det_to_generators print*,'i_hole_osoci = ',i_hole_osoci call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) - call is_a_good_candidate(threshold_lmct,is_ok,verbose,exit_loop) + double precision :: e_pt2 + call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) print*,'is_ok = ',is_ok - if(.not.is_ok)cycle - allocate(dressing_matrix(N_det_generators,N_det_generators)) - dressing_matrix = 0.d0 - if(.not.do_it_perturbative)then - - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl + if(is_ok)then + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo enddo - enddo - hkl = dressing_matrix(1,1) - do k = 1, N_det_generators - dressing_matrix(k,k) = dressing_matrix(k,k) - hkl - enddo - print*,'Naked matrix' - do k = 1, N_det_generators - write(*,'(100(F12.5,X))')dressing_matrix(k,:) - enddo - - ! Do all the single excitations on top of the CAS and 1h determinants - call set_bitmask_particl_as_input(reunion_of_bitmask) - call set_bitmask_hole_as_input(reunion_of_bitmask) - call all_single - call make_s2_eigenfunction - call diagonalize_ci -! if(dressing_2h2p)then -! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct) -! endif - -! ! Change the mask of the holes and particles to perform all the -! ! double excitations that starts from the active space in order -! ! to introduce the Coulomb hole in the active space -! ! These are the 1h2p excitations that have the i_hole_osoci hole in common -! ! and the 2p if there is more than one electron in the active space -! do k = 1, N_int -! zero_bitmask(k,1) = 0_bit_kind -! zero_bitmask(k,2) = 0_bit_kind -! enddo -! ! hole is possible only in the orbital i_hole_osoci -! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int) -! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int) -! ! and in the active space -! do k = 1, n_act_orb -! call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int) -! call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int) -! enddo -! call set_bitmask_hole_as_input(zero_bitmask) - -! call set_bitmask_particl_as_input(reunion_of_bitmask) - -! call all_1h2p -! call diagonalize_CI_SC2 -! call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) - -! ! Change the mask of the holes and particles to perform all the -! ! double excitations that from the orbital i_hole_osoci -! do k = 1, N_int -! zero_bitmask(k,1) = 0_bit_kind -! zero_bitmask(k,2) = 0_bit_kind -! enddo -! ! hole is possible only in the orbital i_hole_osoci -! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int) -! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int) -! call set_bitmask_hole_as_input(zero_bitmask) - -! call set_bitmask_particl_as_input(reunion_of_bitmask) - -! call set_psi_det_to_generators -! call all_2h2p -! call diagonalize_CI_SC2 + hkl = dressing_matrix(1,1) + do k = 1, N_det_generators + dressing_matrix(k,k) = dressing_matrix(k,k) - hkl + enddo + print*,'Naked matrix' + do k = 1, N_det_generators + write(*,'(100(F12.5,X))')dressing_matrix(k,:) + enddo + + ! Do all the single excitations on top of the CAS and 1h determinants + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call all_single(e_pt2) + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + call diagonalize_ci double precision :: hkl call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) hkl = dressing_matrix(1,1) @@ -139,7 +96,10 @@ subroutine FOBOCI_lmct_mlct_old_thr do k = 1, N_det_generators write(*,'(100(F12.5,X))')dressing_matrix(k,:) enddo -! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) + deallocate(dressing_matrix) + else + if(.not.do_it_perturbative)cycle + if(.not. is_ok_perturbative)cycle endif call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) @@ -148,7 +108,6 @@ subroutine FOBOCI_lmct_mlct_old_thr norm_total(k) += norm_tmp(k) enddo call update_density_matrix_osoci - deallocate(dressing_matrix) enddo if(.True.)then @@ -163,9 +122,9 @@ subroutine FOBOCI_lmct_mlct_old_thr print*,'--------------------------' ! First set the current generators to the one of restart call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle call set_generators_to_generators_restart call set_psi_det_to_generators - if(.not.test_sym)cycle print*,'i_particl_osoci= ',i_particl_osoci ! Initialize the bitmask to the restart ones call initialize_bitmask_to_restart_ones @@ -181,32 +140,33 @@ subroutine FOBOCI_lmct_mlct_old_thr call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) !! ! so all the mono excitation on the new generators - call is_a_good_candidate(threshold_mlct,is_ok,verbose,exit_loop) + call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) print*,'is_ok = ',is_ok - if(.not. is_ok)then + if(is_ok)then + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + call all_single(e_pt2) + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + + call diagonalize_ci + deallocate(dressing_matrix) + else if(exit_loop)then + call set_generators_to_generators_restart + call set_psi_det_to_generators exit else - cycle + if(.not.do_it_perturbative)cycle + if(.not. is_ok_perturbative)cycle endif - endif - allocate(dressing_matrix(N_det_generators,N_det_generators)) - if(.not.do_it_perturbative)then - dressing_matrix = 0.d0 - do k = 1, N_det_generators - do l = 1, N_det_generators - call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) - dressing_matrix(k,l) = hkl - enddo - enddo - ! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) - ! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) - call all_single - call make_s2_eigenfunction - call diagonalize_ci -! if(dressing_2h2p)then -! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct) -! endif endif call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) do k = 1, N_states @@ -214,7 +174,6 @@ subroutine FOBOCI_lmct_mlct_old_thr norm_total(k) += norm_tmp(k) enddo call update_density_matrix_osoci - deallocate(dressing_matrix) enddo endif @@ -376,3 +335,303 @@ subroutine FOBOCI_lmct_old enddo print*,'accu = ',accu end + +subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) + use bitmasks + implicit none + integer, intent(in) :: iter + integer :: i,j,k,l + integer(bit_kind),allocatable :: unpaired_bitmask(:,:) + integer, allocatable :: occ(:,:) + integer :: n_occ_alpha, n_occ_beta + double precision :: norm_tmp(N_states),norm_total(N_states) + logical :: test_sym + double precision :: thr,hij + double precision, allocatable :: dressing_matrix(:,:) + logical :: verbose,is_ok,is_ok_perturbative + verbose = .True. + thr = 1.d-12 + allocate(unpaired_bitmask(N_int,2)) + allocate (occ(N_int*bit_kind_size,2)) + do i = 1, N_int + unpaired_bitmask(i,1) = unpaired_alpha_electrons(i) + unpaired_bitmask(i,2) = unpaired_alpha_electrons(i) + enddo + norm_total = 0.d0 + call initialize_density_matrix_osoci + call bitstring_to_list(inact_bitmask(1,1), occ(1,1), n_occ_beta, N_int) + print*,'' + print*,'' + print*,'mulliken spin population analysis' + accu =0.d0 + do i = 1, nucl_num + accu += mulliken_spin_densities(i) + print*,i,nucl_charge(i),mulliken_spin_densities(i) + enddo + print*,'' + print*,'' + print*,'DOING FIRST LMCT !!' + print*,'Threshold_lmct = ',threshold_lmct + integer(bit_kind) , allocatable :: zero_bitmask(:,:) + integer(bit_kind) , allocatable :: psi_singles(:,:,:) + logical :: lmct + double precision, allocatable :: psi_singles_coef(:,:) + logical :: exit_loop + allocate( zero_bitmask(N_int,2) ) + if(iter.ne.1)then + do i = 1, n_inact_orb + lmct = .True. + integer :: i_hole_osoci + i_hole_osoci = list_inact(i) + print*,'--------------------------' + ! First set the current generators to the one of restart + call check_symetry(i_hole_osoci,thr,test_sym) + if(.not.test_sym)cycle + call set_generators_to_generators_restart + call set_psi_det_to_generators + print*,'i_hole_osoci = ',i_hole_osoci + call create_restart_and_1h(i_hole_osoci) + call set_generators_to_psi_det + print*,'Passed set generators' + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + double precision :: e_pt2 + call is_a_good_candidate(threshold_lmct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) + print*,'is_ok = ',is_ok + if(is_ok)then + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + hkl = dressing_matrix(1,1) + do k = 1, N_det_generators + dressing_matrix(k,k) = dressing_matrix(k,k) - hkl + enddo + print*,'Naked matrix' + do k = 1, N_det_generators + write(*,'(100(F12.5,X))')dressing_matrix(k,:) + enddo + + ! Do all the single excitations on top of the CAS and 1h determinants + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) + call all_single(e_pt2) + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + call diagonalize_ci + double precision :: hkl + call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) + hkl = dressing_matrix(1,1) + do k = 1, N_det_generators + dressing_matrix(k,k) = dressing_matrix(k,k) - hkl + enddo + print*,'Dressed matrix' + do k = 1, N_det_generators + write(*,'(100(F12.5,X))')dressing_matrix(k,:) + enddo + deallocate(dressing_matrix) + else + if(.not.do_it_perturbative)cycle + if(.not. is_ok_perturbative)cycle + endif + call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) + + do k = 1, N_states + print*,'norm_tmp = ',norm_tmp(k) + norm_total(k) += norm_tmp(k) + enddo + call update_density_matrix_osoci + enddo + else + double precision :: array_dm(mo_tot_num) + call read_dm_from_lmct(array_dm) + call update_density_matrix_beta_osoci_read(array_dm) + endif + + if(iter.ne.1)then + if(.True.)then + print*,'' + print*,'DOING THEN THE MLCT !!' + print*,'Threshold_mlct = ',threshold_mlct + lmct = .False. + do i = 1, n_virt_orb + integer :: i_particl_osoci + i_particl_osoci = list_virt(i) + + print*,'--------------------------' + ! First set the current generators to the one of restart + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle + call set_generators_to_generators_restart + call set_psi_det_to_generators + print*,'i_particl_osoci= ',i_particl_osoci + ! Initialize the bitmask to the restart ones + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call modify_bitmasks_for_particl(i_particl_osoci) + call print_generators_bitmasks_holes + ! Impose that only the active part can be reached + call set_bitmask_hole_as_input(unpaired_bitmask) +!!! call all_single_h_core + call create_restart_and_1p(i_particl_osoci) +!!! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) +!!! ! so all the mono excitation on the new generators + call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) + print*,'is_ok = ',is_ok + if(is_ok)then + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + call all_single(e_pt2) + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + + call diagonalize_ci + deallocate(dressing_matrix) + else + if(exit_loop)then + call set_generators_to_generators_restart + call set_psi_det_to_generators + exit + else + if(.not.do_it_perturbative)cycle + if(.not. is_ok_perturbative)cycle + endif + endif + call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) + do k = 1, N_states + print*,'norm_tmp = ',norm_tmp(k) + norm_total(k) += norm_tmp(k) + enddo + call update_density_matrix_osoci + enddo + endif + else + integer :: norb + call read_dm_from_mlct(array_dm,norb) + call update_density_matrix_alpha_osoci_read(array_dm) + do i = norb+1, n_virt_orb + i_particl_osoci = list_virt(i) + + print*,'--------------------------' + ! First set the current generators to the one of restart + call check_symetry(i_particl_osoci,thr,test_sym) + if(.not.test_sym)cycle + call set_generators_to_generators_restart + call set_psi_det_to_generators + print*,'i_particl_osoci= ',i_particl_osoci + ! Initialize the bitmask to the restart ones + call initialize_bitmask_to_restart_ones + ! Impose that only the hole i_hole_osoci can be done + call modify_bitmasks_for_particl(i_particl_osoci) + call print_generators_bitmasks_holes + ! Impose that only the active part can be reached + call set_bitmask_hole_as_input(unpaired_bitmask) +!!! call all_single_h_core + call create_restart_and_1p(i_particl_osoci) +!!! ! Update the generators + call set_generators_to_psi_det + call set_bitmask_particl_as_input(reunion_of_bitmask) + call set_bitmask_hole_as_input(reunion_of_bitmask) +!!! ! so all the mono excitation on the new generators + call is_a_good_candidate(threshold_mlct,is_ok,e_pt2,verbose,exit_loop,is_ok_perturbative) + print*,'is_ok = ',is_ok + if(is_ok)then + allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 + do k = 1, N_det_generators + do l = 1, N_det_generators + call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) + dressing_matrix(k,l) = hkl + enddo + enddo + call all_single(e_pt2) + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + + call diagonalize_ci + deallocate(dressing_matrix) + else + if(exit_loop)then + call set_generators_to_generators_restart + call set_psi_det_to_generators + exit + else + if(.not.do_it_perturbative)cycle + if(.not. is_ok_perturbative)cycle + endif + endif + call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) + do k = 1, N_states + print*,'norm_tmp = ',norm_tmp(k) + norm_total(k) += norm_tmp(k) + enddo + call update_density_matrix_osoci + enddo + endif + + print*,'norm_total = ',norm_total + norm_total = norm_generators_restart + norm_total = 1.d0/norm_total +! call rescale_density_matrix_osoci(norm_total) + double precision :: accu + accu = 0.d0 + do i = 1, mo_tot_num + accu += one_body_dm_mo_alpha_osoci(i,i) + one_body_dm_mo_beta_osoci(i,i) + enddo + print*,'accu = ',accu +end + +subroutine read_dm_from_lmct(array) + implicit none + integer :: i,iunit ,getUnitAndOpen + double precision :: stuff + double precision, intent(out) :: array(mo_tot_num) + character*(128) :: input + input=trim("fort.33") + iunit= getUnitAndOpen(input,'r') + print*, iunit + array = 0.d0 + do i = 1, n_inact_orb + read(iunit,*) stuff + print*, list_inact(i),stuff + array(list_inact(i)) = stuff + enddo +end + +subroutine read_dm_from_mlct(array,norb) + implicit none + integer :: i,iunit ,getUnitAndOpen + double precision :: stuff + double precision, intent(out) :: array(mo_tot_num) + character*(128) :: input + input=trim("fort.35") + iunit= getUnitAndOpen(input,'r') + integer,intent(out) :: norb + read(iunit,*)norb + print*, iunit + input=trim("fort.34") + iunit= getUnitAndOpen(input,'r') + array = 0.d0 + print*, 'norb = ',norb + do i = 1, norb + read(iunit,*) stuff + print*, list_virt(i),stuff + array(list_virt(i)) = stuff + enddo +end diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index 09d4aa2b..eba9f0ad 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -9,6 +9,7 @@ BEGIN_PROVIDER [ integer, N_det_generators_restart ] integer :: i integer, save :: ifirst = 0 double precision :: norm + print*, ' Providing N_det_generators_restart' if(ifirst == 0)then call ezfio_get_determinants_n_det(N_det_generators_restart) ifirst = 1 @@ -30,6 +31,7 @@ END_PROVIDER integer :: i, k integer, save :: ifirst = 0 double precision, allocatable :: psi_coef_read(:,:) + print*, ' Providing psi_det_generators_restart' if(ifirst == 0)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) do k = 1, N_int diff --git a/plugins/FOBOCI/hcc_1h1p.irp.f b/plugins/FOBOCI/hcc_1h1p.irp.f index 66cf2fd4..ffad686f 100644 --- a/plugins/FOBOCI/hcc_1h1p.irp.f +++ b/plugins/FOBOCI/hcc_1h1p.irp.f @@ -15,12 +15,12 @@ subroutine routine call diagonalize_CI call test_hcc call test_mulliken -! call SC2_1h1p(psi_det,psi_coef,energies, & -! diag_H_elements,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) - allocate(H_matrix(N_det,N_det)) - call SC2_1h1p_full(psi_det,psi_coef,energies, & - H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) - deallocate(H_matrix) + call SC2_1h1p(psi_det,psi_coef,energies, & + diag_H_elements,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) +! allocate(H_matrix(N_det,N_det)) +! call SC2_1h1p_full(psi_det,psi_coef,energies, & +! H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) +! deallocate(H_matrix) integer :: i,j double precision :: accu,coef_hf ! coef_hf = 1.d0/psi_coef(1,1) @@ -34,12 +34,12 @@ end subroutine pouet implicit none double precision :: accu,coef_hf -! provide one_body_dm_mo_alpha one_body_dm_mo_beta + provide one_body_dm_mo_alpha one_body_dm_mo_beta ! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int) ! touch one_body_dm_mo_alpha one_body_dm_mo_beta call test_hcc call test_mulliken -! call save_wavefunction + call save_wavefunction end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 3ecd7977..b3dfca52 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -218,6 +218,44 @@ subroutine update_density_matrix_osoci enddo +end + +subroutine update_density_matrix_beta_osoci_read(array) + implicit none + BEGIN_DOC + ! one_body_dm_mo_alpha_osoci += Delta rho alpha + ! one_body_dm_mo_beta_osoci += Delta rho beta + END_DOC + integer :: i,j + integer :: iorb,jorb + double precision :: array(mo_tot_num) + do i = 1, mo_tot_num + j = list_act(1) + one_body_dm_mo_beta_osoci(i,j) += array(i) + one_body_dm_mo_beta_osoci(j,i) += array(i) + one_body_dm_mo_beta_osoci(i,i) += array(i) * array(i) + enddo + + +end + +subroutine update_density_matrix_alpha_osoci_read(array) + implicit none + BEGIN_DOC + ! one_body_dm_mo_alpha_osoci += Delta rho alpha + ! one_body_dm_mo_beta_osoci += Delta rho beta + END_DOC + integer :: i,j + integer :: iorb,jorb + double precision :: array(mo_tot_num) + do i = 1, mo_tot_num + j = list_act(1) + one_body_dm_mo_alpha_osoci(i,j) += array(i) + one_body_dm_mo_alpha_osoci(j,i) += array(i) + one_body_dm_mo_alpha_osoci(i,i) += array(i) * array(i) + enddo + + end @@ -387,14 +425,14 @@ subroutine save_osoci_natural_mos print*,'ACTIVE ORBITAL ',iorb do j = 1, n_inact_orb jorb = list_inact(j) - if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then + if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then print*,'INACTIVE ' print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo do j = 1, n_virt_orb jorb = list_virt(j) - if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then + if(dabs(tmp(iorb,jorb)).gt.0.0001d0)then print*,'VIRT ' print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif @@ -412,6 +450,10 @@ subroutine save_osoci_natural_mos label = "Natural" call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) +!if(disk_access_ao_integrals == "None" .or. disk_access_ao_integrals == "Write" )then +! disk_access_ao_integrals = "Read" +! touch disk_access_ao_integrals +!endif !soft_touch mo_coef deallocate(tmp,occ) diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index c1da3670..80739aa2 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -73,21 +73,21 @@ print*, '1h1p = ',accu ! 1h1p third order - delta_ij_tmp = 0.d0 - call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) -!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) -!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + if(do_third_order_1h1p)then + delta_ij_tmp = 0.d0 + call give_1h1p_sec_order_singles_contrib(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p(3)',accu + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p(3)',accu + endif ! 2h delta_ij_tmp = 0.d0 diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index b4c7e6f4..f08af1d5 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -287,50 +287,46 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) integer :: ispin,jspin,kspin if (n_holes_act == 0 .and. n_particles_act == 1) then -! i_particle_act = particles_active_list_spin_traced(1) -! delta_e_act += one_creat_spin_trace(i_particle_act ) ispin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) - call get_excitation_degree(det_1,det_2,degree,N_int) - if(degree == 1)then - call get_excitation(det_1,det_2,exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - i_hole = list_inact_reverse(h1) - i_part = list_act_reverse(p1) - do i_state = 1, N_states - delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) - enddo - else if (degree == 2)then +! call get_excitation_degree(det_1,det_2,degree,N_int) +! if(degree == 1)then +! call get_excitation(det_1,det_2,exc,degree,phase,N_int) +! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) +! i_hole = list_inact_reverse(h1) +! i_part = list_act_reverse(p1) +! do i_state = 1, N_states +! delta_e_act(i_state) += one_anhil_inact(i_hole,i_part,i_state) +! enddo +! else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_creat(i_particle_act,ispin,i_state) enddo - endif +! endif else if (n_holes_act == 1 .and. n_particles_act == 0) then -! i_hole_act = holes_active_list_spin_traced(1) -! delta_e_act += one_anhil_spin_trace(i_hole_act ) ispin = hole_list_practical(1,1) i_hole_act = hole_list_practical(2,1) - call get_excitation_degree(det_1,det_2,degree,N_int) - if(degree == 1)then - call get_excitation(det_1,det_2,exc,degree,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - i_hole = list_act_reverse(h1) - i_part = list_virt_reverse(p1) - do i_state = 1, N_states - if(isnan(one_creat_virt(i_hole,i_part,i_state)))then - print*, i_hole,i_part,i_state - call debug_det(det_1,N_int) - call debug_det(det_2,N_int) - stop - endif - delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) - enddo - else if (degree == 2)then +! call get_excitation_degree(det_1,det_2,degree,N_int) +! if(degree == 1)then +! call get_excitation(det_1,det_2,exc,degree,phase,N_int) +! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) +! i_hole = list_act_reverse(h1) +! i_part = list_virt_reverse(p1) +! do i_state = 1, N_states +! if(isnan(one_creat_virt(i_hole,i_part,i_state)))then +! print*, i_hole,i_part,i_state +! call debug_det(det_1,N_int) +! call debug_det(det_2,N_int) +! stop +! endif +! delta_e_act(i_state) += one_creat_virt(i_hole,i_part,i_state) +! enddo +! else if (degree == 2)then do i_state = 1, N_states delta_e_act(i_state) += one_anhil(i_hole_act , ispin,i_state) enddo - endif +! endif else if (n_holes_act == 1 .and. n_particles_act == 1) then ! i_hole_act = holes_active_list_spin_traced(1) @@ -460,21 +456,12 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) double precision :: phase call get_excitation_degree(det_1,det_2,degree,N_int) if(degree == 1)then -! call debug_det(det_1,N_int) call get_excitation(det_1,det_2,exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) i_hole = list_inact_reverse(h1) i_part = list_virt_reverse(p1) do i_state = 1, N_states -! if(one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1).gt.1.d-10)then -! print*, hij, one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) -! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) & -! * coef_array(i_state)* hij*coef_array(i_state)* hij *one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) -! print*, coef_array(i_state)* hij*coef_array(i_state)* hij,one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1), & -! coef_array(i_state)* hij*coef_array(i_state)* hij *one_anhil_one_creat_inact_virt_norm(i_hole,i_part,i_state,s1) -! else - delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) -! endif +! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index ad26cfe5..c5d6379f 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -16,4 +16,4 @@ type: Normalized_float doc: The selection process stops when the energy ratio variational/(variational+PT2) is equal to var_pt2_ratio interface: ezfio,provider,ocaml -default: 0.75 \ No newline at end of file +default: 0.75 diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index c284e01e..29aed8d3 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -142,6 +142,60 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) end + + +subroutine pt2_epstein_nesbet_2x2_no_ci_diag($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + ! compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution + ! + ! for the various N_st states. + ! + ! e_2_pert(i) = 0.5 * (( - E(i) ) - sqrt( ( - E(i)) ^2 + 4 ^2 ) + ! + ! c_pert(i) = e_2_pert(i)/ + ! + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock,delta_e, h + double precision :: i_H_psi_array(N_st) + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + PROVIDE CI_electronic_energy + + call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + !call i_H_psi_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array) + + h = diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint) + do i =1,N_st + if (i_H_psi_array(i) /= 0.d0) then + delta_e = h - CI_expectation_value(i) + if (delta_e > 0.d0) then + e_2_pert(i) = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) + else + e_2_pert(i) = 0.5d0 * (delta_e + dsqrt(delta_e * delta_e + 4.d0 * i_H_psi_array(i) * i_H_psi_array(i))) + endif + if (dabs(i_H_psi_array(i)) > 1.d-6) then + c_pert(i) = e_2_pert(i)/i_H_psi_array(i) + else + c_pert(i) = 0.d0 + endif + H_pert_diag(i) = h*c_pert(i)*c_pert(i) + else + e_2_pert(i) = 0.d0 + c_pert(i) = 0.d0 + H_pert_diag(i) = 0.d0 + endif + enddo + +end + + + subroutine pt2_moller_plesset ($arguments) use bitmasks implicit none diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index de14da9f..63ad545b 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -121,6 +121,11 @@ END_PROVIDER conversion_factor_mhz_hcc(8) = -606.1958551736545d0 conversion_factor_gauss_hcc(8) = -216.30574771560407d0 conversion_factor_cm_1_hcc(8) = -202.20517197179822d0 + + ! Phosphore + conversion_factor_mhz_hcc(15) = 1811.0967763744873d0 + conversion_factor_gauss_hcc(15) = 646.2445276897648d0 + conversion_factor_cm_1_hcc(15) = 604.1170297381395d0 END_PROVIDER diff --git a/plugins/Selectors_no_sorted/selectors.irp.f b/plugins/Selectors_no_sorted/selectors.irp.f index 9273c7bb..83a8d472 100644 --- a/plugins/Selectors_no_sorted/selectors.irp.f +++ b/plugins/Selectors_no_sorted/selectors.irp.f @@ -40,6 +40,7 @@ END_PROVIDER do k=1,N_states do i=1,N_det_selectors psi_selectors_coef(i,k) = psi_coef(i,k) +! print*, 'psi_selectors_coef(i,k) == ',psi_selectors_coef(i,k) enddo enddo END_PROVIDER diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f new file mode 100644 index 00000000..d7cc5c65 --- /dev/null +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -0,0 +1,110 @@ +program loc_int + implicit none + integer :: i,j,k,l,iorb,jorb + double precision :: exchange_int(mo_tot_num) + integer :: iorder(mo_tot_num) + integer :: indices(mo_tot_num,2) + logical :: list_core_inact_check(mo_tot_num) + integer :: n_rot + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_act_orb + iorb = list_act(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_act_orb + jorb = list_act(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_virt_orb + iorb = list_virt(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_virt_orb + jorb = list_virt(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + + + call save_mos + + +end diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f new file mode 100644 index 00000000..b9bbeb82 --- /dev/null +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -0,0 +1,45 @@ +program loc_int + implicit none + integer :: i,j,k,l,iorb,jorb + double precision :: exchange_int(mo_tot_num) + integer :: iorder(mo_tot_num) + integer :: indices(mo_tot_num,2) + logical :: list_core_inact_check(mo_tot_num) + integer :: n_rot + + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_act_orb + iorb = list_act(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_act_orb + jorb = list_act(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + call save_mos + + +end diff --git a/plugins/loc_cele/loc_exchange_int_inact.irp.f b/plugins/loc_cele/loc_exchange_int_inact.irp.f new file mode 100644 index 00000000..2ff3c85f --- /dev/null +++ b/plugins/loc_cele/loc_exchange_int_inact.irp.f @@ -0,0 +1,45 @@ +program loc_int + implicit none + integer :: i,j,k,l,iorb,jorb + double precision :: exchange_int(mo_tot_num) + integer :: iorder(mo_tot_num) + integer :: indices(mo_tot_num,2) + logical :: list_core_inact_check(mo_tot_num) + integer :: n_rot + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + + call save_mos + + +end diff --git a/plugins/loc_cele/loc_exchange_int_virt.irp.f b/plugins/loc_cele/loc_exchange_int_virt.irp.f new file mode 100644 index 00000000..333f189b --- /dev/null +++ b/plugins/loc_cele/loc_exchange_int_virt.irp.f @@ -0,0 +1,47 @@ +program loc_int + implicit none + integer :: i,j,k,l,iorb,jorb + double precision :: exchange_int(mo_tot_num) + integer :: iorder(mo_tot_num) + integer :: indices(mo_tot_num,2) + logical :: list_core_inact_check(mo_tot_num) + integer :: n_rot + + indices = 0 + list_core_inact_check = .True. + n_rot = 0 + do i = 1, n_virt_orb + iorb = list_virt(i) + exchange_int = 0.d0 + iorder = 0 + print*,'' + if(list_core_inact_check(iorb) == .False.)cycle + do j = i+1, n_virt_orb + jorb = list_virt(j) + iorder(jorb) = jorb + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + enddo + n_rot += 1 + call dsort(exchange_int,iorder,mo_tot_num) + indices(n_rot,1) = iorb + indices(n_rot,2) = iorder(1) + list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' + enddo + print*,'****************************' + print*,'-+++++++++++++++++++++++++' + do i = 1, n_rot + iorb = indices(i,1) + jorb = indices(i,2) + print*,iorb,jorb + call mix_mo_jk(iorb,jorb) + enddo + + + + call save_mos + + +end diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index b1c459ba..324005aa 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -124,3 +124,16 @@ interface: ezfio,provider,ocaml doc: Energy that should be obtained when truncating the wave function (optional) type: Energy default: 0. + +[store_full_H_mat] +type: logical +doc: If True, the Davidson diagonalization is performed by storring the full H matrix up to n_det_max_stored. Be carefull, it can cost a lot of memory but can also save a lot of CPU time +interface: ezfio,provider,ocaml +default: False + +[n_det_max_stored] +type: Det_number_max +doc: Maximum number of determinants for which the full H matrix is stored. Be carefull, the memory requested scales as 10*n_det_max_stored**2. For instance, 90000 determinants represent a matrix of size 60 Gb. +interface: ezfio,provider,ocaml +default: 90000 + diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 28513597..d5b972e4 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -306,7 +306,6 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) call omp_unset_lock(H_apply_buffer_lock(1,iproc)) end - subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) use f77_zmq implicit none diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f index deba43c5..130bd56d 100644 --- a/src/Determinants/davidson.irp.f +++ b/src/Determinants/davidson.irp.f @@ -334,6 +334,9 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun double precision :: to_print(2,N_st) double precision :: cpu, wall + if(store_full_H_mat.and.sze.le.n_det_max_stored)then + provide H_matrix_all_dets + endif call write_time(iunit) @@ -439,7 +442,11 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun ! ---------------------- do k=1,N_st - call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) + if(store_full_H_mat.and.sze.le.n_det_max_stored)then + call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze) + else + call H_u_0(W(1,k,iter),U(1,k,iter),H_jj,sze,dets_in,Nint) + endif enddo diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f index 11ec6db5..49714082 100644 --- a/src/Determinants/diagonalize_CI.irp.f +++ b/src/Determinants/diagonalize_CI.irp.f @@ -33,6 +33,14 @@ BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] END_PROVIDER + BEGIN_PROVIDER [ double precision, CI_expectation_value, (N_states_diag) ] + implicit none + integer :: i + do i = 1, N_states + call u0_H_u_0(CI_expectation_value(i),psi_coef(1,i),n_det,psi_det,N_int) + enddo + END_PROVIDER + BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] @@ -69,10 +77,14 @@ END_PROVIDER if (diag_algorithm == "Davidson") then + print*, '------------- In Davidson ' call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) + print*, '------------- Out Davidson ' do j=1,N_states_diag + print*, '------------- In S^2' call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),CI_eigenvectors_s2(j)) + print*, '------------- Out S^2' enddo @@ -233,16 +245,20 @@ END_PROVIDER else - ! Sorting the N_states_diag by energy, whatever the S^2 value is + !! Sorting the N_states_diag by energy, whatever the S^2 value is allocate(e_array(n_states_diag),iorder(n_states_diag)) - do j = 1, N_states_diag - call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) + do j = 2, N_states_diag + if(store_full_H_mat.and.n_det.le.n_det_max_stored)then + call u_0_H_u_0_stored(e_0,CI_eigenvectors(1,j),H_matrix_all_dets,n_det) + else + call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) + endif e_array(j) = e_0 iorder(j) = j enddo call dsort(e_array,iorder,n_states_diag) - do j = 1, N_states_diag + do j = 2, N_states_diag CI_electronic_energy(j) = e_array(j) do i = 1, N_det CI_eigenvectors(i,j) = psi_coef(i,iorder(j)) @@ -253,6 +269,7 @@ END_PROVIDER endif deallocate(s2_eigvalues) endif + print*, 'out provider' END_PROVIDER diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index e2e12974..c58d1f82 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -256,27 +256,6 @@ subroutine make_s2_eigenfunction integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction -! return - -! !TODO DEBUG -! do i=1,N_det -! do j=i+1,N_det -! s = 0 -! do k=1,N_int -! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & -! (psi_det(k,2,j) /= psi_det(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error0: det ', j, 'already in wf' -! call debug_det(psi_det(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 @@ -308,33 +287,15 @@ subroutine make_s2_eigenfunction if (N_det_new > 0) then call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) +! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det endif deallocate(d,det_buffer) - -! !TODO DEBUG -! do i=1,N_det -! do j=i+1,N_det -! s = 0 -! do k=1,N_int -! if((psi_det(k,1,j) /= psi_det(k,1,i)).or. & -! (psi_det(k,2,j) /= psi_det(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error : det ', j, 'already in wf at ', i -! call debug_det(psi_det(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG call write_int(output_determinants,N_det_new, 'Added deteminants for S^2') end + diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 7f0e7e57..5cbed15e 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -431,7 +431,7 @@ end -subroutine i_H_j(key_i,key_j,Nint,hij) +subroutine i_H_j_new(key_i,key_j,Nint,hij) use bitmasks implicit none BEGIN_DOC @@ -463,6 +463,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) hij = 0.d0 !DIR$ FORCEINLINE call get_excitation_degree(key_i,key_j,degree,Nint) + integer :: spin select case (degree) case (2) call get_double_excitation(key_i,key_j,exc,phase,Nint) @@ -507,6 +508,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! Mono alpha m = exc(1,1,1) p = exc(1,2,1) + spin = 1 do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then @@ -534,6 +536,8 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! Mono beta m = exc(1,1,2) p = exc(1,2,2) + spin = 2 + do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then @@ -559,6 +563,154 @@ subroutine i_H_j(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p)) + + + case (0) + hij = diag_H_mat_elem(key_i,Nint) + end select +end + + +subroutine i_H_j(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_schwartz + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem, phase,phase_2 + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + integer :: spin + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,2,2) )then + hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) + else if (exc(1,2,1) ==exc(1,1,2))then + hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) + else + hij = phase*get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + get_mo_bielec_integral_schwartz( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral_schwartz( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + spin = 1 +! do k = 1, elec_alpha_num +! i = occ(k,1) +! if (.not.has_mipi(i)) then +! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) +! has_mipi(i) = .True. +! endif +! enddo +! do k = 1, elec_beta_num +! i = occ(k,2) +! if (.not.has_mipi(i)) then +! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! has_mipi(i) = .True. +! endif +! enddo +! +! do k = 1, elec_alpha_num +! hij = hij + mipi(occ(k,1)) - miip(occ(k,1)) +! enddo +! do k = 1, elec_beta_num +! hij = hij + mipi(occ(k,2)) +! enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + spin = 2 + +! do k = 1, elec_beta_num +! i = occ(k,2) +! if (.not.has_mipi(i)) then +! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) +! has_mipi(i) = .True. +! endif +! enddo +! do k = 1, elec_alpha_num +! i = occ(k,1) +! if (.not.has_mipi(i)) then +! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! has_mipi(i) = .True. +! endif +! enddo +! +! do k = 1, elec_alpha_num +! hij = hij + mipi(occ(k,1)) +! enddo +! do k = 1, elec_beta_num +! hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) +! enddo + + endif +! hij = phase*(hij + mo_mono_elec_integral(m,p)) + + call get_mono_excitation_from_fock(key_i,key_j,p,m,spin,phase,hij) case (0) hij = diag_H_mat_elem(key_i,Nint) @@ -2182,3 +2334,43 @@ subroutine H_u_0(v_0,u_0,H_jj,n,keys_tmp,Nint) deallocate (shortcut, sort_idx, sorted, version) end +subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! uses the big_matrix_stored array + END_DOC + integer, intent(in) :: sze + double precision, intent(in) :: hmatrix(sze,sze) + double precision, intent(out) :: v_0(sze) + double precision, intent(in) :: u_0(sze) + v_0 = 0.d0 + call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) + +end + +subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = + ! + ! n : number of determinants + ! + ! uses the big_matrix_stored array + END_DOC + integer, intent(in) :: sze + double precision, intent(in) :: hmatrix(sze,sze) + double precision, intent(out) :: e_0 + double precision, intent(in) :: u_0(sze) + double precision :: v_0(sze) + double precision :: u_dot_v + e_0 = 0.d0 + v_0 = 0.d0 + call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) + e_0 = u_dot_v(v_0,u_0,sze) +end diff --git a/src/Determinants/utils.irp.f b/src/Determinants/utils.irp.f index 22faee83..cc191970 100644 --- a/src/Determinants/utils.irp.f +++ b/src/Determinants/utils.irp.f @@ -1,15 +1,21 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] + use bitmasks implicit none BEGIN_DOC ! H matrix on the basis of the slater determinants defined by psi_det END_DOC - integer :: i,j + integer :: i,j,k double precision :: hij + integer :: degree(N_det),idx(0:N_det) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij,degree,idx,k) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) do i =1,N_det - do j =i,N_det +! call get_excitation_degree_vector(psi_det,psi_det(1,1,i),degree,N_int,N_det,idx) +! do k =1, idx(0) +! j = idx(k) +! if(j.lt.i)cycle + do j = i, N_det call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) H_matrix_all_dets(i,j) = hij H_matrix_all_dets(j,i) = hij @@ -18,3 +24,33 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] !$OMP END PARALLEL DO END_PROVIDER + +subroutine provide_big_matrix_stored_with_current_dets(sze,dets_in,big_matrix_stored) + use bitmasks + integer, intent(in) :: sze + integer(bit_kind), intent(in) :: dets_in(N_int,2,sze) + double precision, intent(out) :: big_matrix_stored(sze,sze) + integer :: i,j,k + double precision :: hij + integer :: degree(N_det),idx(0:N_det) + call i_H_j(dets_in(1,1,1),dets_in(1,1,1),N_int,hij) + print*, 'providing big_matrix_stored' + print*, n_det_max_stored + !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij,degree,idx,k) & + !$OMP SHARED (sze, dets_in, N_int,big_matrix_stored) + do i =1,sze +! call get_excitation_degree_vector(dets_in,dets_in(1,1,i),degree,N_int,sze,idx) +! do k =1, idx(0) +! j = idx(k) + do j = i, sze + if(j.lt.i)cycle + call i_H_j(dets_in(1,1,i),dets_in(1,1,j),N_int,hij) + big_matrix_stored(i,j) = hij + big_matrix_stored(j,i) = hij + enddo + enddo + !$OMP END PARALLEL DO + print*, 'big_matrix_stored provided !!' + + +end diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 01b87fc1..0d5c5832 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -12,6 +12,22 @@ interface: ezfio,provider,ocaml default: False ezfio_name: no_vvvv_integrals + +[write_ao_map_after_transfo] +type: logical +doc: If True, you dump all the ao integrals after having transformed the mo integrals +interface: ezfio,provider,ocaml +default: False +ezfio_name: write_ao_map_after_transfo + +[clear_ao_map_after_mo_transfo] +type: logical +doc: If True, you clear all the ao integrals after having done the transformation +interface: ezfio,provider,ocaml +default: False +ezfio_name: clear_ao_map_after_mo_transfo + + [no_ivvv_integrals] type: logical doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual index and 1 belonging to the core inactive active orbitals @@ -19,6 +35,13 @@ interface: ezfio,provider,ocaml default: False ezfio_name: no_ivvv_integrals +[no_vvv_integrals] +type: logical +doc: Can be switched on only if no_vvvv_integrals is True, then do not computes the integrals having 3 virtual orbitals +interface: ezfio,provider,ocaml +default: False +ezfio_name: no_vvv_integrals + [disk_access_mo_integrals] type: Disk_access doc: Read/Write MO integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index eb443701..54bcc1c4 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -349,6 +349,8 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integral = ao_bielec_integral(1,1,1,1) real :: map_mb + print*, 'read_ao_integrals',read_ao_integrals + print*, 'disk_access_ao_integrals',disk_access_ao_integrals if (read_ao_integrals) then integer :: load_ao_integrals print*,'Reading the AO integrals' diff --git a/src/Integrals_Bielec/integrals_3_index.irp.f b/src/Integrals_Bielec/integrals_3_index.irp.f new file mode 100644 index 00000000..b9ee29b9 --- /dev/null +++ b/src/Integrals_Bielec/integrals_3_index.irp.f @@ -0,0 +1,22 @@ + BEGIN_PROVIDER [double precision, big_array_coulomb_integrals, (mo_tot_num_align,mo_tot_num, mo_tot_num)] +&BEGIN_PROVIDER [double precision, big_array_exchange_integrals,(mo_tot_num_align,mo_tot_num, mo_tot_num)] + implicit none + integer :: i,j,k,l + double precision :: get_mo_bielec_integral_schwartz + double precision :: integral + + do k = 1, mo_tot_num + do i = 1, mo_tot_num + do j = 1, mo_tot_num + l = j + integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map) + big_array_coulomb_integrals(j,i,k) = integral + l = j + integral = get_mo_bielec_integral_schwartz(i,j,l,k,mo_integrals_map) + big_array_exchange_integrals(j,i,k) = integral + enddo + enddo + enddo + + +END_PROVIDER diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index dc35f278..305abee3 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -414,6 +414,73 @@ subroutine get_mo_bielec_integrals_ij(k,l,sze,out_array,map) deallocate(pairs,hash,iorder,tmp_val) end +subroutine get_mo_bielec_integrals_coulomb_ii(k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals + ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1) + ! for k,l fixed. + END_DOC + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE mo_bielec_integrals_in_map + + integer :: kk + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(k,i,l,i,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(map, hash, out_val, sze) + else + call map_get_many(map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + +subroutine get_mo_bielec_integrals_exch_ii(k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals + ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1) + ! for k,l fixed. + END_DOC + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE mo_bielec_integrals_in_map + + integer :: kk + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(k,i,i,l,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(map, hash, out_val, sze) + else + call map_get_many(map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + + integer*8 function get_mo_map_size() implicit none BEGIN_DOC diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 85fdde10..bf23ad1f 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -20,6 +20,7 @@ end BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] +use map_module implicit none integer(bit_kind) :: mask_ijkl(N_int,4) integer(bit_kind) :: mask_ijk(N_int,3) @@ -40,7 +41,7 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] if(no_vvvv_integrals)then integer :: i,j,k,l -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 4 ! print*, '' @@ -52,7 +53,7 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) enddo call add_integrals_to_map(mask_ijkl) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 2 (virt) ^2 ! = J_iv print*, '' @@ -76,17 +77,19 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] mask_ijkl(i,4) = virt_bitmask(i,1) enddo call add_integrals_to_map(mask_ijkl) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! + if(.not.no_vvv_integrals)then print*, '' - print*, '' + print*, ' and ' do i = 1,N_int - mask_ijk(i,1) = virt_bitmask(i,1) - mask_ijk(i,2) = virt_bitmask(i,1) - mask_ijk(i,3) = virt_bitmask(i,1) + mask_ijk(i,1) = virt_bitmask(i,1) + mask_ijk(i,2) = virt_bitmask(i,1) + mask_ijk(i,3) = virt_bitmask(i,1) enddo call add_integrals_to_map_three_indices(mask_ijk) + endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 3 (virt) ^1 ! print*, '' @@ -101,9 +104,9 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! ! (core+inact+act) ^ 1 (virt) ^3 ! - print*, '' - print*, '' if(.not.no_ivvv_integrals)then + print*, '' + print*, '' do i = 1,N_int mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) mask_ijkl(i,2) = virt_bitmask(i,1) @@ -116,6 +119,21 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] else call add_integrals_to_map(full_ijkl_bitmask_4) endif + + if(write_ao_map_after_transfo)then + call dump_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') + disk_access_ao_integrals = "Read" + touch disk_access_ao_integrals + call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read") + endif + if(clear_ao_map_after_mo_transfo)then + call clear_ao_map + integer (map_size_kind) :: get_ao_map_size + print*, '^^^^^^^^^^^^^^^^^^^^^' + print *, 'get_ao_map_size',get_ao_map_size + print*, '^^^^^^^^^^^^^^^^^^^^^' + FREE ao_bielec_integrals_in_map + endif END_PROVIDER subroutine set_integrals_jj_into_map @@ -391,64 +409,41 @@ subroutine add_integrals_to_map(mask_ijkl) endif j1 = ishft((l*l-l),-1) do j0 = 1, n_j -! print*, 'l :: j0',l j = list_ijkl(j0,2) -! print*, 'j :: 2',j if (j > l) then -! print*, 'j>l' -! print*, j,l exit endif j1 += 1 do k0 = 1, n_k k = list_ijkl(k0,3) -! print*, 'l :: k0',l -! print*, 'k :: 3',j i1 = ishft((k*k-k),-1) if (i1<=j1) then continue else -! print*, 'k>l' -! print*, k,l exit endif bielec_tmp_1 = 0.d0 do i0 = 1, n_i i = list_ijkl(i0,1) -! print*, 'l :: i0',l -! print*, 'i :: 1',i if (i>k) then -! print*, 'i>k' -! print*, i,k exit endif bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) ! i1+=1 enddo -! do i = 1, min(k,j1-i1+list_ijkl(1,1)) -! do i = 1, min(k,j1-i1+list_ijkl(1,1)-1) do i0 = 1, n_i i = list_ijkl(i0,1) if(i> min(k,j1-i1+list_ijkl(1,1)-1))then -! if (i>k) then !min(k,j1-i1) exit endif -! print*, i,j,k,l -! print*, k,j1,i1,j1-i1 if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle endif -! print*, i,j,k,l n_integrals += 1 buffer_value(n_integrals) = bielec_tmp_1(i) !DEC$ FORCEINLINE call mo_bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) -! if(i==12.and.k==12 .and.j==12.and.l==12)then -! print*, i,j,k,l,buffer_i(n_integrals) -! accu_bis += buffer_value(n_integrals) -! print*, buffer_value(n_integrals),accu_bis -! endif if (n_integrals == size_buffer) then call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,& real(mo_integrals_threshold,integral_kind)) @@ -631,7 +626,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) bielec_tmp_2 = 0.d0 do j1 = 1,ao_num call get_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) enddo do j1 = 1,ao_num kmax = 0 @@ -732,9 +726,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) j = list_ijkl(j0,2) do i0 = 1, n_i i = list_ijkl(i0,1) -! if(m==2)then -! if(i==j .and. j == k)cycle -! endif if (i>k) then exit endif diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 13138499..f9645aa4 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -561,3 +561,18 @@ end +subroutine matrix_vector_product(u0,u1,matrix,sze,lda) + implicit none + BEGIN_DOC +! performs u1 += u0 * matrix + END_DOC + integer, intent(in) :: sze,lda + double precision, intent(in) :: u0(sze) + double precision, intent(inout) :: u1(sze) + double precision, intent(in) :: matrix(lda,sze) + integer :: i,j + integer :: incx,incy + incx = 1 + incy = 1 + call dsymv('U', sze, 1.d0, matrix, lda, u0, incx, 1.d0, u1, incy) +end From 05e641de97750a593e9c1ccdceb58492705416f1 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 2 Nov 2016 16:11:13 +0100 Subject: [PATCH 30/32] warning --- plugins/Full_CI/NEEDED_CHILDREN_MODULES | 2 +- plugins/Perturbation/pt2_equations.irp.f | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index a1e61718..58203ca4 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full MRPT_Utils +Perturbation Selectors_full Generators_full diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 29aed8d3..b0d3e386 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -64,6 +64,7 @@ subroutine pt2_decontracted ($arguments) ASSERT (Nint > 0) !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) + H_pert_diag = 0.d0 c_pert(1) = coef_pert From d13853691a2038f61c3d13b9931b82af96faa50d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 2 Nov 2016 17:39:39 +0100 Subject: [PATCH 31/32] conflicts minimized for merge --- config/ifort.cfg | 9 +- plugins/Full_CI/EZFIO.cfg | 12 ++ plugins/Full_CI/full_ci.irp.f | 5 +- plugins/Full_CI/full_ci_no_skip.irp.f | 4 + plugins/MRPT_Utils/excitations_cas.irp.f | 40 +++---- plugins/MRPT_Utils/fock_like_operators.irp.f | 12 +- plugins/MRPT_Utils/new_way.irp.f | 26 ++--- .../new_way_second_order_coef.irp.f | 12 +- plugins/MRPT_Utils/second_order_new.irp.f | 12 +- plugins/MRPT_Utils/second_order_new_2p.irp.f | 6 +- plugins/Perturbation/EZFIO.cfg | 1 + plugins/Properties/EZFIO.cfg | 1 + plugins/Properties/hyperfine_constants.irp.f | 2 +- plugins/Selectors_full/selectors.irp.f | 3 +- src/Bitmask/bitmask_cas_routines.irp.f | 24 ++-- src/Determinants/EZFIO.cfg | 4 +- src/Determinants/NEEDED_CHILDREN_MODULES | 2 +- src/Determinants/diagonalize_CI.irp.f | 12 -- src/Determinants/slater_rules.irp.f | 104 +++++++++--------- src/Determinants/test_3d.irp.f | 15 --- src/Determinants/test_two_body.irp.f | 18 --- src/Determinants/utils.irp.f | 35 +----- src/Integrals_Bielec/integrals_3_index.irp.f | 6 +- src/Integrals_Bielec/map_integrals.irp.f | 26 +---- src/Integrals_Bielec/mo_bi_integrals.irp.f | 20 +--- 25 files changed, 155 insertions(+), 256 deletions(-) delete mode 100644 src/Determinants/test_3d.irp.f delete mode 100644 src/Determinants/test_two_body.irp.f diff --git a/config/ifort.cfg b/config/ifort.cfg index da414912..c1d7e968 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -31,14 +31,14 @@ OPENMP : 1 ; Append OpenMP flags # -ftz : Flushes denormal results to zero # [OPT] -FCFLAGS : -O2 -xHost -ip -ftz +FCFLAGS : -xSSE4.2 -O2 -ip -opt-prefetch -ftz -g # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : -xSSE4.2 -O2 -ip -ftz +FCFLAGS : -xSSE4.2 -O2 -ip -opt-prefetch -ftz # Debugging flags ################# @@ -50,9 +50,8 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz # -xSSE2 : Valgrind needs a very simple x86 executable # [DEBUG] -FC : -g -traceback -fpe0 -FCFLAGS : -xSSE2 -C -IRPF90_FLAGS : --openmp +FC : -g -traceback +FCFLAGS : -xSSE2 -C -fpe0 # OpenMP flags ################# diff --git a/plugins/Full_CI/EZFIO.cfg b/plugins/Full_CI/EZFIO.cfg index 9a552cd0..afb25d2e 100644 --- a/plugins/Full_CI/EZFIO.cfg +++ b/plugins/Full_CI/EZFIO.cfg @@ -8,3 +8,15 @@ type: double precision doc: Calculated FCI energy + PT2 interface: ezfio +[threshold_generators_pt2] +type: Threshold +doc: Thresholds on generators (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 0.999 + +[threshold_selectors_pt2] +type: Threshold +doc: Thresholds on selectors (fraction of the norm) for final PT2 calculation +interface: ezfio,provider,ocaml +default: 1. + diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index e6d0f7f2..ff599870 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -90,8 +90,9 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = 1.d0 - threshold_generators = 0.999d0 + threshold_generators = threshold_generators_pt2 + threshold_selectors = threshold_selectors_pt2 + SOFT_TOUCH threshold_generators threshold_selectors call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) print *, 'Final step' diff --git a/plugins/Full_CI/full_ci_no_skip.irp.f b/plugins/Full_CI/full_ci_no_skip.irp.f index 3ed304a1..078334f7 100644 --- a/plugins/Full_CI/full_ci_no_skip.irp.f +++ b/plugins/Full_CI/full_ci_no_skip.irp.f @@ -73,6 +73,10 @@ program full_ci call diagonalize_CI if(do_pt2_end)then print*,'Last iteration only to compute the PT2' + threshold_generators = threshold_generators_pt2 + threshold_selectors = threshold_selectors_pt2 + SOFT_TOUCH threshold_generators threshold_selectors + ! print*,'The thres' call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 805070f7..fb5cc953 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -270,7 +270,7 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -291,31 +291,31 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -333,15 +333,15 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) do k = 1, n_occ_ab(1) i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, n_occ_ab(2) i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -360,15 +360,15 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) do k = 1, n_occ_ab(2) i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, n_occ_ab(1) i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -494,7 +494,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -518,7 +518,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) if(exc(1,1,1) == exc(1,2,2) .and. exc(1,2,1) == exc(1,1,2))then hij = 0.d0 else - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & @@ -526,14 +526,14 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) endif else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & @@ -551,14 +551,14 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) do k = 1, n_occ_ab(1) i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, n_occ_ab(2) i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -577,14 +577,14 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) do k = 1, n_occ_ab(2) i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, n_occ_ab(1) i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index 2074daf6..d4ce0661 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -51,7 +51,7 @@ double precision :: accu_coulomb,accu_exchange(2) double precision :: na,nb,ntot double precision :: coulomb, exchange - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: j_act_orb,k_act_orb,i_inact_core_orb integer :: i_state @@ -75,8 +75,8 @@ na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) ntot = na + nb - coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) - exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) + coulomb = get_mo_bielec_integral(j_act_orb,i_inact_core_orb,k_act_orb,i_inact_core_orb,mo_integrals_map) + exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_inact_core_orb,i_inact_core_orb,mo_integrals_map) accu_coulomb += 2.d0 * ntot * coulomb accu_exchange(1) += 2.d0 * na * exchange accu_exchange(2) += 2.d0 * nb * exchange @@ -97,7 +97,7 @@ double precision :: accu_coulomb,accu_exchange(2) double precision :: na,nb,ntot double precision :: coulomb, exchange - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: j_act_orb,i_virt_orb,k_act_orb integer :: i_state ! TODO : inverse loop of i_state @@ -122,8 +122,8 @@ na = one_body_dm_mo_alpha(j_act_orb,k_act_orb,i_state) nb = one_body_dm_mo_beta(j_act_orb,k_act_orb,i_state) ntot = na + nb - coulomb = get_mo_bielec_integral_schwartz(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) - exchange = get_mo_bielec_integral_schwartz(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) + coulomb = get_mo_bielec_integral(j_act_orb,i_virt_orb,k_act_orb,i_virt_orb,mo_integrals_map) + exchange = get_mo_bielec_integral(j_act_orb,k_act_orb,i_virt_orb,i_virt_orb,mo_integrals_map) accu_coulomb += 2.d0 * ntot * coulomb accu_exchange(1) += 2.d0 * na * exchange accu_exchange(2) += 2.d0 * nb * exchange diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index 09016ab0..fa5812e1 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -15,7 +15,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer(bit_kind) :: det_tmp(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_2h1p = 0.d0 @@ -34,8 +34,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo integer :: degree(N_det) @@ -209,7 +209,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) integer(bit_kind) :: det_tmp(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_1h2p = 0.d0 @@ -228,8 +228,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo integer :: degree(N_det) @@ -406,7 +406,7 @@ subroutine give_1h1p_contrib(matrix_1h1p) integer(bit_kind) :: det_tmp(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase integer :: degree(N_det) @@ -474,10 +474,10 @@ subroutine give_1h1p_contrib(matrix_1h1p) endif call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(ispin == jspin )then - hij = -get_mo_bielec_integral_schwartz(iorb,aorb,rorb,borb,mo_integrals_map) & - + get_mo_bielec_integral_schwartz(iorb,aorb,borb,rorb,mo_integrals_map) + hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & + + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) else - hij = get_mo_bielec_integral_schwartz(iorb,borb,rorb,aorb,mo_integrals_map) + hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) endif hij = hij * phase double precision :: hij_test @@ -530,7 +530,7 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: hij_det_pert(n_inact_orb,n_virt_orb,2,N_states) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase integer :: degree(N_det) @@ -690,7 +690,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) double precision :: hij_det_pert(n_act_orb,n_virt_orb,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: hij,phase integer :: degree(N_det) integer :: idx(0:N_det) @@ -832,7 +832,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) integer(bit_kind) :: det_tmp(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase integer :: degree(N_det) diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 5c4b562f..4c12dbe1 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -16,7 +16,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) integer(bit_kind) :: det_tmp_j(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase integer :: index_orb_act_mono(N_det,6) @@ -36,8 +36,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange perturb_dets_phase(a,1,1) = -1000.d0 perturb_dets_phase(a,1,2) = -1000.d0 perturb_dets_phase(a,2,2) = -1000.d0 @@ -375,7 +375,7 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) integer(bit_kind) :: det_tmp_j(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib @@ -410,8 +410,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange perturb_dets_phase(a,1,1) = -1000.d0 perturb_dets_phase(a,1,2) = -1000.d0 perturb_dets_phase(a,2,2) = -1000.d0 diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index bcd08bf5..46de6601 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -18,7 +18,7 @@ subroutine give_1h2p_new(matrix_1h2p) integer(bit_kind) :: det_tmp_j(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) @@ -63,8 +63,8 @@ subroutine give_1h2p_new(matrix_1h2p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,aorb,rorb,vorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange perturb_dets_phase(a,1,1) = -1000.d0 perturb_dets_phase(a,1,2) = -1000.d0 perturb_dets_phase(a,2,2) = -1000.d0 @@ -495,7 +495,7 @@ subroutine give_2h1p_new(matrix_2h1p) integer(bit_kind) :: det_tmp(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase integer :: i_hole,i_part @@ -531,8 +531,8 @@ subroutine give_2h1p_new(matrix_2h1p) ! take all the integral you will need for i,j,r fixed do a = 1, n_act_orb aorb = list_act(a) - active_int(a,1) = get_mo_bielec_integral_schwartz(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct - active_int(a,2) = get_mo_bielec_integral_schwartz(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange + active_int(a,1) = get_mo_bielec_integral(iorb,jorb,rorb,aorb,mo_integrals_map) ! direct + active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange perturb_dets_phase(a,1,1) = -1000.d0 perturb_dets_phase(a,1,2) = -1000.d0 perturb_dets_phase(a,2,2) = -1000.d0 diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f index 2e94527c..11ae18da 100644 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -17,7 +17,7 @@ subroutine give_2p_new(matrix_2p) integer(bit_kind) :: det_tmp_j(N_int,2) integer :: exc(0:2,2,2) integer :: accu_elec - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) @@ -62,8 +62,8 @@ subroutine give_2p_new(matrix_2p) aorb = list_act(a) do b = 1, n_act_orb borb = list_act(b) - active_int(a,b,1) = get_mo_bielec_integral_schwartz(aorb,borb,rorb,vorb,mo_integrals_map) ! direct ( a--> r | b--> v ) - active_int(a,b,2) = get_mo_bielec_integral_schwartz(aorb,borb,vorb,rorb,mo_integrals_map) ! exchange ( b--> r | a--> v ) + active_int(a,b,1) = get_mo_bielec_integral(aorb,borb,rorb,vorb,mo_integrals_map) ! direct ( a--> r | b--> v ) + active_int(a,b,2) = get_mo_bielec_integral(aorb,borb,vorb,rorb,mo_integrals_map) ! exchange ( b--> r | a--> v ) perturb_dets_phase(a,b,1,1) = -1000.d0 perturb_dets_phase(a,b,1,2) = -1000.d0 perturb_dets_phase(a,b,2,2) = -1000.d0 diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index c5d6379f..9023accf 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -17,3 +17,4 @@ doc: The selection process stops when the energy ratio variational/(variational+ is equal to var_pt2_ratio interface: ezfio,provider,ocaml default: 0.75 + diff --git a/plugins/Properties/EZFIO.cfg b/plugins/Properties/EZFIO.cfg index 40ccd8b9..2a5ae803 100644 --- a/plugins/Properties/EZFIO.cfg +++ b/plugins/Properties/EZFIO.cfg @@ -9,3 +9,4 @@ type: double precision doc: threshold for the values of the alpha/beta two body dm evaluation interface: ezfio,provider,ocaml default: 0.000001 + diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index 63ad545b..6fa39278 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -151,7 +151,7 @@ subroutine print_hcc integer :: i,j print*,'Z AU GAUSS MHZ cm^-1' do i = 1, nucl_num - write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) + write(*,'(I2,X,F4.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) enddo end diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index 71c3550e..ce5e8367 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -20,8 +20,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] norm = norm + psi_average_norm_contrib_sorted(i) if (norm > threshold_selectors) then -! N_det_selectors = i-1 - N_det_selectors = i + N_det_selectors = i-1 exit endif enddo diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 961be5df..87a02d10 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -1,7 +1,8 @@ use bitmasks integer function number_of_holes(key_in) -use bitmasks - ! function that returns the number of holes in the inact space + BEGIN_DOC + ! Function that returns the number of holes in the inact space + END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -104,8 +105,9 @@ end integer function number_of_particles(key_in) -use bitmasks + BEGIN_DOC ! function that returns the number of particles in the virtual space + END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -208,12 +210,13 @@ use bitmasks end logical function is_a_two_holes_two_particles(key_in) -use bitmasks + BEGIN_DOC ! logical function that returns True if the determinant 'key_in' ! belongs to the 2h-2p excitation class of the DDCI space ! this is calculated using the CAS_bitmask that defines the active ! orbital space, the inact_bitmasl that defines the inactive oribital space ! and the virt_bitmask that defines the virtual orbital space + END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i,i_diff @@ -403,8 +406,9 @@ use bitmasks integer function number_of_holes_verbose(key_in) -use bitmasks + BEGIN_DOC ! function that returns the number of holes in the inact space + END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -432,7 +436,9 @@ end integer function number_of_particles_verbose(key_in) + BEGIN_DOC ! function that returns the number of particles in the inact space + END_DOC implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: i @@ -458,7 +464,6 @@ integer function number_of_particles_verbose(key_in) end logical function is_a_1h1p(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -470,7 +475,6 @@ use bitmasks end logical function is_a_1h2p(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -482,7 +486,6 @@ use bitmasks end logical function is_a_2h1p(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -494,7 +497,6 @@ use bitmasks end logical function is_a_1h(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -506,7 +508,6 @@ use bitmasks end logical function is_a_1p(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -518,7 +519,6 @@ use bitmasks end logical function is_a_2p(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -530,7 +530,6 @@ use bitmasks end logical function is_a_2h(key_in) -use bitmasks implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) integer :: number_of_particles, number_of_holes @@ -542,7 +541,6 @@ use bitmasks end logical function is_i_in_virtual(i) -use bitmasks implicit none integer,intent(in) :: i integer(bit_kind) :: key(N_int) diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 324005aa..afb2644e 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -127,13 +127,13 @@ default: 0. [store_full_H_mat] type: logical -doc: If True, the Davidson diagonalization is performed by storring the full H matrix up to n_det_max_stored. Be carefull, it can cost a lot of memory but can also save a lot of CPU time +doc: If True, the Davidson diagonalization is performed by storing the full H matrix up to n_det_max_stored. Be careful, it can cost a lot of memory but can also save a lot of CPU time interface: ezfio,provider,ocaml default: False [n_det_max_stored] type: Det_number_max -doc: Maximum number of determinants for which the full H matrix is stored. Be carefull, the memory requested scales as 10*n_det_max_stored**2. For instance, 90000 determinants represent a matrix of size 60 Gb. +doc: Maximum number of determinants for which the full H matrix is stored. Be careful, the memory requested scales as 10*n_det_max_stored**2. For instance, 90000 determinants represent a matrix of size 60 Gb. interface: ezfio,provider,ocaml default: 90000 diff --git a/src/Determinants/NEEDED_CHILDREN_MODULES b/src/Determinants/NEEDED_CHILDREN_MODULES index 566762ba..8711010f 100644 --- a/src/Determinants/NEEDED_CHILDREN_MODULES +++ b/src/Determinants/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Integrals_Monoelec Integrals_Bielec Hartree_Fock +Integrals_Monoelec Integrals_Bielec diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f index 49714082..6f94eedb 100644 --- a/src/Determinants/diagonalize_CI.irp.f +++ b/src/Determinants/diagonalize_CI.irp.f @@ -77,14 +77,10 @@ END_PROVIDER if (diag_algorithm == "Davidson") then - print*, '------------- In Davidson ' call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) - print*, '------------- Out Davidson ' do j=1,N_states_diag - print*, '------------- In S^2' call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),CI_eigenvectors_s2(j)) - print*, '------------- Out S^2' enddo @@ -103,7 +99,6 @@ END_PROVIDER do j=1,N_det call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) s2_eigvalues(j) = s2 - print*, 's2 in lapack',s2 print*, eigenvalues(j) + nuclear_repulsion ! Select at least n_states states with S^2 values closed to "expected_s2" if(dabs(s2-expected_s2).le.0.3d0)then @@ -219,12 +214,6 @@ END_PROVIDER do i = 1, N_det CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(iorder(j))) enddo -! call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int) -! print*,'e = ',CI_electronic_energy(j) -! print*,' = ',e_0 -! call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),s2) -! print*,'s^2 = ',CI_eigenvectors_s2(j) -! print*,'= ',s2 enddo deallocate(e_array,iorder) @@ -269,7 +258,6 @@ END_PROVIDER endif deallocate(s2_eigvalues) endif - print*, 'out provider' END_PROVIDER diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 5cbed15e..f98947a2 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -443,7 +443,7 @@ subroutine i_H_j_new(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -469,31 +469,31 @@ subroutine i_H_j_new(key_i,key_j,Nint,hij) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -512,15 +512,15 @@ subroutine i_H_j_new(key_i,key_j,Nint,hij) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -541,15 +541,15 @@ subroutine i_H_j_new(key_i,key_j,Nint,hij) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -583,7 +583,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -614,7 +614,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) else if (exc(1,2,1) ==exc(1,1,2))then hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) else - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & @@ -622,24 +622,24 @@ subroutine i_H_j(key_i,key_j,Nint,hij) endif else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -658,15 +658,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! do k = 1, elec_alpha_num ! i = occ(k,1) ! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) -! miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) +! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) +! miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) ! has_mipi(i) = .True. ! endif ! enddo ! do k = 1, elec_beta_num ! i = occ(k,2) ! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) ! has_mipi(i) = .True. ! endif ! enddo @@ -687,15 +687,15 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! do k = 1, elec_beta_num ! i = occ(k,2) ! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) -! miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) +! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) +! miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) ! has_mipi(i) = .True. ! endif ! enddo ! do k = 1, elec_alpha_num ! i = occ(k,1) ! if (.not.has_mipi(i)) then -! mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) +! mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) ! has_mipi(i) = .True. ! endif ! enddo @@ -731,7 +731,7 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) integer,intent(out) :: exc(0:2,2,2) integer,intent(out) :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -756,31 +756,31 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & exc(1,2,2) ,mo_integrals_map) else if (exc(0,1,1) == 2) then ! Double alpha - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) else if (exc(0,1,2) == 2) then ! Double beta - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -798,15 +798,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -825,15 +825,15 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -867,7 +867,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) integer :: exc(0:2,2,2) integer :: degree - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral integer :: m,n,p,q integer :: i,j,k integer :: occ(Nint*bit_kind_size,2) @@ -894,7 +894,7 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) call get_double_excitation(key_i,key_j,exc,phase,Nint) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - hij = phase*get_mo_bielec_integral_schwartz( & + hij = phase*get_mo_bielec_integral( & exc(1,1,1), & exc(1,1,2), & exc(1,2,1), & @@ -904,22 +904,22 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) else if (exc(0,1,1) == 2) then ! Double alpha print*,'phase hij = ',phase - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & exc(1,2,1) ,mo_integrals_map) ) - print*,get_mo_bielec_integral_schwartz( & + print*,get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(1,2,1), & exc(2,2,1) ,mo_integrals_map) - print*,get_mo_bielec_integral_schwartz( & + print*,get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & exc(2,2,1), & @@ -928,23 +928,23 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) else if (exc(0,1,2) == 2) then ! Double beta print*,'phase hij = ',phase - print*, get_mo_bielec_integral_schwartz( & + print*, get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map ) - print*, get_mo_bielec_integral_schwartz( & + print*, get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & exc(1,2,2) ,mo_integrals_map) - hij = phase*(get_mo_bielec_integral_schwartz( & + hij = phase*(get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(1,2,2), & exc(2,2,2) ,mo_integrals_map) - & - get_mo_bielec_integral_schwartz( & + get_mo_bielec_integral( & exc(1,1,2), & exc(2,1,2), & exc(2,2,2), & @@ -962,15 +962,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo @@ -989,15 +989,15 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) do k = 1, elec_beta_num i = occ(k,2) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral_schwartz(m,i,i,p,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) has_mipi(i) = .True. endif enddo do k = 1, elec_alpha_num i = occ(k,1) if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral_schwartz(m,i,p,i,mo_integrals_map) + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) has_mipi(i) = .True. endif enddo diff --git a/src/Determinants/test_3d.irp.f b/src/Determinants/test_3d.irp.f deleted file mode 100644 index a5d09cd3..00000000 --- a/src/Determinants/test_3d.irp.f +++ /dev/null @@ -1,15 +0,0 @@ -program test_3d - implicit none - integer :: i,npt - double precision :: dx,domain,x_min,x,step_function_becke -!domain = 5.d0 -!npt = 100 -!dx = domain/dble(npt) -!x_min = -0.5d0 * domain -!x = x_min -!do i = 1, npt -! write(33,*)x,step_function_becke(x) -! x += dx -!enddo - -end diff --git a/src/Determinants/test_two_body.irp.f b/src/Determinants/test_two_body.irp.f deleted file mode 100644 index 54c43c09..00000000 --- a/src/Determinants/test_two_body.irp.f +++ /dev/null @@ -1,18 +0,0 @@ -program test - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - integer :: i,j,k,l - do i = 1, n_act_orb - do j = 1, n_act_orb - do k = 1, n_act_orb - - enddo - enddo - enddo -end diff --git a/src/Determinants/utils.irp.f b/src/Determinants/utils.irp.f index cc191970..dbd5a7ef 100644 --- a/src/Determinants/utils.irp.f +++ b/src/Determinants/utils.irp.f @@ -8,13 +8,9 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] double precision :: hij integer :: degree(N_det),idx(0:N_det) call i_H_j(psi_det(1,1,1),psi_det(1,1,1),N_int,hij) - !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij,degree,idx,k) & + !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) & !$OMP SHARED (N_det, psi_det, N_int,H_matrix_all_dets) do i =1,N_det -! call get_excitation_degree_vector(psi_det,psi_det(1,1,i),degree,N_int,N_det,idx) -! do k =1, idx(0) -! j = idx(k) -! if(j.lt.i)cycle do j = i, N_det call i_H_j(psi_det(1,1,i),psi_det(1,1,j),N_int,hij) H_matrix_all_dets(i,j) = hij @@ -25,32 +21,3 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] END_PROVIDER -subroutine provide_big_matrix_stored_with_current_dets(sze,dets_in,big_matrix_stored) - use bitmasks - integer, intent(in) :: sze - integer(bit_kind), intent(in) :: dets_in(N_int,2,sze) - double precision, intent(out) :: big_matrix_stored(sze,sze) - integer :: i,j,k - double precision :: hij - integer :: degree(N_det),idx(0:N_det) - call i_H_j(dets_in(1,1,1),dets_in(1,1,1),N_int,hij) - print*, 'providing big_matrix_stored' - print*, n_det_max_stored - !$OMP PARALLEL DO SCHEDULE(GUIDED) PRIVATE(i,j,hij,degree,idx,k) & - !$OMP SHARED (sze, dets_in, N_int,big_matrix_stored) - do i =1,sze -! call get_excitation_degree_vector(dets_in,dets_in(1,1,i),degree,N_int,sze,idx) -! do k =1, idx(0) -! j = idx(k) - do j = i, sze - if(j.lt.i)cycle - call i_H_j(dets_in(1,1,i),dets_in(1,1,j),N_int,hij) - big_matrix_stored(i,j) = hij - big_matrix_stored(j,i) = hij - enddo - enddo - !$OMP END PARALLEL DO - print*, 'big_matrix_stored provided !!' - - -end diff --git a/src/Integrals_Bielec/integrals_3_index.irp.f b/src/Integrals_Bielec/integrals_3_index.irp.f index b9ee29b9..41037b34 100644 --- a/src/Integrals_Bielec/integrals_3_index.irp.f +++ b/src/Integrals_Bielec/integrals_3_index.irp.f @@ -2,17 +2,17 @@ &BEGIN_PROVIDER [double precision, big_array_exchange_integrals,(mo_tot_num_align,mo_tot_num, mo_tot_num)] implicit none integer :: i,j,k,l - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral double precision :: integral do k = 1, mo_tot_num do i = 1, mo_tot_num do j = 1, mo_tot_num l = j - integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map) + integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) big_array_coulomb_integrals(j,i,k) = integral l = j - integral = get_mo_bielec_integral_schwartz(i,j,l,k,mo_integrals_map) + integral = get_mo_bielec_integral(i,j,l,k,mo_integrals_map) big_array_exchange_integrals(j,i,k) = integral enddo enddo diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 305abee3..65561a57 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -294,28 +294,6 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) get_mo_bielec_integral = dble(tmp) end -double precision function get_mo_bielec_integral_schwartz(i,j,k,l,map) - use map_module - implicit none - BEGIN_DOC - ! Returns one integral in the MO basis - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - type(map_type), intent(inout) :: map - real(integral_kind) :: tmp - PROVIDE mo_bielec_integrals_in_map - if (mo_bielec_integral_schwartz(i,k)*mo_bielec_integral_schwartz(j,l) > mo_integrals_threshold) then - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - else - tmp = 0.d0 - endif - get_mo_bielec_integral_schwartz = dble(tmp) -end - double precision function mo_bielec_integral(i,j,k,l) implicit none @@ -323,9 +301,9 @@ double precision function mo_bielec_integral(i,j,k,l) ! Returns one integral in the MO basis END_DOC integer, intent(in) :: i,j,k,l - double precision :: get_mo_bielec_integral_schwartz + double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map - mo_bielec_integral = get_mo_bielec_integral_schwartz(i,j,k,l,mo_integrals_map) + mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) return end diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index bf23ad1f..af7f21d2 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -1447,22 +1447,6 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [ double precision, mo_bielec_integral_schwartz,(mo_tot_num,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Needed to compute Schwartz inequalities - END_DOC - - integer :: i,k - - do i=1,mo_tot_num - do k=1,mo_tot_num - mo_bielec_integral_schwartz(k,i) = 1.d10 - enddo - enddo - -END_PROVIDER - subroutine clear_mo_map implicit none @@ -1470,7 +1454,7 @@ subroutine clear_mo_map ! Frees the memory of the MO map END_DOC call map_deinit(mo_integrals_map) - FREE mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti + FREE mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti FREE mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map @@ -1478,7 +1462,7 @@ end subroutine provide_all_mo_integrals implicit none - provide mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti + provide mo_integrals_map mo_bielec_integral_jj mo_bielec_integral_jj_anti provide mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map end From e17e530ce132ad2a84ca58a6839f366b317f0bfd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 2 Nov 2016 23:55:19 +0100 Subject: [PATCH 32/32] Now compiles with gfortran --- plugins/MRPT_Utils/excitations_cas.irp.f | 4 ++-- plugins/MRPT_Utils/second_order_new.irp.f | 18 +++++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index fb5cc953..10cfe7c0 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -64,7 +64,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & accu_elec += popcnt(det_tmp_bis(j)) enddo if(accu_elec == 1)then - phase = phase * -1.d0 + phase = -phase endif enddo do j = 1, N_states_in @@ -102,7 +102,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & accu_elec += popcnt(det_tmp_bis(j)) enddo if(accu_elec == 1)then - phase = phase * -1.d0 + phase = -phase endif enddo do j = 1, N_states_in diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 46de6601..ba3b421b 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -198,8 +198,8 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == kspin .and. vorb.le.rorb)then cycle_same_spin_first_order = .True. endif -! if(ispin .ne. kspin .and. cycle_same_spin_first_order == .False. )then ! condition not to double count - if(cycle_same_spin_first_order == .False. )then ! condition not to double count +! if(ispin .ne. kspin .and. cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count + if(cycle_same_spin_first_order .eqv. .False. )then ! condition not to double count ! FIRST ORDER CONTRIBUTION @@ -235,7 +235,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == jspin .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then + if(cycle_same_spin_second_order .eqv. .False.)then do corb = 1, n_act_orb if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle do inint = 1, N_int @@ -292,7 +292,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(borb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,borb,2,ispin) @@ -326,7 +326,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) @@ -365,7 +365,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 2 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,2,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,2,ispin) @@ -400,7 +400,7 @@ subroutine give_1h2p_new(matrix_1h2p) if(ispin == 1 .and. vorb.le.rorb)then cycle_same_spin_second_order = .True. endif - if(cycle_same_spin_second_order == .False.)then ! condition not to double count + if(cycle_same_spin_second_order .eqv. .False.)then ! condition not to double count if(perturb_dets_phase(aorb,1,ispin) .le. -10.d0)cycle do inint = 1, N_int det_tmp(inint,1) = perturb_dets(inint,1,aorb,1,ispin) @@ -648,7 +648,7 @@ subroutine give_2h1p_new(matrix_2h1p) if(ispin == kspin .and. iorb.le.jorb)then cycle_same_spin_first_order = .True. endif - if(ispin .ne. kspin .or. cycle_same_spin_first_order == .False. )then! condition not to double count + if(ispin .ne. kspin .or. cycle_same_spin_first_order .eqv. .False. )then! condition not to double count ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{aorb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Idet > do inint = 1, N_int @@ -680,7 +680,7 @@ subroutine give_2h1p_new(matrix_2h1p) if(ispin == jspin .and. iorb.le.jorb)then cycle_same_spin_second_order = .True. endif - if(ispin .ne. jspin .or. cycle_same_spin_second_order == .False. )then! condition not to double count + if(ispin .ne. jspin .or. cycle_same_spin_second_order .eqv. .False. )then! condition not to double count do corb = 1, n_act_orb if(perturb_dets_phase(corb,jspin,ispin) .le. -10.d0)cycle do inint = 1, N_int