From 80cf1472ca55e922f69cf0eb7982cd5d8419753d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 4 Apr 2016 17:28:49 +0200 Subject: [PATCH 001/188] 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 002/188] 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 003/188] 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 004/188] 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 005/188] 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 6492f613a141830cbcf207004d29fbce7fd935ca Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 15 Jul 2016 15:31:16 +0200 Subject: [PATCH 006/188] Removed debug --- ocaml/Address.ml | 2 +- src/Determinants/connected_to_ref.irp.f | 9 +++------ src/Determinants/filter_connected.irp.f | 2 -- src/Determinants/slater_rules.irp.f | 5 ----- 4 files changed, 4 insertions(+), 14 deletions(-) diff --git a/ocaml/Address.ml b/ocaml/Address.ml index e107cf0c..47eb3fd6 100644 --- a/ocaml/Address.ml +++ b/ocaml/Address.ml @@ -42,7 +42,7 @@ end = struct assert (String.is_prefix ~prefix:"inproc://" x); x let create name = - Printf.sprintf "ipc://%s" name + Printf.sprintf "inproc://%s" name let to_string x = x end diff --git a/src/Determinants/connected_to_ref.irp.f b/src/Determinants/connected_to_ref.irp.f index 7a54bdbc..c0b611be 100644 --- a/src/Determinants/connected_to_ref.irp.f +++ b/src/Determinants/connected_to_ref.irp.f @@ -109,8 +109,6 @@ integer function get_index_in_psi_det_sorted_bit(key,Nint) continue else in_wavefunction = .True. - !DIR$ IVDEP - !DIR$ LOOP COUNT MIN(3) do l=2,Nint if ( (key(l,1) /= psi_det_sorted_bit(l,1,i)).or. & (key(l,2) /= psi_det_sorted_bit(l,2,i)) ) then @@ -175,7 +173,6 @@ logical function is_connected_to(key,keys,Nint,Ndet) do i=1,Ndet degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) do l=2,Nint degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& popcnt(xor( key(l,2), keys(l,2,i))) @@ -208,7 +205,6 @@ logical function is_connected_to_by_mono(key,keys,Nint,Ndet) do i=1,Ndet degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) do l=2,Nint degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& popcnt(xor( key(l,2), keys(l,2,i))) @@ -302,10 +298,12 @@ integer function connected_to_ref(key,keys,Nint,N_past_in,Ndet) do i=N_past-1,1,-1 degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) do l=2,Nint degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& popcnt(xor( key(l,2), keys(l,2,i))) + if (degree_x2 > 4) then + exit + endif enddo if (degree_x2 > 4) then cycle @@ -406,7 +404,6 @@ integer function connected_to_ref_by_mono(key,keys,Nint,N_past_in,Ndet) do i=N_past-1,1,-1 degree_x2 = popcnt(xor( key(1,1), keys(1,1,i))) + & popcnt(xor( key(1,2), keys(1,2,i))) - !DEC$ LOOP COUNT MIN(3) do l=2,Nint degree_x2 = degree_x2 + popcnt(xor( key(l,1), keys(l,1,i))) +& popcnt(xor( key(l,2), keys(l,2,i))) diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index 46280b31..34d6feb9 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -299,7 +299,6 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) else - integer, save :: icount(4) = (/0,0,0,0/) !DIR$ LOOP COUNT (1000) outer: do i=1,sze degree_x2 = 0 @@ -317,7 +316,6 @@ subroutine filter_connected_i_H_psi0(key1,key2,Nint,sze,idx) enddo idx(l) = i l = l+1 - icount(3) = icount(3) + 1_8 enddo outer endif diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 967ac9a3..ec7eb76d 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -1249,7 +1249,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) 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))) @@ -1264,7 +1263,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) 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))) + & @@ -1281,7 +1279,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) 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))) + & @@ -1300,10 +1297,8 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx) 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))) From a0d58690546d906304978f83e8e360d66690e7d6 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 16 Jul 2016 16:09:50 +0200 Subject: [PATCH 007/188] 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 008/188] 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 009/188] 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 010/188] 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 011/188] 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 012/188] 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 013/188] 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 014/188] 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 015/188] 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 016/188] 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 017/188] 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 018/188] 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 019/188] 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 020/188] 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 021/188] 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 022/188] 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 023/188] 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 024/188] 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 025/188] 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 026/188] 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 027/188] 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 028/188] 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 e356e97e167cf865a9129c3d37de5ad763e1feb9 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 12 Oct 2016 11:26:21 +0200 Subject: [PATCH 029/188] Introduced qp_run -slave --- ocaml/Qpackage.ml | 11 +++++++++++ ocaml/TaskServer.ml | 24 +++++++++++------------ ocaml/TaskServer.mli | 4 ++-- ocaml/qp_run.ml | 46 ++++++++++++++++++++++++++++++-------------- src/ZMQ/utils.irp.f | 14 +++++++++----- 5 files changed, 65 insertions(+), 34 deletions(-) diff --git a/ocaml/Qpackage.ml b/ocaml/Qpackage.ml index bd0d34fc..8011b23b 100644 --- a/ocaml/Qpackage.ml +++ b/ocaml/Qpackage.ml @@ -127,3 +127,14 @@ let get_ezfio_default directory data = |> aux ;; +let ezfio_work ezfio_file = + let result = + Filename.concat ezfio_file "work" + in + begin + match Sys.is_directory result with + | `Yes -> () + | _ -> Unix.mkdir result + end; + result +;; diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 6f012981..cfc22cfc 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -48,20 +48,21 @@ let zmq_context = ZMQ.Context.create () -let bind_socket ~socket_type ~socket ~address = +let bind_socket ~socket_type ~socket ~port = let rec loop = function | 0 -> failwith @@ Printf.sprintf - "Unable to bind the %s socket : %s " - socket_type address + "Unable to bind the %s socket to port : %d " + socket_type port | -1 -> () | i -> try - ZMQ.Socket.bind socket address; + ZMQ.Socket.bind socket @@ Printf.sprintf "tcp://*:%d" port; loop (-1) with | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) | other_exception -> raise other_exception - in loop 60 + in loop 60; + ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port let hostname = lazy ( @@ -115,7 +116,7 @@ let stop ~port = let req_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.req and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + Printf.sprintf "ipc:///tmp/qp_run:%d" port in ZMQ.Socket.set_linger_period req_socket 1_000_000; ZMQ.Socket.connect req_socket address; @@ -567,10 +568,8 @@ let start_pub_thread ~port = let pub_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.pub - and address = - Printf.sprintf "tcp://*:%d" port in - bind_socket ~socket_type:"PUB" ~socket:pub_socket ~address; + bind_socket ~socket_type:"PUB" ~socket:pub_socket ~port; let pollitem = ZMQ.Poll.mask_of @@ -608,7 +607,7 @@ let run ~port = and address = "inproc://pair" in - bind_socket "PAIR" pair_socket address; + ZMQ.Socket.bind pair_socket address; let pub_thread = start_pub_thread ~port:(port+1) () @@ -617,11 +616,9 @@ let run ~port = (** Bind REP socket *) let rep_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.rep - and address = - Printf.sprintf "tcp://*:%d" port in ZMQ.Socket.set_linger_period rep_socket 1_000_000; - bind_socket "REP" rep_socket address; + bind_socket "REP" rep_socket port; let initial_program_state = { queue = Queuing_system.create () ; @@ -721,6 +718,7 @@ let run ~port = ZMQ.Socket.send pair_socket @@ string_of_pub_state Stopped; Thread.join pub_thread; + ZMQ.Socket.close rep_socket diff --git a/ocaml/TaskServer.mli b/ocaml/TaskServer.mli index f923a18a..e1baab12 100644 --- a/ocaml/TaskServer.mli +++ b/ocaml/TaskServer.mli @@ -23,9 +23,9 @@ val debug : string -> unit (** ZeroMQ context *) val zmq_context : ZMQ.Context.t -(** Bind a ZMQ socket *) +(** Bind a ZMQ socket to a TCP port and to an IPC file /tmp/qp_run. *) val bind_socket : - socket_type:string -> socket:'a ZMQ.Socket.t -> address:string -> unit + socket_type:string -> socket:'a ZMQ.Socket.t -> port:int -> unit (** Name of the host on which the server runs *) val hostname : string lazy_t diff --git a/ocaml/qp_run.ml b/ocaml/qp_run.ml index 8a221614..e8c8d05a 100644 --- a/ocaml/qp_run.ml +++ b/ocaml/qp_run.ml @@ -15,7 +15,7 @@ let print_list () = let () = Random.self_init () -let run ~master exe ezfio_file = +let run slave exe ezfio_file = (** Check availability of the ports *) @@ -28,7 +28,7 @@ let run ~master exe ezfio_file = in let rec try_new_port port_number = try - List.iter [ 0;1;2;3;4 ] ~f:(fun i -> + List.iter [ 0;1;2;3;4;5;6;7;8;9 ] ~f:(fun i -> let address = Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) (port_number+i) in @@ -75,16 +75,23 @@ let run ~master exe ezfio_file = | 0 -> () | i -> failwith "Error: Input inconsistent\n" end; - begin - match master with - | Some address -> Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address - | None -> () - end; - (** Start task server *) - let address = - Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number + let qp_run_address_filename = + Filename.concat (Qpackage.ezfio_work ezfio_file) "qp_run_address" in + + let () = + if slave then + try + let address = + In_channel.read_all qp_run_address_filename + |> String.strip + in + Unix.putenv ~key:"QP_RUN_ADDRESS_MASTER" ~data:address + with Sys_error _ -> failwith "No master is not running" + in + + (** Start task server *) let task_thread = let thread = Thread.create ( fun () -> @@ -92,7 +99,16 @@ let run ~master exe ezfio_file = in thread (); in + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force TaskServer.ip_address) port_number + in Unix.putenv ~key:"QP_RUN_ADDRESS" ~data:address; + let () = + if (not slave) then + Out_channel.with_file qp_run_address_filename ~f:( + fun oc -> Out_channel.output_lines oc [address]) + in + (** Run executable *) let prefix = @@ -111,6 +127,8 @@ let run ~master exe ezfio_file = TaskServer.stop ~port:port_number; Thread.join task_thread; + if (not slave) then + Sys.remove qp_run_address_filename; let duration = Time.diff (Time.now()) time_start |> Core.Span.to_string in @@ -119,8 +137,8 @@ let run ~master exe ezfio_file = let spec = let open Command.Spec in empty - +> flag "master" (optional string) - ~doc:("address Address of the master process") + +> flag "slave" no_arg + ~doc:(" Needed for slave tasks") +> anon ("executable" %: string) +> anon ("ezfio_file" %: string) ;; @@ -138,8 +156,8 @@ Executes a Quantum Package binary file among these:\n\n" ) ) spec - (fun master exe ezfio_file () -> - run ~master exe ezfio_file + (fun slave exe ezfio_file () -> + run slave exe ezfio_file ) |> Command.run ~version: Git.sha1 ~build_info: Git.message diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index c3a55a05..61fb45de 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -670,12 +670,16 @@ subroutine disconnect_from_taskserver(zmq_to_qp_run_socket, & message = trim(message(1:rc)) read(message,*) reply, state - if ( (trim(reply) /= 'disconnect_reply').or. & - (trim(state) /= zmq_state) ) then - print *, 'Unable to disconnect : ', zmq_state - print *, trim(message) - stop -1 + if ((trim(reply) == 'disconnect_reply').and.(trim(state) == trim(zmq_state))) then + return endif + if (trim(message) == 'error No job is running') then + return + endif + + print *, 'Unable to disconnect : ', trim(zmq_state) + print *, trim(message) + stop -1 end From 5f836025780a884021c95b82871b4d56f1090716 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 12 Oct 2016 12:09:25 +0200 Subject: [PATCH 030/188] Introduced IPC for qp_run and sub sockets --- src/Davidson/davidson_parallel.irp.f | 4 +- src/ZMQ/utils.irp.f | 60 ++++++++++------------------ 2 files changed, 22 insertions(+), 42 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index cede52c9..50b58f67 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -501,7 +501,7 @@ subroutine davidson_miniserver_end() integer rc character*(64) buf - address = trim(qp_run_address)//':11223' + address = trim(qp_run_address_tcp)//':11223' requester = f77_zmq_socket(zmq_context, ZMQ_REQ) rc = f77_zmq_connect(requester,address) @@ -520,7 +520,7 @@ subroutine davidson_miniserver_get() character*(20) buffer integer rc - address = trim(qp_run_address)//':11223' + address = trim(qp_run_address_tcp)//':11223' requester = f77_zmq_socket(zmq_context, ZMQ_REQ) rc = f77_zmq_connect(requester,address) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 61fb45de..84665199 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -17,6 +17,8 @@ END_PROVIDER BEGIN_PROVIDER [ character*(128), qp_run_address ] +&BEGIN_PROVIDER [ character*(128), qp_run_address_ipc ] +&BEGIN_PROVIDER [ character*(128), qp_run_address_tcp ] &BEGIN_PROVIDER [ integer, zmq_port_start ] use f77_zmq implicit none @@ -34,19 +36,22 @@ END_PROVIDER integer :: i do i=len(buffer),1,-1 if ( buffer(i:i) == ':') then - qp_run_address = trim(buffer(1:i-1)) + qp_run_address_tcp = trim(buffer(1:i-1)) read(buffer(i+1:), *) zmq_port_start exit endif enddo + qp_run_address_ipc = 'ipc:///tmp/qp_run' + qp_run_address = qp_run_address_ipc END_PROVIDER + BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ] -&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ] -&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_address ] use f77_zmq implicit none BEGIN_DOC @@ -54,12 +59,12 @@ END_PROVIDER END_DOC character*(8), external :: zmq_port - zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' - zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address_tcp)//':'//zmq_port(2)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_sub_address = trim(qp_run_address)//':'//zmq_port(1)//' ' ! /!\ Don't forget to change subroutine reset_zmq_addresses END_PROVIDER @@ -72,12 +77,13 @@ subroutine reset_zmq_addresses END_DOC character*(8), external :: zmq_port - zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' - zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address_tcp)//':'//zmq_port(2)//' ' + zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address + zmq_socket_sub_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + end @@ -105,6 +111,7 @@ subroutine switch_qp_run_to_master exit endif enddo + qp_run_address_tcp = qp_run_address call reset_zmq_addresses end @@ -367,7 +374,7 @@ function new_zmq_sub_socket() stop 'Unable to subscribe new_zmq_sub_socket' endif - rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_tcp_address) + rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_address) if (rc /= 0) then stop 'Unable to connect new_zmq_sub_socket' endif @@ -403,17 +410,6 @@ subroutine end_zmq_pair_socket(zmq_socket_pair) character*(8), external :: zmq_port rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address) -! if (rc /= 0) then -! print *, rc -! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address)' -! stop 'error' -! endif - -! rc = f77_zmq_setsockopt(zmq_socket_pair,0ZMQ_LINGER,1000,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_LINGER on zmq_socket_pair' -! endif - rc = f77_zmq_close(zmq_socket_pair) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pair)' @@ -433,26 +429,7 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) character*(8), external :: zmq_port rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) -! if (rc /= 0) then -! print *, rc -! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)' -! stop 'error' -! endif - rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) -! if (rc /= 0) then -! print *, rc -! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)' -! stop 'error' -! endif - -! call sleep(1) ! see https://github.com/zeromq/libzmq/issues/1922 - -! rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,10000,4) -! if (rc /= 0) then -! stop 'Unable to set ZMQ_LINGER on zmq_socket_pull' -! endif - rc = f77_zmq_close(zmq_socket_pull) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pull)' @@ -784,6 +761,9 @@ subroutine get_task_from_taskserver(zmq_to_qp_run_socket,worker_id,task_id,task) else if (trim(reply) == 'terminate') then task_id = 0 task = 'terminate' + else if (trim(message) == 'error No job is running') then + task_id = 0 + task = 'terminate' else print *, 'Unable to get the next task' print *, trim(message) From bd91472407467433d7c44d78638bae1086dfcd37 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 12 Oct 2016 21:29:15 +0200 Subject: [PATCH 031/188] 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 d7b40e6d1fc4056b4d996b852493b153f9089ece Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 13 Oct 2016 12:32:22 +0200 Subject: [PATCH 032/188] Removed core from queuing_system --- ocaml/Id.ml | 24 +++---- ocaml/Id.mli | 23 +++++++ ocaml/Queuing_system.ml | 143 ++++++++++++++++++++++++++++----------- ocaml/Queuing_system.mli | 63 +++++++++++++++++ ocaml/TaskServer.ml | 6 +- 5 files changed, 201 insertions(+), 58 deletions(-) create mode 100644 ocaml/Id.mli create mode 100644 ocaml/Queuing_system.mli diff --git a/ocaml/Id.ml b/ocaml/Id.ml index 660c3452..3e616922 100644 --- a/ocaml/Id.ml +++ b/ocaml/Id.ml @@ -1,26 +1,22 @@ -open Core.Std - -module Id : sig - type t - val of_int : int -> t - val to_int : t -> int - val of_string : string -> t - val to_string : t -> string - val increment : t -> t - val decrement : t -> t -end -= struct +module Id = struct type t = int + let of_int x = assert (x>0); x + let to_int x = x + let of_string x = - Int.of_string x + int_of_string x |> of_int + let to_string x = - Int.to_string x + string_of_int x + let increment x = x + 1 let decrement x = x - 1 + + let compare = compare end module Task = struct diff --git a/ocaml/Id.mli b/ocaml/Id.mli new file mode 100644 index 00000000..02d1efca --- /dev/null +++ b/ocaml/Id.mli @@ -0,0 +1,23 @@ +module Id : + sig + type t + val of_int : int -> t + val to_int : t -> int + val of_string : string -> t + val to_string : t -> string + val increment : t -> t + val decrement : t -> t + val compare : t -> t -> int + end + + +module Task : + sig + include (module type of Id) + end + + +module Client : + sig + include (module type of Id) + end diff --git a/ocaml/Queuing_system.ml b/ocaml/Queuing_system.ml index 29a60538..5ee263a1 100644 --- a/ocaml/Queuing_system.ml +++ b/ocaml/Queuing_system.ml @@ -1,27 +1,33 @@ -open Core.Std -open Qptypes - +module RunningMap = Map.Make (Id.Task) +module TasksMap = Map.Make (Id.Task) +module ClientsSet = Set.Make (Id.Client) type t = { queued : Id.Task.t list ; - running : (Id.Task.t, Id.Client.t) Map.Poly.t ; - tasks : (Id.Task.t, string) Map.Poly.t; - clients : Id.Client.t Set.Poly.t; + running : Id.Client.t RunningMap.t; + tasks : string TasksMap.t; + clients : ClientsSet.t; next_client_id : Id.Client.t; next_task_id : Id.Task.t; - number_of_queued : int; + number_of_queued : int; + number_of_running : int; + number_of_tasks : int; + number_of_clients : int; } let create () = { queued = [] ; - running = Map.Poly.empty ; - tasks = Map.Poly.empty; - clients = Set.Poly.empty; + running = RunningMap.empty ; + tasks = TasksMap.empty; + clients = ClientsSet.empty; next_client_id = Id.Client.of_int 1; next_task_id = Id.Task.of_int 1; - number_of_queued = 0; + number_of_queued = 0; + number_of_running = 0; + number_of_tasks = 0; + number_of_clients = 0; } @@ -33,9 +39,10 @@ let add_task ~task q = in { q with queued = task_id :: q.queued ; - tasks = Map.add q.tasks ~key:task_id ~data:task ; + tasks = TasksMap.add task_id task q.tasks; next_task_id = Id.Task.increment task_id ; number_of_queued = q.number_of_queued + 1; + number_of_tasks = q.number_of_tasks + 1; } @@ -46,8 +53,9 @@ let add_client q = q.next_client_id in { q with - clients = Set.add q.clients client_id; + clients = ClientsSet.add client_id q.clients; next_client_id = Id.Client.increment client_id; + number_of_clients = q.number_of_clients + 1; }, client_id @@ -55,47 +63,57 @@ let pop_task ~client_id q = let { queued ; running ; _ } = q in - assert (Set.mem q.clients client_id); + assert (ClientsSet.mem client_id q.clients); match queued with | task_id :: new_queue -> let new_q = { q with queued = new_queue ; - running = Map.add running ~key:task_id ~data:client_id ; - number_of_queued = q.number_of_queued - 1; + running = RunningMap.add task_id client_id running; + number_of_queued = q.number_of_queued - 1; + number_of_running = q.number_of_running + 1; } - in new_q, Some task_id, (Map.find q.tasks task_id) + and found = + try Some (TasksMap.find task_id q.tasks) + with Not_found -> None + in new_q, Some task_id, found | [] -> q, None, None let del_client ~client_id q = - assert (Set.mem q.clients client_id); + assert (ClientsSet.mem client_id q.clients); { q with - clients = Set.remove q.clients client_id } + clients = ClientsSet.remove client_id q.clients; + number_of_clients = q.number_of_clients - 1 + } let end_task ~task_id ~client_id q = let { running ; tasks ; _ } = q in - assert (Set.mem q.clients client_id); - let () = - match Map.Poly.find running task_id with - | None -> failwith "Task already finished" - | Some client_id_check -> assert (client_id_check = client_id) + assert (ClientsSet.mem client_id q.clients); + let () = + let client_id_check = + try RunningMap.find task_id running with + Not_found -> failwith "Task already finished" + in + assert (client_id_check = client_id) in { q with - running = Map.remove running task_id ; + running = RunningMap.remove task_id running ; + number_of_running = q.number_of_running - 1 } - + let del_task ~task_id q = let { tasks ; _ } = q in - if (Map.mem tasks task_id) then + if (TasksMap.mem task_id tasks) then { q with - tasks = Map.remove tasks task_id ; + tasks = TasksMap.remove task_id tasks; + number_of_tasks = q.number_of_tasks - 1; } else Printf.sprintf "Task %d is already deleted" (Id.Task.to_int task_id) @@ -103,36 +121,79 @@ let del_task ~task_id q = -let number q = - Map.length q.tasks +let number_of_tasks q = + assert (q.number_of_tasks >= 0); + q.number_of_tasks let number_of_queued q = + assert (q.number_of_queued >= 0); q.number_of_queued let number_of_running q = - Map.length q.running + assert (q.number_of_running >= 0); + q.number_of_running + +let number_of_clients q = + assert (q.number_of_clients >= 0); + q.number_of_clients -let to_string { queued ; running ; tasks ; _ } = +let to_string qs = + let { queued ; running ; tasks ; _ } = qs in let q = - List.map ~f:Id.Task.to_string queued - |> String.concat ~sep:" ; " + List.map Id.Task.to_string queued + |> String.concat " ; " and r = - Map.Poly.to_alist running - |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", " + RunningMap.bindings running + |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", " ^(Id.Client.to_string c)^")") - |> String.concat ~sep:" ; " + |> String.concat " ; " and t = - Map.Poly.to_alist tasks - |> List.map ~f:(fun (t,c) -> "("^(Id.Task.to_string t)^", \"" + TasksMap.bindings tasks + |> List.map (fun (t,c) -> "("^(Id.Task.to_string t)^", \"" ^c^"\")") - |> String.concat ~sep:" ; " + |> String.concat " ; " in Printf.sprintf "{ +Tasks : %d Queued : %d Running : %d Clients : %d queued : { %s } running : { %s } tasks : [ %s ] -}" q r t +}" +(number_of_tasks qs) (number_of_queued qs) (number_of_running qs) (number_of_clients qs) +q r t + +let test () = + let q = + create () + |> add_task ~task:"First Task" + |> add_task ~task:"Second Task" + in + let q, client_id = + add_client q + in + let q, task_id, task_content = + match pop_task ~client_id q with + | q, Some x, Some y -> q, Id.Task.to_int x, y + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + let q, task_id, task_content = + match pop_task ~client_id q with + | q, Some x, Some y -> q, Id.Task.to_int x, y + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + let q, task_id, task_content = + match pop_task ~client_id q with + | q, None, None -> q, 0, "None" + | _ -> assert false + in + Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + q + |> to_string + |> print_endline + diff --git a/ocaml/Queuing_system.mli b/ocaml/Queuing_system.mli new file mode 100644 index 00000000..f0e8f941 --- /dev/null +++ b/ocaml/Queuing_system.mli @@ -0,0 +1,63 @@ +module RunningMap : Map.S with type key = Id.Task.t +module TasksMap : Map.S with type key = Id.Task.t +module ClientsSet : Set.S with type elt = Id.Client.t + +type t = { + queued : Id.Task.t list ; + running : Id.Client.t RunningMap.t ; + tasks : string TasksMap.t ; + clients : ClientsSet.t ; + next_client_id : Id.Client.t ; + next_task_id : Id.Task.t ; + number_of_queued : int ; + number_of_running : int ; + number_of_tasks : int ; + number_of_clients : int ; +} + +(** Creates a new queuing system. Returns the new queue. *) +val create : unit -> t + +(** Add a new task represented as a string. Returns the queue with the added task. *) +val add_task : task:string -> t -> t + +(** Add a new client. Returns the queue and a new client_id. *) +val add_client : t -> t * Id.Client.t + +(** Pops a task from the queue. The task is set as running on client client_id. + Returns the queue, a task_id and the content of the task. If the queue contains + no task, the task_id and the task content are None. *) +val pop_task : + client_id:ClientsSet.elt -> t -> t * Id.Task.t option * string option + +(** Deletes a client from the queuing system *) +val del_client : client_id:ClientsSet.elt -> t -> t + +(** Deletes a client from the queuing system. The client is assumed to be a member + of the set of clients. Returns the queue without the removed client. *) +val end_task : task_id:RunningMap.key -> client_id:ClientsSet.elt -> t -> t + +(** Deletes a task from the queuing system. The task is assumed to be a member + of the map of tasks. Returns the queue without the removed task. *) +val del_task : task_id:TasksMap.key -> t -> t + +(** Returns the number of tasks, assumed >= 0 *) +val number_of_tasks : t -> int + +(** Returns the number of queued tasks, assumed >= 0 *) +val number_of_queued : t -> int + +(** Returns the number of running tasks, assumed >= 0 *) +val number_of_running : t -> int + +(** Returns the number of connected clients, assumed >= 0 *) +val number_of_clients : t -> int + +(** Prints the content of the queue *) +val to_string : t -> string + +(** Test function for debug *) +val test : unit -> unit + + + diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index cfc22cfc..9a1797f8 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -306,7 +306,7 @@ let del_task msg program_state rep_socket = } in let more = - (Queuing_system.number new_program_state.queue > 0) + (Queuing_system.number_of_tasks new_program_state.queue > 0) in Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) |> Message.to_string @@ -678,9 +678,9 @@ let run ~port = (** Debug input *) Printf.sprintf "q:%d r:%d n:%d : %s\n%!" - (Queuing_system.number_of_queued program_state.queue) + (Queuing_system.number_of_queued program_state.queue) (Queuing_system.number_of_running program_state.queue) - (Queuing_system.number program_state.queue) + (Queuing_system.number_of_tasks program_state.queue) (Message.to_string message) |> debug; From 85596d9e7a512df29215c604b66fd82cf1098205 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Oct 2016 17:40:51 +0200 Subject: [PATCH 033/188] Queuing_system.ml pops from the back and adds to the front --- ocaml/Queuing_system.ml | 26 ++++++++++++++++++-------- ocaml/Queuing_system.mli | 4 ++-- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/ocaml/Queuing_system.ml b/ocaml/Queuing_system.ml index 5ee263a1..0c668e16 100644 --- a/ocaml/Queuing_system.ml +++ b/ocaml/Queuing_system.ml @@ -3,7 +3,8 @@ module TasksMap = Map.Make (Id.Task) module ClientsSet = Set.Make (Id.Client) type t = -{ queued : Id.Task.t list ; +{ queued_front : Id.Task.t list ; + queued_back : Id.Task.t list ; running : Id.Client.t RunningMap.t; tasks : string TasksMap.t; clients : ClientsSet.t; @@ -18,7 +19,8 @@ type t = let create () = - { queued = [] ; + { queued_front = [] ; + queued_back = [] ; running = RunningMap.empty ; tasks = TasksMap.empty; clients = ClientsSet.empty; @@ -38,7 +40,7 @@ let add_task ~task q = q.next_task_id in { q with - queued = task_id :: q.queued ; + queued_front = task_id :: q.queued_front ; tasks = TasksMap.add task_id task q.tasks; next_task_id = Id.Task.increment task_id ; number_of_queued = q.number_of_queued + 1; @@ -60,15 +62,21 @@ let add_client q = let pop_task ~client_id q = - let { queued ; running ; _ } = + let { queued_front ; queued_back ; running ; _ } = q in assert (ClientsSet.mem client_id q.clients); - match queued with + let queued_front', queued_back' = + match queued_front, queued_back with + | (l, []) -> ( [], List.rev l) + | t -> t + in + match queued_back' with | task_id :: new_queue -> let new_q = { q with - queued = new_queue ; + queued_front= queued_front' ; + queued_back = new_queue ; running = RunningMap.add task_id client_id running; number_of_queued = q.number_of_queued - 1; number_of_running = q.number_of_running + 1; @@ -139,9 +147,10 @@ let number_of_clients q = let to_string qs = - let { queued ; running ; tasks ; _ } = qs in + let { queued_back ; queued_front ; running ; tasks ; _ } = qs in let q = - List.map Id.Task.to_string queued + (List.map Id.Task.to_string queued_front) @ + (List.map Id.Task.to_string @@ List.rev queued_back) |> String.concat " ; " and r = RunningMap.bindings running @@ -181,6 +190,7 @@ let test () = | _ -> assert false in Printf.printf "Task_id : %d \t\t Task : %s\n" task_id task_content; + to_string q |> print_endline ; let q, task_id, task_content = match pop_task ~client_id q with | q, Some x, Some y -> q, Id.Task.to_int x, y diff --git a/ocaml/Queuing_system.mli b/ocaml/Queuing_system.mli index f0e8f941..dc6836d2 100644 --- a/ocaml/Queuing_system.mli +++ b/ocaml/Queuing_system.mli @@ -3,7 +3,8 @@ module TasksMap : Map.S with type key = Id.Task.t module ClientsSet : Set.S with type elt = Id.Client.t type t = { - queued : Id.Task.t list ; + queued_front : Id.Task.t list ; + queued_back : Id.Task.t list ; running : Id.Client.t RunningMap.t ; tasks : string TasksMap.t ; clients : ClientsSet.t ; @@ -60,4 +61,3 @@ val to_string : t -> string val test : unit -> unit - From 62e8d1a0ac21f1981f08f85ed41cd038c3dcd2df Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 13:38:45 +0200 Subject: [PATCH 034/188] The qp_run queue now pops from the back --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- src/Davidson/u0Hu0.irp.f | 2 +- src/Determinants/H_apply_zmq.template.f | 2 +- src/Integrals_Bielec/ao_bi_integrals.irp.f | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index c81b1266..a5dd8dcf 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -134,7 +134,7 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step + do i= 1,N_det_generators, step i_generator_start = max(i-step+1,1) i_generator_max = i write(task,*) i_generator_start, i_generator_max, 1, N diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index a1a72100..3787370a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -252,7 +252,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) ave_workload = ave_workload/dble(shortcut(0,1)) - do sh=shortcut(0,1),1,-1 + do sh=1,shortcut(0,1),1 workload = shortcut(0,1)+dble(shortcut(sh+1,1) - shortcut(sh,1))**2 do i=sh, shortcut(0,2), shortcut(0,1) do j=i, min(i, shortcut(0,2)) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index d59f2994..59544b79 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -35,7 +35,7 @@ subroutine $subroutine($params_main) call zmq_put_psi(zmq_to_qp_run_socket,1,energy,size(energy)) - do i_generator=N_det_generators,1,-1 + do i_generator=1,N_det_generators $skip write(task,*) i_generator call add_task_to_taskserver(zmq_to_qp_run_socket,task) diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 2ebb402e..9eadbf35 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -368,7 +368,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') - do l=1,ao_num + do l=ao_num,1,-1 write(task,*) "triangle ", l call add_task_to_taskserver(zmq_to_qp_run_socket,task) enddo From 973065319ce7bdd46c3fab86f4edfb102341e107 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 19:29:50 +0200 Subject: [PATCH 035/188] Introduced QR in Davidson --- ocaml/Progress_bar.ml | 4 +- src/Davidson/diagonalization_hs2.irp.f | 143 ++++++------------------- src/Utils/LinearAlgebra.irp.f | 44 +++++++- 3 files changed, 71 insertions(+), 120 deletions(-) diff --git a/ocaml/Progress_bar.ml b/ocaml/Progress_bar.ml index 2ca8bd00..b8e97a59 100644 --- a/ocaml/Progress_bar.ml +++ b/ocaml/Progress_bar.ml @@ -14,13 +14,13 @@ type t = let init ?(bar_length=20) ?(start_value=0.) ?(end_value=1.) ~title = { title ; start_value ; end_value ; bar_length ; cur_value=start_value ; - init_time= Time.now () ; dirty = true ; next = Time.now () } + init_time= Time.now () ; dirty = false ; next = Time.now () } let update ~cur_value bar = { bar with cur_value ; dirty=true } let increment_end bar = - { bar with end_value=(bar.end_value +. 1.) ; dirty=true } + { bar with end_value=(bar.end_value +. 1.) ; dirty=false } let increment_cur bar = { bar with cur_value=(bar.cur_value +. 1.) ; dirty=true } diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index c8ac3733..2db6b4cd 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -95,7 +95,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s double precision :: u_dot_v, u_dot_u - integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 @@ -107,12 +106,14 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall - integer :: shift, shift2 + integer :: shift, shift2, itermax include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda - if (N_st_diag > sze) then - stop 'error in Davidson : N_st_diag > sze' + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif PROVIDE nuclear_repulsion @@ -147,26 +148,26 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, external :: align_double sze_8 = align_double(sze) + itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & - W(sze_8,N_st_diag*davidson_sze_max), & - U(sze_8,N_st_diag*davidson_sze_max), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & R(sze_8,N_st_diag), & - S(sze_8,N_st_diag*davidson_sze_max), & - h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*davidson_sze_max), & - s2(N_st_diag*davidson_sze_max), & - lambda(N_st_diag*davidson_sze_max)) + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) h = 0.d0 s_ = 0.d0 s_tmp = 0.d0 - c = 0.d0 U = 0.d0 + W = 0.d0 S = 0.d0 R = 0.d0 y = 0.d0 @@ -183,10 +184,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - do k=1,N_st - call normalize(u_in(1,k),sze) - enddo - do k=N_st+1,N_st_diag do i=1,sze double precision :: r1, r2 @@ -194,14 +191,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call random_number(r2) u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) enddo - - ! Gram-Schmidt - ! ------------ - call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1), & - u_in(1,k),1,0.d0,c,1) - call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1), & - c,1,1.d0,u_in(1,k),1) - call normalize(u_in(1,k),sze) enddo @@ -213,11 +202,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo enddo - do iter=1,davidson_sze_max-1 + do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter + call ortho_qr(U,size(U,1),sze,shift2) ! Compute |W_k> = \sum_i |i> ! ----------------------------------------- @@ -229,20 +219,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Compute h_kl = = ! ------------------------------------------- - -! do l=1,N_st_diag -! do k=1,N_st_diag -! do iter2=1,iter-1 -! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) -! h(k,iter,l,iter2) = h(k,iter2,l,iter) -! enddo -! enddo -! do k=1,l -! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) -! h(l,iter,k,iter) = h(k,iter,l,iter) -! enddo -! enddo - call dgemm('T','N', shift2, N_st_diag, sze, & 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & 0.d0, h(1,shift+1), size(h,1)) @@ -295,22 +271,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Express eigenvectors of h in the determinant basis ! -------------------------------------------------- -! do k=1,N_st_diag -! do i=1,sze -! U(i,shift2+k) = 0.d0 -! W(i,shift2+k) = 0.d0 -! S(i,shift2+k) = 0.d0 -! enddo -! do l=1,N_st_diag*iter -! do i=1,sze -! U(i,shift2+k) = U(i,shift2+k) + U(i,l)*y(l,k) -! W(i,shift2+k) = W(i,shift2+k) + W(i,l)*y(l,k) -! S(i,shift2+k) = S(i,shift2+k) + S(i,l)*y(l,k) -! enddo -! enddo -! enddo -! -! call dgemm('N','N', sze, N_st_diag, shift2, & 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) call dgemm('N','N', sze, N_st_diag, shift2, & @@ -321,13 +281,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Compute residual vector ! ----------------------- -! do k=1,N_st_diag -! print *, s2(k) -! s2(k) = u_dot_v(U(1,shift2+k), S(1,shift2+k), sze) + S_z2_Sz -! print *, s2(k) -! print *, '' -! pause -! enddo do k=1,N_st_diag do i=1,sze R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & @@ -338,14 +291,17 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s to_print(1,k) = lambda(k) + nuclear_repulsion to_print(2,k) = s2(k) to_print(3,k) = residual_norm(k) - if (residual_norm(k) > 1.e9) then - stop 'Davidson failed' - endif endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(:,1:N_st) + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,A20))') iter, to_print(:,1:N_st), '' call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e9) then + print *, '' + stop 'Davidson failed' + endif + enddo if (converged) then exit endif @@ -359,42 +315,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo enddo - ! Gram-Schmidt - ! ------------ - - do k=1,N_st_diag - -! do l=1,N_st_diag*iter -! c(1) = u_dot_v(U(1,shift2+k),U(1,l),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,l) -! enddo -! enddo -! - call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & - U(1,shift2+k),1,0.d0,c,1) - call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & - c,1,1.d0,U(1,shift2+k),1) -! -! do l=1,k-1 -! c(1) = u_dot_v(U(1,shift2+k),U(1,shift2+l),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,shift2+l) -! enddo -! enddo -! - call dgemv('T',sze,k-1,1.d0,U(1,shift2+1),size(U,1), & - U(1,shift2+k),1,0.d0,c,1) - call dgemv('N',sze,k-1,-1.d0,U(1,shift2+1),size(U,1), & - c,1,1.d0,U(1,shift2+k),1) - - call normalize( U(1,shift2+k), sze ) - enddo - enddo if (.not.converged) then - iter = davidson_sze_max-1 + iter = itermax-1 endif ! Re-contract to u_in @@ -404,20 +328,14 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s energies(k) = lambda(k) enddo -! do k=1,N_st_diag -! do i=1,sze -! do l=1,iter*N_st_diag -! u_in(i,k) += U(i,l)*y(l,k) -! enddo -! enddo -! enddo -! enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo + do k=1,N_st_diag + S2_jj(k) = s2(k) + enddo write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ =========== ===========' @@ -427,7 +345,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call write_time(iunit) deallocate ( & - kl_pairs, & W, residual_norm, & U, & R, c, S, & diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 00f61101..e44e8c2c 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -11,9 +11,9 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) integer, intent(in) :: LDA, LDU, LDVt, m, n double precision, intent(in) :: A(LDA,n) - double precision, intent(out) :: U(LDU,n) + double precision, intent(out) :: U(LDU,m) double precision,intent(out) :: Vt(LDVt,n) - double precision,intent(out) :: D(n) + double precision,intent(out) :: D(min(m,n)) double precision,allocatable :: work(:) integer :: info, lwork, i, j, k @@ -24,13 +24,13 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) ! Find optimal size for temp arrays allocate(work(1)) lwork = -1 - call dgesvd('A','A', n, n, A_tmp, LDA, & + call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) lwork = work(1) deallocate(work) allocate(work(lwork)) - call dgesvd('A','A', n, n, A_tmp, LDA, & + call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) deallocate(work,A_tmp) @@ -125,6 +125,40 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m) end +subroutine ortho_qr(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + double precision, intent(inout) :: A(LDA,n) + + integer :: lwork, info + integer, allocatable :: jpvt(:) + double precision, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(1)) + LWORK=-1 +! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) + call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) + LWORK=WORK(1) + deallocate(WORK) + allocate(WORK(LWORK)) +! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) + call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) + call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) + deallocate(WORK,jpvt,tau) +end + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC @@ -161,7 +195,7 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) allocate(U(ldc,n),Vt(lda,n),S_half(lda,n),D(n)) - call svd(overlap,lda,U,ldc,D,Vt,lda,m,n) + call svd(overlap,lda,U,ldc,D,Vt,lda,n,n) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(S_half,U,D,Vt,n,C,m) & From 1fe1750f90bdd0176e2cd8f34499f39c650931de Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 21:36:45 +0200 Subject: [PATCH 036/188] Removed residual in Davdison --- src/Davidson/diagonalization_hs2.irp.f | 46 ++++++++++++++------------ 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 2db6b4cd..abffcf81 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -98,7 +98,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), R(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -109,7 +109,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: shift, shift2, itermax include 'constants.include.F' - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then print *, 'error in Davidson :' print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 @@ -152,7 +152,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s allocate( & W(sze_8,N_st_diag*itermax), & U(sze_8,N_st_diag*itermax), & - R(sze_8,N_st_diag), & S(sze_8,N_st_diag*itermax), & h(N_st_diag*itermax,N_st_diag*itermax), & y(N_st_diag*itermax,N_st_diag*itermax), & @@ -169,7 +168,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s U = 0.d0 W = 0.d0 S = 0.d0 - R = 0.d0 y = 0.d0 @@ -184,12 +182,24 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - do k=N_st+1,N_st_diag + double precision :: r1, r2 + do k=N_st+1,N_st_diag-2,2 do i=1,sze - double precision :: r1, r2 call random_number(r1) call random_number(r2) - u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + u_in(i,k+1) = r1*dsin(r2) + enddo + enddo + do k=N_st_diag-1,N_st_diag + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) enddo enddo @@ -278,16 +288,17 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call dgemm('N','N', sze, N_st_diag, shift2, & 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) - ! Compute residual vector - ! ----------------------- + ! Compute residual vector and davidson step + ! ----------------------------------------- do k=1,N_st_diag do i=1,sze - R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz) + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz) & + /max(H_jj(i) - lambda (k),1.d-2) enddo if (k <= N_st) then - residual_norm(k) = u_dot_u(R(1,k),sze) + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion to_print(2,k) = s2(k) to_print(3,k) = residual_norm(k) @@ -306,15 +317,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s exit endif - ! Davidson step - ! ------------- - - do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = - R(i,k)/max(H_jj(i) - lambda(k),1.d-2) - enddo - enddo - enddo if (.not.converged) then @@ -347,7 +349,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s deallocate ( & W, residual_norm, & U, & - R, c, S, & + c, S, & h, & y, s_, s_tmp, & lambda & From 4119577ae8335d49548f875219a1b7a4263e81ba Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 22:20:46 +0200 Subject: [PATCH 037/188] Minor changes --- src/Davidson/diagonalization_hs2.irp.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index abffcf81..a7bc2b95 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -294,8 +294,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag do i=1,sze U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz) & - /max(H_jj(i) - lambda (k),1.d-2) + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) enddo if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) @@ -305,10 +305,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,A20))') iter, to_print(:,1:N_st), '' + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,A30))') iter, to_print(:,1:N_st), '' call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) do k=1,N_st - if (residual_norm(k) > 1.e9) then + if (residual_norm(k) > 1.e4) then print *, '' stop 'Davidson failed' endif From 2f1c7c5ce90f1b107992b5b7c0e461cf8a3d1a63 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 23:07:03 +0200 Subject: [PATCH 038/188] Small changes in MRCC --- plugins/MRCC_Utils/mrcc_dress.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 323 +++++++++++++++++++--------- plugins/mrcepa0/EZFIO.cfg | 2 +- plugins/mrcepa0/dressing.irp.f | 37 ++-- 4 files changed, 241 insertions(+), 123 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_dress.irp.f b/plugins/MRCC_Utils/mrcc_dress.irp.f index e6d0fb81..5c2f5efc 100644 --- a/plugins/MRCC_Utils/mrcc_dress.irp.f +++ b/plugins/MRCC_Utils/mrcc_dress.irp.f @@ -271,7 +271,7 @@ subroutine mrcc_dress(delta_ij_, delta_ii_, Nstates, Ndet_non_ref, Ndet_ref,i_ge !delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0 * dIa_hla(i_state,k_sd) enddo endif enddo diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 14885153..f1c4b4a3 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -685,7 +685,7 @@ END_PROVIDER - do s = 1, N_states + do s=1, N_states A_val = 0d0 A_ind = 0 @@ -698,61 +698,61 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)& !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)& - !$OMP shared(active, active_hh_idx, active_pp_idx, nactive)& + !$OMP shared(active, active_hh_idx, active_pp_idx, nactive) & !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh) - allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) - do ppp=1,nactive - pp = active_pp_idx(ppp) - hh = active_hh_idx(ppp) - lref = 0 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind /= -1) then - call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - if (phase > 0.d0) then - lref(psi_non_ref_sorted_idx(ind)) = II - else - lref(psi_non_ref_sorted_idx(ind)) = -II - endif - end if - end do - wk = 0 - do i=1, N_det_non_ref - if(lref(i) > 0) then - wk += 1 - A_val(wk, ppp) = psi_ref_coef(lref(i), s) - A_ind(wk, ppp) = i - else if(lref(i) < 0) then - wk += 1 - A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) - A_ind(wk, ppp) = i - end if - end do - A_ind(0,ppp) = wk + allocate(lref(N_det_non_ref)) + !$OMP DO schedule(static,10) + do ppp=1,nactive + pp = active_pp_idx(ppp) + hh = active_hh_idx(ppp) + lref = 0 + do II = 1, N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind /= -1) then + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + if (phase > 0.d0) then + lref(psi_non_ref_sorted_idx(ind)) = II + else + lref(psi_non_ref_sorted_idx(ind)) = -II + endif + end if end do + wk = 0 + do i=1, N_det_non_ref + if(lref(i) > 0) then + wk += 1 + A_val(wk, ppp) = psi_ref_coef(lref(i), s) + A_ind(wk, ppp) = i + else if(lref(i) < 0) then + wk += 1 + A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) + A_ind(wk, ppp) = i + end if + end do + A_ind(0,ppp) = wk + end do !$OMP END DO deallocate(lref) - !$OMP END PARALLEL - - + !$OMP END PARALLEL + + print *, 'Done building A_val, A_ind' AtA_size = 0 col_shortcut = 0 N_col = 0 - integer :: a_coll, at_roww + integer :: a_coll, at_roww !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)& !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx) allocate(A_val_mwen(nex), A_ind_mwen(nex)) - + !$OMP DO schedule(dynamic, 100) do at_roww = 1, nactive ! nex at_row = active_pp_idx(at_roww) @@ -762,8 +762,8 @@ END_PROVIDER j = active_pp_idx(i) AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww) end do - - do a_coll = 1, nactive + + do a_coll = 1, nactive a_col = active_pp_idx(a_coll) t = 0d0 r1 = 1 @@ -795,12 +795,12 @@ END_PROVIDER col_shortcut(at_roww) = AtA_size+1 N_col(at_roww) = wk if (AtA_size+wk > size(AtA_ind,1)) then - print *, AtA_size+wk , size(AtA_ind,1) - stop 'too small' + print *, AtA_size+wk , size(AtA_ind,1) + stop 'too small' endif do i=1,wk - AtA_ind(AtA_size+i) = A_ind_mwen(i) - AtA_val(AtA_size+i) = A_val_mwen(i) + AtA_ind(AtA_size+i) = A_ind_mwen(i) + AtA_val(AtA_size+i) = A_val_mwen(i) enddo AtA_size += wk !$OMP END CRITICAL @@ -822,41 +822,41 @@ END_PROVIDER rho_mrcc_init = 0d0 allocate(lref(N_det_ref)) - !$OMP PARALLEL DO default(shared) schedule(static, 1) & + !$OMP PARALLEL DO default(shared) schedule(static, 1) & !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) cycle - lref = 0 - do II=1,N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - ind = psi_non_ref_sorted_idx(ind) - call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) += psi_ref_coef(II,s)**2 - AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase - lref(II) = ind - if(phase < 0d0) lref(II) = -ind + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(active(pp)) cycle + lref = 0 + do II=1,N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind == -1) cycle + ind = psi_non_ref_sorted_idx(ind) + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + X(pp) += psi_ref_coef(II,s)**2 + AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase + lref(II) = ind + if(phase < 0d0) lref(II) = -ind + end do + X(pp) = AtB(pp) / X(pp) + do II=1,N_det_ref + if(lref(II) > 0) then + rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) + else if(lref(II) < 0) then + rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) + end if + end do end do - X(pp) = AtB(pp) / X(pp) - do II=1,N_det_ref - if(lref(II) > 0) then - rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) - else if(lref(II) < 0) then - rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) - end if - end do - end do end do !$OMP END PARALLEL DO x_new = x - - double precision :: factor, resold + + double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) do k=0,100000 @@ -882,10 +882,10 @@ END_PROVIDER !$OMP END PARALLEL res = 0.d0 - + if (res < resold) then - do a_coll=1,nactive ! nex + do a_coll=1,nactive ! nex a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref i = A_ind(j,a_coll) @@ -894,60 +894,172 @@ END_PROVIDER enddo res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) - end do - factor = 1.d0 + end do + factor = 1.d0 else factor = -factor * 0.5d0 endif resold = res - - if(mod(k, 5) == 0) then + + if(mod(k, 100) == 0) then print *, "res ", k, res end if - if(res < 1d-12) exit + if(res < 1d-9) exit end do norm = 0.d0 - do i=1,N_det_non_ref - norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) - enddo - ! Norm now contains the norm of A.X - - do i=1,N_det_ref - norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) - enddo - ! Norm now contains the norm of Psi + A.X - - print *, k, "res : ", res, "norm : ", sqrt(norm) - - !dIj_unique(:size(X), s) = X(:) + do i=1,N_det_non_ref + norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) + enddo + ! Norm now contains the norm of A.X + + do i=1,N_det_ref + norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) + enddo + ! Norm now contains the norm of Psi + A.X + + print *, k, "res : ", res, "norm : ", sqrt(norm) + +!--------------- +! double precision :: e_0, overlap +! double precision, allocatable :: u_0(:) +! integer(bit_kind), allocatable :: keys_tmp(:,:,:) +! allocate (u_0(N_det), keys_tmp(N_int,2,N_det) ) +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! u_0(k) = psi_non_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |Psi_CASSD> : ', e_0 + nuclear_repulsion, overlap +! +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! ! f is such that f.\tilde{c_i} = c_i +! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) +! +! ! Avoid numerical instabilities +! f = min(f,2.d0) +! f = max(f,-2.d0) +! +! f = 1.d0 +! +! u_0(k) = rho_mrcc(i,1)*f +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! norm += u_0(k)**2 +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> : ', e_0 + nuclear_repulsion, overlap +! +! f = 1.d0/norm +! norm = 1.d0 +! do i=1,N_det_ref +! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) +! enddo +! f = dsqrt(f*norm) +! overlap = norm +! do i=1,N_det_non_ref +! u_0(k) = rho_mrcc(i,1)*f +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (normalized) : ', e_0 + nuclear_repulsion, overlap +! +! k=0 +! overlap = 0.d0 +! do i=1,N_det_ref +! k = k+1 +! u_0(k) = psi_ref_coef(i,1) +! keys_tmp(:,:,k) = psi_ref(:,:,i) +! overlap += u_0(k)*psi_ref_coef(i,1) +! enddo +! norm = 0.d0 +! do i=1,N_det_non_ref +! k = k+1 +! ! f is such that f.\tilde{c_i} = c_i +! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) +! +! ! Avoid numerical instabilities +! f = min(f,2.d0) +! f = max(f,-2.d0) +! +! u_0(k) = rho_mrcc(i,1)*f +! keys_tmp(:,:,k) = psi_non_ref(:,:,i) +! norm += u_0(k)**2 +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (mu_i): ', e_0 + nuclear_repulsion, overlap +! +! f = 1.d0/norm +! norm = 1.d0 +! do i=1,N_det_ref +! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) +! enddo +! overlap = norm +! f = dsqrt(f*norm) +! do i=1,N_det_non_ref +! u_0(k) = rho_mrcc(i,1)*f +! overlap += u_0(k)*psi_non_ref_coef(i,1) +! enddo +! +! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) +! print *, 'Energy of |(1+T)Psi_0> (normalized mu_i) : ', e_0 + nuclear_repulsion, overlap +! +! deallocate(u_0, keys_tmp) +! +!--------------- norm = 0.d0 - double precision :: f + double precision :: f do i=1,N_det_non_ref if (rho_mrcc(i,s) == 0.d0) then rho_mrcc(i,s) = 1.d-32 endif - + ! f is such that f.\tilde{c_i} = c_i f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) - + ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - + norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f enddo ! norm now contains the norm of |T.Psi_0> ! rho_mrcc now contains the f factors - + f = 1.d0/norm ! f now contains 1/ - + norm = 1.d0 do i=1,N_det_ref norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -955,22 +1067,23 @@ END_PROVIDER ! norm now contains f = dsqrt(f*norm) ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized - + norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - + do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) enddo - + do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant - dIj_unique(:size(X), s) = X(:) + dIj_unique(:size(X), s) = X(:) end do + END_PROVIDER diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index d792390d..61f3392f 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -23,7 +23,7 @@ interface: ezfio type: Threshold doc: Threshold on the convergence of the dressed CI energy interface: ezfio,provider,ocaml -default: 1.e-4 +default: 5.e-5 [n_it_max_dressed_ci] type: Strictly_positive_int diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 8df7e91a..4f355f2b 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -299,7 +299,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) enddo endif enddo @@ -554,7 +554,7 @@ END_PROVIDER do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) - call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) +! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) @@ -647,7 +647,7 @@ end function integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, HIIi, HJk, wall + double precision :: contrib, contrib2, HIIi, HJk, wall integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) integer(bit_kind),allocatable :: sortRef(:,:,:) @@ -677,7 +677,7 @@ end function delta_mrcepa0_ij(:,:,:) = 0d0 !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) @@ -720,16 +720,18 @@ end function !$OMP ATOMIC notf = notf+1 - call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) - !contrib = delta_cas(II, J, i_state) * HJk * lambda_mrcc(i_state, det_cepa0_idx(k)) +! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - !$OMP ATOMIC - delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC - delta_mrcepa0_ii(J,i_state) -= contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + delta_mrcepa0_ii(J,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 end if + !$OMP ATOMIC + delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib end do kloop end do @@ -753,7 +755,7 @@ END_PROVIDER integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ logical :: ok double precision :: phase_Ji, phase_Ik, phase_Ii - double precision :: contrib, delta_IJk, HJk, HIk, HIl + double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) integer, allocatable :: idx_sorted_bit(:) @@ -778,7 +780,7 @@ END_PROVIDER !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & - !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & + !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & !$OMP private(det_tmp, det_tmp2, II, blok) & !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) @@ -827,13 +829,16 @@ END_PROVIDER delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) if(ok) cycle - contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) + contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) + if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) + !$OMP ATOMIC + delta_sub_ii(II,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 + endif !$OMP ATOMIC delta_sub_ij(II, i, i_state) += contrib - if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then - !$OMP ATOMIC - delta_sub_ii(II,i_state) -= contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) - endif end do end do end do From 360d38a41de3c30cdba6ce8fbadb50d0e18b82f4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 23:10:04 +0200 Subject: [PATCH 039/188] Format error in loc_cele --- plugins/loc_cele/loc_cele.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index c9036aa1..52e0ef28 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -451,7 +451,7 @@ enddo !big loop over symmetry - 10 format (4E18.12) + 10 format (4E19.12) ! Now we copyt the newcmo into the mo_coef From 1185d70be7404841abb9d4c0c419ba41f91af49d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Oct 2016 23:31:20 +0200 Subject: [PATCH 040/188] Removed all ipc between Fortran and OCaml --- ocaml/TaskServer.ml | 4 ++-- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 16 ++++++++-------- plugins/mrcepa0/dressing.irp.f | 1 - src/Davidson/davidson_parallel.irp.f | 4 ++-- src/ZMQ/utils.irp.f | 27 ++++++++++----------------- 6 files changed, 23 insertions(+), 31 deletions(-) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 9a1797f8..6edc8122 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -678,9 +678,9 @@ let run ~port = (** Debug input *) Printf.sprintf "q:%d r:%d n:%d : %s\n%!" - (Queuing_system.number_of_queued program_state.queue) + (Queuing_system.number_of_queued program_state.queue) (Queuing_system.number_of_running program_state.queue) - (Queuing_system.number_of_tasks program_state.queue) + (Queuing_system.number_of_tasks program_state.queue) (Message.to_string message) |> debug; diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index a5dd8dcf..c81b1266 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -134,7 +134,7 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= 1,N_det_generators, step + do i= N_det_generators, 1, -step i_generator_start = max(i-step+1,1) i_generator_max = i write(task,*) i_generator_start, i_generator_max, 1, N diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f1c4b4a3..84bca0b4 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -1043,23 +1043,23 @@ END_PROVIDER if (rho_mrcc(i,s) == 0.d0) then rho_mrcc(i,s) = 1.d-32 endif - + ! f is such that f.\tilde{c_i} = c_i f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) - + ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - + norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f enddo ! norm now contains the norm of |T.Psi_0> ! rho_mrcc now contains the f factors - + f = 1.d0/norm ! f now contains 1/ - + norm = 1.d0 do i=1,N_det_ref norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -1067,14 +1067,14 @@ END_PROVIDER ! norm now contains f = dsqrt(f*norm) ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized - + norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - + do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) enddo - + do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 4f355f2b..3646b0b2 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -554,7 +554,6 @@ END_PROVIDER do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) -! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 50b58f67..cede52c9 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -501,7 +501,7 @@ subroutine davidson_miniserver_end() integer rc character*(64) buf - address = trim(qp_run_address_tcp)//':11223' + address = trim(qp_run_address)//':11223' requester = f77_zmq_socket(zmq_context, ZMQ_REQ) rc = f77_zmq_connect(requester,address) @@ -520,7 +520,7 @@ subroutine davidson_miniserver_get() character*(20) buffer integer rc - address = trim(qp_run_address_tcp)//':11223' + address = trim(qp_run_address)//':11223' requester = f77_zmq_socket(zmq_context, ZMQ_REQ) rc = f77_zmq_connect(requester,address) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 84665199..f2703ff8 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -17,8 +17,6 @@ END_PROVIDER BEGIN_PROVIDER [ character*(128), qp_run_address ] -&BEGIN_PROVIDER [ character*(128), qp_run_address_ipc ] -&BEGIN_PROVIDER [ character*(128), qp_run_address_tcp ] &BEGIN_PROVIDER [ integer, zmq_port_start ] use f77_zmq implicit none @@ -36,22 +34,19 @@ END_PROVIDER integer :: i do i=len(buffer),1,-1 if ( buffer(i:i) == ':') then - qp_run_address_tcp = trim(buffer(1:i-1)) + qp_run_address = trim(buffer(1:i-1)) read(buffer(i+1:), *) zmq_port_start exit endif enddo - qp_run_address_ipc = 'ipc:///tmp/qp_run' - qp_run_address = qp_run_address_ipc END_PROVIDER - BEGIN_PROVIDER [ character*(128), zmq_socket_pull_tcp_address ] -&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_pair_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ] -&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_tcp_address ] use f77_zmq implicit none BEGIN_DOC @@ -59,12 +54,12 @@ END_PROVIDER END_DOC character*(8), external :: zmq_port + zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address_tcp)//':'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_sub_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' ! /!\ Don't forget to change subroutine reset_zmq_addresses END_PROVIDER @@ -77,13 +72,12 @@ subroutine reset_zmq_addresses END_DOC character*(8), external :: zmq_port + zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address_tcp)//':'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_sub_address = trim(qp_run_address)//':'//zmq_port(1)//' ' - + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' end @@ -111,7 +105,6 @@ subroutine switch_qp_run_to_master exit endif enddo - qp_run_address_tcp = qp_run_address call reset_zmq_addresses end @@ -374,7 +367,7 @@ function new_zmq_sub_socket() stop 'Unable to subscribe new_zmq_sub_socket' endif - rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_address) + rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_tcp_address) if (rc /= 0) then stop 'Unable to connect new_zmq_sub_socket' endif From b7590f1bb3d85c47fbbf00b31c3f6cb8c70ab82b Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 24 Oct 2016 16:54:54 -0500 Subject: [PATCH 041/188] fix #169 --- doc/source/conf.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/source/conf.py b/doc/source/conf.py index c77267ea..e461323a 100644 --- a/doc/source/conf.py +++ b/doc/source/conf.py @@ -25,7 +25,7 @@ import sys, os # Add any Sphinx extension module names here, as strings. They can be extensions # coming with Sphinx (named 'sphinx.ext.*') or your custom ones. -extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.pngmath', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode'] +extensions = ['sphinx.ext.autodoc', 'sphinx.ext.doctest', 'sphinx.ext.todo', 'sphinx.ext.mathjax', 'sphinx.ext.viewcode'] # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] From f340c3eb993d8b7f7106dbb12255be2a112e8d31 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 25 Oct 2016 15:42:43 -0500 Subject: [PATCH 042/188] Try to fix the opam dependency for conf-gmp.1 --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 18a13949..c9990d79 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,6 +9,7 @@ sudo: false addons: apt: packages: + - libgmp3-dev - gfortran - gcc - liblapack-dev From e96446e305d20468df6c9968c3e16859f34f6fbc Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 25 Oct 2016 16:05:14 -0500 Subject: [PATCH 043/188] Add zlib in travis (Maybe solve cryptokit error) --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index c9990d79..99299662 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,6 +9,7 @@ sudo: false addons: apt: packages: + - zlib1g-dev - libgmp3-dev - gfortran - gcc From c78101882fe0d12a532e6713e21336e8b6124d08 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Oct 2016 23:42:32 +0200 Subject: [PATCH 044/188] Add zarith in ocaml install (missing dep. of cryptokit) --- install/scripts/install_ocaml.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index a7462b2e..913ae75d 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -5,7 +5,7 @@ QP_ROOT=$PWD cd - # Normal installation -PACKAGES="core cryptokit ocamlfind sexplib ZMQ" +PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ" #ppx_sexp_conv # Needed for ZeroMQ From 8802d988490bff8ffa656b1484d6526a343c65b1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Oct 2016 13:49:29 +0200 Subject: [PATCH 045/188] wrong dimensions in s2_out --- src/Davidson/diagonalization_hs2.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index a7bc2b95..d7ec11b6 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st), s2_out(N_st) + double precision, intent(out) :: energies(N_st), s2_out(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem From afc4111e24dc5f0578346b863fa0ebfee4fdf9a6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Oct 2016 17:10:49 +0200 Subject: [PATCH 046/188] Fixed "Unable to bind socket" --- configure | 5 ++++- src/ZMQ/utils.irp.f | 35 ++++++++++++++++++++++++++++------- 2 files changed, 32 insertions(+), 8 deletions(-) diff --git a/configure b/configure index 19016136..8cb02608 100755 --- a/configure +++ b/configure @@ -487,7 +487,6 @@ def create_ninja_and_rc(l_installed): l_rc = [ 'export QP_ROOT={0}'.format(QP_ROOT), - '#export QP_NIC=ib0 # Choose the correct network inuterface', 'export QP_EZFIO={0}'.format(path_ezfio.replace(QP_ROOT,"${QP_ROOT}")), 'export QP_PYTHON={0}'.format(":".join(l_python)), "", 'export IRPF90={0}'.format(path_irpf90.replace(QP_ROOT,"${QP_ROOT}")), @@ -498,6 +497,10 @@ def create_ninja_and_rc(l_installed): 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "", 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "", 'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true', + '', + '# Choose the correct network interface', + '# export QP_NIC=ib0', + '# export QP_NIC=eth0', "" ] diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index f2703ff8..444c33fe 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -257,15 +257,36 @@ function new_zmq_pull_socket() stop 'Unable to set ZMQ_RCVHWM on pull socket' endif - rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) - if (rc /= 0) then - print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address + integer :: icount + + icount = 10 + do while (icount > 0) + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address) + if (rc /= 0) then + icount = icount-1 + call sleep(3) + endif + enddo + + if (icount == 0) then + print *, 'Unable to bind new_zmq_pull_socket (inproc)', zmq_socket_pull_inproc_address stop endif - - rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_inproc_address) - if (rc /= 0) then - stop 'Unable to bind new_zmq_pull_socket (inproc)' + + + icount = 10 + do while (icount > 0) + rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) + if (rc /= 0) then + icount = icount-1 + call sleep(3) + endif + + enddo + + if (icount == 0) then + print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address + stop endif end From 08ac74cc2dfe8c7f91b36c6e6da2ecb8911a2808 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Oct 2016 18:18:46 +0200 Subject: [PATCH 047/188] Fixed binding bug --- src/ZMQ/utils.irp.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 444c33fe..b2b5b7b4 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -265,12 +265,14 @@ function new_zmq_pull_socket() if (rc /= 0) then icount = icount-1 call sleep(3) + else + exit endif enddo if (icount == 0) then print *, 'Unable to bind new_zmq_pull_socket (inproc)', zmq_socket_pull_inproc_address - stop + stop -1 endif @@ -280,13 +282,14 @@ function new_zmq_pull_socket() if (rc /= 0) then icount = icount-1 call sleep(3) + else + exit endif - enddo if (icount == 0) then print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address - stop + stop -1 endif end From 156a3f551bc859c232bb181e31d83d9cd4ce5ca7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Oct 2016 21:59:39 +0200 Subject: [PATCH 048/188] Accelerated integral access --- src/Integrals_Bielec/map_integrals.irp.f | 85 ++++++++++++++---------- 1 file changed, 51 insertions(+), 34 deletions(-) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index afc573aa..22fd48a6 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -120,15 +120,16 @@ end END_PROVIDER -BEGIN_PROVIDER [ double precision, ao_integrals_cache, (ao_integrals_cache_min:ao_integrals_cache_max,ao_integrals_cache_min:ao_integrals_cache_max,ao_integrals_cache_min:ao_integrals_cache_max,ao_integrals_cache_min:ao_integrals_cache_max) ] +BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ] implicit none BEGIN_DOC ! Cache of AO integrals for fast access END_DOC PROVIDE ao_bielec_integrals_in_map - integer :: i,j,k,l + integer :: i,j,k,l,ii integer(key_kind) :: idx - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx) + real(integral_kind) :: integral + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) do l=ao_integrals_cache_min,ao_integrals_cache_max do k=ao_integrals_cache_min,ao_integrals_cache_max do j=ao_integrals_cache_min,ao_integrals_cache_max @@ -136,7 +137,12 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (ao_integrals_cache_min:a !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,idx) !DIR$ FORCEINLINE - call map_get(ao_integrals_map,idx,ao_integrals_cache(i,j,k,l)) + call map_get(ao_integrals_map,idx,integral) + ii = l-ao_integrals_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_cache_min) + ao_integrals_cache(ii) = integral enddo enddo enddo @@ -155,30 +161,33 @@ double precision function get_ao_bielec_integral(i,j,k,l,map) integer, intent(in) :: i,j,k,l integer(key_kind) :: idx type(map_type), intent(inout) :: map + integer :: ii real(integral_kind) :: tmp - PROVIDE ao_bielec_integrals_in_map + PROVIDE ao_bielec_integrals_in_map ao_integrals_cache ao_integrals_cache_min !DIR$ FORCEINLINE if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then tmp = 0.d0 else if (ao_bielec_integral_schwartz(i,k)*ao_bielec_integral_schwartz(j,l) < ao_integrals_threshold) then tmp = 0.d0 else - if ( (i >= ao_integrals_cache_min) .and. & - (j >= ao_integrals_cache_min) .and. & - (k >= ao_integrals_cache_min) .and. & - (l >= ao_integrals_cache_min) .and. & - (i <= ao_integrals_cache_max) .and. & - (j <= ao_integrals_cache_max) .and. & - (k <= ao_integrals_cache_max) .and. & - (l <= ao_integrals_cache_max) ) then - tmp = ao_integrals_cache(i,j,k,l) - else + ii = l-ao_integrals_cache_min + ii = ior(ii, k-ao_integrals_cache_min) + ii = ior(ii, j-ao_integrals_cache_min) + ii = ior(ii, i-ao_integrals_cache_min) + if (iand(ii, -64) /= 0) then !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE call map_get(map,idx,tmp) + get_ao_bielec_integral = dble(tmp) + else + ii = l-ao_integrals_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_cache_min) + get_ao_bielec_integral = ao_integrals_cache(ii) endif endif - get_ao_bielec_integral = tmp end @@ -324,20 +333,22 @@ end ! Min and max values of the MOs for which the integrals are in the cache END_DOC mo_integrals_cache_min = max(1,elec_alpha_num - 31) - mo_integrals_cache_max = min(mo_tot_num,elec_alpha_num + 32) + mo_integrals_cache_max = min(mo_tot_num,mo_integrals_cache_min+63) END_PROVIDER -BEGIN_PROVIDER [ double precision, mo_integrals_cache, (mo_integrals_cache_min:mo_integrals_cache_max,mo_integrals_cache_min:mo_integrals_cache_max,mo_integrals_cache_min:mo_integrals_cache_max,mo_integrals_cache_min:mo_integrals_cache_max) ] +BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0:64*64*64*64) ] implicit none BEGIN_DOC ! Cache of MO integrals for fast access END_DOC PROVIDE mo_bielec_integrals_in_map integer :: i,j,k,l + integer :: ii integer(key_kind) :: idx + real(integral_kind) :: integral FREE ao_integrals_cache - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx) + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) do l=mo_integrals_cache_min,mo_integrals_cache_max do k=mo_integrals_cache_min,mo_integrals_cache_max do j=mo_integrals_cache_min,mo_integrals_cache_max @@ -345,7 +356,12 @@ BEGIN_PROVIDER [ double precision, mo_integrals_cache, (mo_integrals_cache_min:m !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,idx) !DIR$ FORCEINLINE - call map_get(mo_integrals_map,idx,mo_integrals_cache(i,j,k,l)) + call map_get(mo_integrals_map,idx,integral) + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + mo_integrals_cache(ii) = integral enddo enddo enddo @@ -362,24 +378,26 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) END_DOC integer, intent(in) :: i,j,k,l integer(key_kind) :: idx + integer :: ii type(map_type), intent(inout) :: map real(integral_kind) :: tmp PROVIDE mo_bielec_integrals_in_map mo_integrals_cache - if ( (i >= mo_integrals_cache_min) .and. & - (j >= mo_integrals_cache_min) .and. & - (k >= mo_integrals_cache_min) .and. & - (l >= mo_integrals_cache_min) .and. & - (i <= mo_integrals_cache_max) .and. & - (j <= mo_integrals_cache_max) .and. & - (k <= mo_integrals_cache_max) .and. & - (l <= mo_integrals_cache_max) ) then - get_mo_bielec_integral = mo_integrals_cache(i,j,k,l) - else + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then !DIR$ FORCEINLINE call bielec_integrals_index(i,j,k,l,idx) !DIR$ FORCEINLINE call map_get(map,idx,tmp) get_mo_bielec_integral = dble(tmp) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + get_mo_bielec_integral = mo_integrals_cache(ii) endif end @@ -390,16 +408,15 @@ double precision function get_mo_bielec_integral_schwartz(i,j,k,l,map) ! 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 + double precision, external :: get_mo_bielec_integral + PROVIDE mo_bielec_integrals_in_map mo_integrals_cache if (mo_bielec_integral_schwartz(i,k)*mo_bielec_integral_schwartz(j,l) > mo_integrals_threshold) then - double precision, external :: get_mo_bielec_integral !DIR$ FORCEINLINE get_mo_bielec_integral_schwartz = get_mo_bielec_integral(i,j,k,l,map) else - tmp = 0.d0 + get_mo_bielec_integral_schwartz = 0.d0 endif end From 3946c710feb8454d53f74ba8dc16390c2de01429 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Oct 2016 22:26:20 +0200 Subject: [PATCH 049/188] Accelerated mono-excitations (mipi miip) --- src/Determinants/slater_rules.irp.f | 131 +++------------------ src/Integrals_Bielec/map_integrals.irp.f | 1 + src/Integrals_Bielec/mo_bi_integrals.irp.f | 25 ++++ 3 files changed, 40 insertions(+), 117 deletions(-) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 67463088..7df6e79e 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -515,8 +515,6 @@ subroutine i_H_j(key_i,key_j,Nint,hij) 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) @@ -568,59 +566,27 @@ subroutine i_H_j(key_i,key_j,Nint,hij) 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, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - 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 + hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) enddo do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(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)) + hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) enddo else ! Mono beta m = exc(1,1,2) p = exc(1,2,2) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - 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(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)) + hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p) enddo do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) enddo endif @@ -651,8 +617,6 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem 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) @@ -704,59 +668,27 @@ subroutine i_H_j_phase_out(key_i,key_j,Nint,hij,phase,exc,degree) 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, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - 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 + hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) enddo do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif + hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) 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) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - 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(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)) + hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p) enddo do k = 1, elec_beta_num - hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) + hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) enddo endif @@ -787,8 +719,6 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) 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) @@ -842,59 +772,26 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) 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, elec_alpha_num - i = occ(k,1) - if (.not.has_mipi(i)) then - 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 + hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,1),m,p) enddo do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1)) - enddo - do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) + hdouble = hdouble + mo_bielec_integral_mipi(occ(k,2),m,p) enddo else ! Mono beta m = exc(1,1,2) p = exc(1,2,2) - do k = 1, elec_beta_num - i = occ(k,2) - if (.not.has_mipi(i)) then - 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(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, elec_alpha_num - hdouble = hdouble + mipi(occ(k,1)) + hdouble = hdouble + mo_bielec_integral_mipi(occ(k,1),m,p) enddo do k = 1, elec_beta_num - hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) + hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,2),m,p) enddo endif diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 22fd48a6..b41a3177 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -370,6 +370,7 @@ BEGIN_PROVIDER [ double precision, mo_integrals_cache, (0:64*64*64*64) ] END_PROVIDER + double precision function get_mo_bielec_integral(i,j,k,l,map) use map_module implicit none diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 0a468c24..e581b536 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -467,6 +467,31 @@ END_PROVIDER enddo enddo +END_PROVIDER + + BEGIN_PROVIDER [ double precision, mo_bielec_integral_mipi, (mo_tot_num_align,mo_tot_num,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_mipi_anti, (mo_tot_num_align,mo_tot_num,mo_tot_num) ] + implicit none + BEGIN_DOC + ! and - . Indices are (i,m,p) + END_DOC + + integer :: m,i,p + double precision :: get_mo_bielec_integral + + PROVIDE mo_bielec_integrals_in_map + + mo_bielec_integral_mipi = 0.d0 + mo_bielec_integral_mipi_anti = 0.d0 + do p=1,mo_tot_num + do m=1,mo_tot_num + do i=1,mo_tot_num + mo_bielec_integral_mipi(i,m,p) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + mo_bielec_integral_mipi_anti(i,m,p) = mo_bielec_integral_mipi(i,m,p) - get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + enddo + enddo + enddo + END_PROVIDER BEGIN_PROVIDER [ double precision, mo_bielec_integral_schwartz,(mo_tot_num,mo_tot_num) ] From a7466703eda5e881707e9470b4269943f0031db0 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 12:52:05 -0500 Subject: [PATCH 050/188] Bats dirty correction --- tests/run_tests.sh | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 4664ce82..3022d529 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -12,28 +12,24 @@ mrcepa0.bats " - export QP_PREFIX="timeout -s 9 300" export QP_TASK_DEBUG=1 - rm -rf work output - -for BATS_FILE in $LIST -do - echo - echo "-~-~-~-~-~-~" - echo - echo "Running tests for ${BATS_FILE%.bats}" - echo - BATS_FILE=bats/$BATS_FILE - if [[ "$1" == "-v" ]] - then +if [[ "$1" == "-v" ]] +then + for BATS_FILE in $LIST + do + echo + echo "-~-~-~-~-~-~" + echo + echo "Running tests for ${BATS_FILE%.bats}" + echo + BATS_FILE=bats/$BATS_FILE echo "Verbose mode" ./bats_to_sh.py $BATS_FILE | bash - else - bats $BATS_FILE - fi -done - + done +else + bats bats +fi From 203876a0d687e09aeee3815e0d94bd5fcf766b4c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 31 Oct 2016 19:44:30 +0100 Subject: [PATCH 051/188] Removed useless unbind --- src/ZMQ/utils.irp.f | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index b2b5b7b4..3177d3e3 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -426,7 +426,6 @@ subroutine end_zmq_pair_socket(zmq_socket_pair) integer :: rc character*(8), external :: zmq_port - rc = f77_zmq_unbind(zmq_socket_pair,zmq_socket_pair_inproc_address) rc = f77_zmq_close(zmq_socket_pair) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pair)' @@ -445,8 +444,6 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) integer :: rc character*(8), external :: zmq_port - rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) - rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) rc = f77_zmq_close(zmq_socket_pull) if (rc /= 0) then print *, 'f77_zmq_close(zmq_socket_pull)' From 707bd6fbbd57f28e4635da9e64209173ccea7758 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 14:08:00 -0500 Subject: [PATCH 052/188] Update run_tests.sh --- tests/run_tests.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 3022d529..558881b0 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -30,6 +30,7 @@ then ./bats_to_sh.py $BATS_FILE | bash done else - bats bats + cd bats + bats fi From 83c517a8e056057a364705fa9892f1d5ec9fe8cd Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 14:18:00 -0500 Subject: [PATCH 053/188] Update run_tests.sh --- tests/run_tests.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 558881b0..7cbab8b2 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -31,6 +31,6 @@ then done else cd bats - bats + bats . fi From 6ebfa85f0f1c8faf16b6914ded9204f048c35d3a Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 15:05:57 -0500 Subject: [PATCH 054/188] Update run_tests.sh --- tests/run_tests.sh | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 7cbab8b2..0f69a554 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -1,7 +1,6 @@ -#!/bin/bash +#!/bin/bash -e LIST=" - convert.bats hf.bats foboci.bats @@ -9,28 +8,29 @@ pseudo.bats fci.bats cassd.bats mrcepa0.bats - " + export QP_PREFIX="timeout -s 9 300" export QP_TASK_DEBUG=1 + rm -rf work output -if [[ "$1" == "-v" ]] -then - for BATS_FILE in $LIST - do - echo - echo "-~-~-~-~-~-~" - echo - echo "Running tests for ${BATS_FILE%.bats}" - echo - BATS_FILE=bats/$BATS_FILE - echo "Verbose mode" - ./bats_to_sh.py $BATS_FILE | bash - done -else - cd bats - bats . -fi + +for BATS_FILE in $LIST +do + echo + echo "-~-~-~-~-~-~" + echo + echo "Running tests for ${BATS_FILE%.bats}" + echo + BATS_FILE=bats/$BATS_FILE + if [[ "$1" == "-v" ]] + then + echo "Verbose mode" + ./bats_to_sh.py $BATS_FILE | bash + else + bats $BATS_FILE + fi +done From a3ed72d0d9b1f43ce41a7688a3f3a56d96597564 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 15:33:41 -0500 Subject: [PATCH 055/188] Update run_tests.sh 'Fix' #173 --- tests/run_tests.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 0f69a554..1254de3b 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -3,12 +3,12 @@ LIST=" convert.bats hf.bats -foboci.bats pseudo.bats fci.bats cassd.bats mrcepa0.bats " +#foboci.bats export QP_PREFIX="timeout -s 9 300" From 4994582619625c3a1ab6b493e745c28524091eb1 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Mon, 31 Oct 2016 16:09:52 -0500 Subject: [PATCH 056/188] Update README.md --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index bb63b691..eacecaf7 100644 --- a/README.md +++ b/README.md @@ -137,6 +137,10 @@ interface: ezfio #FAQ +### Opam error: cryptokit + +You need to install `gmp-dev`. + ### Error: ezfio_* is already defined. #### Why ? From 25b360a4097ad6fd6ac8a54b285c6f447040f6db Mon Sep 17 00:00:00 2001 From: TApplencourt Date: Tue, 1 Nov 2016 17:06:05 -0500 Subject: [PATCH 057/188] Update documetation... --- plugins/All_singles/.gitignore | 32 ++ plugins/All_singles/README.rst | 1 + plugins/All_singles/tree_dependency.png | 0 plugins/CAS_SD/.gitignore | 1 + plugins/CAS_SD/README.rst | 26 +- plugins/Full_CI/.gitignore | 2 +- plugins/Full_CI/README.rst | 138 +----- plugins/Full_CI_ZMQ/.gitignore | 34 ++ plugins/Full_CI_ZMQ/README.rst | 461 ++++++++++++++++++ plugins/Full_CI_ZMQ/tree_dependency.png | 0 plugins/Generators_full/README.rst | 6 +- .../Generators_restart/tree_dependency.png | 0 plugins/Hartree_Fock/README.rst | 10 +- plugins/MRCC_Utils/.gitignore | 1 + plugins/MRCC_Utils/README.rst | 336 +++++++++++-- plugins/Perturbation/README.rst | 58 +-- plugins/Psiref_CAS/.gitignore | 1 + plugins/Psiref_CAS/README.rst | 1 + plugins/Psiref_Utils/README.rst | 77 ++- plugins/Selectors_full/README.rst | 12 +- .../Selectors_no_sorted/tree_dependency.png | 0 plugins/mrcepa0/.gitignore | 36 ++ plugins/mrcepa0/README.rst | 196 ++++++++ plugins/mrcepa0/tree_dependency.png | 0 src/AO_Basis/README.rst | 2 +- src/Davidson/README.rst | 322 ++++++++++++ src/Davidson/tree_dependency.png | 0 src/Determinants/README.rst | 381 +++++---------- src/Electrons/README.rst | 2 +- src/Ezfio_files/README.rst | 16 +- src/Integrals_Bielec/README.rst | 130 +++-- src/Integrals_Monoelec/README.rst | 38 +- src/Nuclei/README.rst | 2 +- src/Utils/README.rst | 77 ++- src/ZMQ/README.rst | 70 ++- src/ZMQ/tree_dependency.png | 0 36 files changed, 1833 insertions(+), 636 deletions(-) create mode 100644 plugins/All_singles/.gitignore create mode 100644 plugins/All_singles/tree_dependency.png create mode 100644 plugins/Full_CI_ZMQ/.gitignore create mode 100644 plugins/Full_CI_ZMQ/README.rst create mode 100644 plugins/Full_CI_ZMQ/tree_dependency.png create mode 100644 plugins/Generators_restart/tree_dependency.png create mode 100644 plugins/Selectors_no_sorted/tree_dependency.png create mode 100644 plugins/mrcepa0/.gitignore create mode 100644 plugins/mrcepa0/tree_dependency.png create mode 100644 src/Davidson/README.rst create mode 100644 src/Davidson/tree_dependency.png create mode 100644 src/ZMQ/tree_dependency.png diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore new file mode 100644 index 00000000..cae0c971 --- /dev/null +++ b/plugins/All_singles/.gitignore @@ -0,0 +1,32 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Davidson +Determinants +Electrons +Ezfio_files +Generators_restart +Hartree_Fock +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +Makefile +Makefile.depend +Nuclei +Perturbation +Properties +Pseudo +Selectors_no_sorted +Utils +ZMQ +all_1h_1p +all_singles +ezfio_interface.irp.f +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/All_singles/README.rst b/plugins/All_singles/README.rst index d3888edc..8836ddd6 100644 --- a/plugins/All_singles/README.rst +++ b/plugins/All_singles/README.rst @@ -15,6 +15,7 @@ Needed Modules * `Properties `_ * `Selectors_no_sorted `_ * `Utils `_ +* `Davidson `_ Documentation ============= diff --git a/plugins/All_singles/tree_dependency.png b/plugins/All_singles/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/plugins/CAS_SD/.gitignore b/plugins/CAS_SD/.gitignore index 380d6cbf..57b1926f 100644 --- a/plugins/CAS_SD/.gitignore +++ b/plugins/CAS_SD/.gitignore @@ -3,6 +3,7 @@ .ninja_log AO_Basis Bitmask +Davidson Determinants Electrons Ezfio_files diff --git a/plugins/CAS_SD/README.rst b/plugins/CAS_SD/README.rst index 11f5d4cc..20ffa64f 100644 --- a/plugins/CAS_SD/README.rst +++ b/plugins/CAS_SD/README.rst @@ -107,6 +107,7 @@ Needed Modules * `Perturbation `_ * `Selectors_full `_ * `Generators_CAS `_ +* `Davidson `_ Documentation ============= @@ -193,31 +194,6 @@ h_apply_cas_s_selected_monoexc Assume N_int is already provided. -h_apply_cas_s_selected_no_skip - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -h_apply_cas_s_selected_no_skip_diexc - Undocumented - - -h_apply_cas_s_selected_no_skip_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_cas_s_selected_no_skip_diexcp - Undocumented - - -h_apply_cas_s_selected_no_skip_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - h_apply_cas_sd Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore index 674f56da..70d637ea 100644 --- a/plugins/Full_CI/.gitignore +++ b/plugins/Full_CI/.gitignore @@ -3,6 +3,7 @@ .ninja_log AO_Basis Bitmask +Davidson Determinants Electrons Ezfio_files @@ -28,7 +29,6 @@ full_ci full_ci_no_skip irpf90.make irpf90_entities -micro_pt2 tags target_pt2 var_pt2_ratio \ No newline at end of file diff --git a/plugins/Full_CI/README.rst b/plugins/Full_CI/README.rst index 750db44c..77a0bd64 100644 --- a/plugins/Full_CI/README.rst +++ b/plugins/Full_CI/README.rst @@ -16,6 +16,7 @@ Needed Modules * `Perturbation `_ * `Selectors_full `_ * `Generators_full `_ +* `Davidson `_ Documentation ============= @@ -77,6 +78,31 @@ h_apply_fci_monoexc Assume N_int is already provided. +h_apply_fci_no_selection + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_no_selection_diexc + Undocumented + + +h_apply_fci_no_selection_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_no_selection_diexcp + Undocumented + + +h_apply_fci_no_selection_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + h_apply_fci_no_skip Calls H_apply on the HF determinant and selects all connected single and double excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. @@ -144,118 +170,6 @@ h_apply_fci_pt2_slave_tcp Computes a buffer over the network -h_apply_pt2_mono_delta_rho - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -h_apply_pt2_mono_delta_rho_diexc - Undocumented - - -h_apply_pt2_mono_delta_rho_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_pt2_mono_delta_rho_diexcp - Undocumented - - -h_apply_pt2_mono_delta_rho_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_pt2_mono_di_delta_rho - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -h_apply_pt2_mono_di_delta_rho_diexc - Undocumented - - -h_apply_pt2_mono_di_delta_rho_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_pt2_mono_di_delta_rho_diexcp - Undocumented - - -h_apply_pt2_mono_di_delta_rho_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_select_mono_delta_rho - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -h_apply_select_mono_delta_rho_diexc - Undocumented - - -h_apply_select_mono_delta_rho_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_select_mono_delta_rho_diexcp - Undocumented - - -h_apply_select_mono_delta_rho_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_select_mono_di_delta_rho - Calls H_apply on the HF determinant and selects all connected single and double - excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. - - -h_apply_select_mono_di_delta_rho_diexc - Undocumented - - -h_apply_select_mono_di_delta_rho_diexcorg - Generate all double excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -h_apply_select_mono_di_delta_rho_diexcp - Undocumented - - -h_apply_select_mono_di_delta_rho_monoexc - Generate all single excitations of key_in using the bit masks of holes and - particles. - Assume N_int is already provided. - - -`micro_pt2 `_ - Helper program to compute the PT2 in distributed mode. - - -`provide_everything `_ - Undocumented - - -`run_wf `_ - Undocumented - - `var_pt2_ratio_run `_ Undocumented diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore new file mode 100644 index 00000000..a996a508 --- /dev/null +++ b/plugins/Full_CI_ZMQ/.gitignore @@ -0,0 +1,34 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Davidson +Determinants +Electrons +Ezfio_files +Full_CI +Generators_full +Hartree_Fock +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +Makefile +Makefile.depend +Nuclei +Perturbation +Properties +Pseudo +Selectors_full +Utils +ZMQ +ezfio_interface.irp.f +fci_zmq +irpf90.make +irpf90_entities +selection_davidson_slave +selection_slave +tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/README.rst b/plugins/Full_CI_ZMQ/README.rst new file mode 100644 index 00000000..d1677a7d --- /dev/null +++ b/plugins/Full_CI_ZMQ/README.rst @@ -0,0 +1,461 @@ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Perturbation `_ +* `Selectors_full `_ +* `Generators_full `_ +* `ZMQ `_ +* `Full_CI `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`add_task_to_taskserver `_ + Get a task from the task server + + +`add_to_selection_buffer `_ + Undocumented + + +`assert `_ + Undocumented + + +`connect_to_taskserver `_ + Connect to the task server and obtain the worker ID + + +`create_selection_buffer `_ + Undocumented + + +`disconnect_from_taskserver `_ + Disconnect from the task server + + +`end_parallel_job `_ + End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + + +`end_zmq_pair_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_pull_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_push_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_sub_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_to_qp_run_socket `_ + Terminate the socket from the application to qp_run + + +`fci_zmq `_ + Undocumented + + +`fill_buffer_double `_ + Undocumented + + +`fill_buffer_single `_ + Undocumented + + +`full_ci `_ + Undocumented + + +`get_d0 `_ + Undocumented + + +`get_d1 `_ + Undocumented + + +`get_d2 `_ + Undocumented + + +`get_m0 `_ + Undocumented + + +`get_m1 `_ + Undocumented + + +`get_m2 `_ + Undocumented + + +`get_mask_phase `_ + Undocumented + + +`get_phase_bi `_ + Undocumented + + +`get_task_from_taskserver `_ + Get a task from the task server + + +h_apply_fci + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_diexc + Undocumented + + +h_apply_fci_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_diexcp + Undocumented + + +h_apply_fci_mono + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_mono_diexc + Undocumented + + +h_apply_fci_mono_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_mono_diexcp + Undocumented + + +h_apply_fci_mono_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_no_selection + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_no_selection_diexc + Undocumented + + +h_apply_fci_no_selection_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_no_selection_diexcp + Undocumented + + +h_apply_fci_no_selection_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_no_skip + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_no_skip_diexc + Undocumented + + +h_apply_fci_no_skip_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_no_skip_diexcp + Undocumented + + +h_apply_fci_no_skip_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_pt2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_pt2_collector + Collects results from the selection in an array of generators + + +h_apply_fci_pt2_diexc + Undocumented + + +h_apply_fci_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_pt2_diexcp + Undocumented + + +h_apply_fci_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_fci_pt2_slave + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_fci_pt2_slave_inproc + Computes a buffer using threads + + +h_apply_fci_pt2_slave_tcp + Computes a buffer over the network + + +`integral8 `_ + Undocumented + + +`new_parallel_job `_ + Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' + + +`new_zmq_pair_socket `_ + Socket on which the collector and the main communicate + + +`new_zmq_pull_socket `_ + Socket on which the results are sent. If thread is 1, use inproc + + +`new_zmq_push_socket `_ + Socket on which the results are sent. If thread is 1, use inproc + + +`new_zmq_sub_socket `_ + Socket to read the state published by the Task server + + +`new_zmq_to_qp_run_socket `_ + Socket on which the qp_run process replies + + +`past_d1 `_ + Undocumented + + +`past_d2 `_ + Undocumented + + +`provide_everything `_ + Undocumented + + +`psi_phasemask `_ + Undocumented + + +`pull_selection_results `_ + Undocumented + + +`push_selection_results `_ + Undocumented + + +`qp_run_address `_ + Address of the qp_run socket + Example : tcp://130.120.229.139:12345 + + +`reset_zmq_addresses `_ + Socket which pulls the results (2) + + +`run_selection_slave `_ + Undocumented + + +`run_wf `_ + Undocumented + + +`select_connected `_ + Undocumented + + +`select_doubles `_ + Undocumented + + +`select_singles `_ + Select determinants connected to i_det by H + + +`selection_collector `_ + Undocumented + + +`selection_slave `_ + Helper program to compute the PT2 in distributed mode. + + +`selection_slave_inproc `_ + Undocumented + + +`selection_slave_tcp `_ + Undocumented + + +`sort_selection_buffer `_ + Undocumented + + +`splash_p `_ + Undocumented + + +`splash_pq `_ + Undocumented + + +`spot_hasbeen `_ + Undocumented + + +`spot_isinwf `_ + Undocumented + + +`switch_qp_run_to_master `_ + Address of the master qp_run socket + Example : tcp://130.120.229.139:12345 + + +`task_done_to_taskserver `_ + Get a task from the task server + + +`update_energy `_ + Update energy when it is received from ZMQ + + +`var_pt2_ratio_run `_ + Undocumented + + +`wait_for_next_state `_ + Undocumented + + +`wait_for_state `_ + Wait for the ZMQ state to be ready + + +`wait_for_states `_ + Wait for the ZMQ state to be ready + + +`zmq_context `_ + Context for the ZeroMQ library + + +`zmq_delete_task `_ + When a task is done, it has to be removed from the list of tasks on the qp_run + queue. This guarantees that the results have been received in the pull. + + +`zmq_port `_ + Return the value of the ZMQ port from the corresponding integer + + +`zmq_port_start `_ + Address of the qp_run socket + Example : tcp://130.120.229.139:12345 + + +`zmq_selection `_ + Undocumented + + +`zmq_set_running `_ + Set the job to Running in QP-run + + +`zmq_socket_pair_inproc_address `_ + Socket which pulls the results (2) + + +`zmq_socket_pull_inproc_address `_ + Socket which pulls the results (2) + + +`zmq_socket_pull_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_socket_push_inproc_address `_ + Socket which pulls the results (2) + + +`zmq_socket_push_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_socket_sub_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_state `_ + Threads executing work through the ZeroMQ interface + diff --git a/plugins/Full_CI_ZMQ/tree_dependency.png b/plugins/Full_CI_ZMQ/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/plugins/Generators_full/README.rst b/plugins/Generators_full/README.rst index c30193a2..d1fc68ec 100644 --- a/plugins/Generators_full/README.rst +++ b/plugins/Generators_full/README.rst @@ -33,7 +33,7 @@ Documentation .. by the `update_README.py` script. -`degree_max_generators `_ +`degree_max_generators `_ Max degree of excitation (respect to HF) of the generators @@ -52,10 +52,10 @@ Documentation Hartree-Fock determinant -`select_max `_ +`select_max `_ Memo to skip useless selectors -`size_select_max `_ +`size_select_max `_ Size of the select_max array diff --git a/plugins/Generators_restart/tree_dependency.png b/plugins/Generators_restart/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/plugins/Hartree_Fock/README.rst b/plugins/Hartree_Fock/README.rst index 77521b94..2e329163 100644 --- a/plugins/Hartree_Fock/README.rst +++ b/plugins/Hartree_Fock/README.rst @@ -67,11 +67,11 @@ Documentation Alpha Fock matrix in AO basis set -`fock_matrix_alpha_mo `_ +`fock_matrix_alpha_mo `_ Fock matrix on the MO basis -`fock_matrix_ao `_ +`fock_matrix_ao `_ Fock matrix in AO basis set @@ -79,7 +79,7 @@ Documentation Alpha Fock matrix in AO basis set -`fock_matrix_beta_mo `_ +`fock_matrix_beta_mo `_ Fock matrix on the MO basis @@ -115,7 +115,7 @@ Documentation .br -`fock_mo_to_ao `_ +`fock_mo_to_ao `_ Undocumented @@ -135,7 +135,7 @@ Documentation S^-1 Beta density matrix in the AO basis x S^-1 -`hf_energy `_ +`hf_energy `_ Hartree-Fock energy diff --git a/plugins/MRCC_Utils/.gitignore b/plugins/MRCC_Utils/.gitignore index 4c65ce66..7a0dd517 100644 --- a/plugins/MRCC_Utils/.gitignore +++ b/plugins/MRCC_Utils/.gitignore @@ -3,6 +3,7 @@ .ninja_log AO_Basis Bitmask +Davidson Determinants Electrons Ezfio_files diff --git a/plugins/MRCC_Utils/README.rst b/plugins/MRCC_Utils/README.rst index 39b5684c..ae041734 100644 --- a/plugins/MRCC_Utils/README.rst +++ b/plugins/MRCC_Utils/README.rst @@ -36,11 +36,19 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_hole_local `_ + Undocumented + + +`apply_particle_local `_ + Undocumented + + +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -63,23 +71,23 @@ Documentation Binomial coefficients -`ci_eigenvectors_dressed `_ - Eigenvectors/values of the CI matrix +`ci_eigenvectors_dressed `_ + Eigenvectors/values of the dressed CI matrix -`ci_eigenvectors_s2_dressed `_ - Eigenvectors/values of the CI matrix +`ci_eigenvectors_s2_dressed `_ + Eigenvectors/values of the dressed CI matrix -`ci_electronic_energy_dressed `_ - Eigenvectors/values of the CI matrix +`ci_electronic_energy_dressed `_ + Eigenvectors/values of the dressed CI matrix -`ci_energy_dressed `_ +`ci_energy_dressed `_ N_states lowest eigenvalues of the dressed CI matrix -`davidson_diag_hjj_mrcc `_ +`davidson_diag_hjj_mrcc `_ Davidson diagonalization with specific diagonal elements of the H matrix .br H_jj : specific diagonal H matrix elements to diagonalize de Davidson @@ -95,12 +103,39 @@ Documentation .br N_st : Number of eigenstates .br + N_st_diag : Number of states in which H is diagonalized + .br iunit : Unit for the I/O .br Initial guess vectors are not necessarily orthonormal -`davidson_diag_mrcc `_ +`davidson_diag_hjj_sjj_mrcc `_ + Davidson diagonalization with specific diagonal elements of the H matrix + .br + H_jj : specific diagonal H matrix elements to diagonalize de Davidson + .br + S2_jj : specific diagonal S^2 matrix elements + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + N_st_diag : Number of states in which H is diagonalized. Assumed > sze + .br + iunit : Unit for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`davidson_diag_mrcc `_ Davidson diagonalization. .br dets_in : bitmasks corresponding to determinants @@ -119,19 +154,38 @@ Documentation Initial guess vectors are not necessarily orthonormal -`dble_fact `_ +`davidson_diag_mrcc_hs2 `_ + Davidson diagonalization. + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit number for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -139,19 +193,23 @@ Documentation Undocumented -`delta_ii `_ - Dressing matrix in N_det basis +`dec_exc `_ + Undocumented -`delta_ij `_ - Dressing matrix in N_det basis - - -`diagonalize_ci_dressed `_ +`diagonalize_ci_dressed `_ Replace the coefficients of the CI states by the coefficients of the eigenstates of the CI matrix +`dij `_ + Undocumented + + +`dij_unique `_ + Undocumented + + `dset_order `_ array A has already been sorted, and iorder has contains the new order of elements of A. This subroutine changes the order of x to match the new order of A. @@ -170,10 +228,26 @@ Documentation contains the new order of the elements. +`dtranspose `_ + Transpose input matrix A into output matrix B + + `erf0 `_ Undocumented +`exc_inf `_ + Undocumented + + +`exccmp `_ + Undocumented + + +`exceq `_ + Undocumented + + `f_integral `_ function that calculates the following integral \int_{\-infty}^{+\infty} x^n \exp(-p x^2) dx @@ -183,19 +257,19 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B -`find_triples_and_quadruples `_ +`find_triples_and_quadruples `_ Undocumented -`find_triples_and_quadruples_micro `_ +`find_triples_and_quadruples_micro `_ Undocumented @@ -221,7 +295,15 @@ Documentation Undocumented -`get_pseudo_inverse `_ +`get_dij `_ + Undocumented + + +`get_dij_index `_ + Undocumented + + +`get_pseudo_inverse `_ Find C = A^-1 @@ -306,11 +388,63 @@ h_apply_mrcc_pt2_monoexc Assume N_int is already provided. -`h_matrix_dressed `_ +h_apply_mrcepa_pt2 + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_mrcepa_pt2_collector + Collects results from the selection in an array of generators + + +h_apply_mrcepa_pt2_diexc + Undocumented + + +h_apply_mrcepa_pt2_diexcorg + Generate all double excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_mrcepa_pt2_diexcp + Undocumented + + +h_apply_mrcepa_pt2_monoexc + Generate all single excitations of key_in using the bit masks of holes and + particles. + Assume N_int is already provided. + + +h_apply_mrcepa_pt2_slave + Calls H_apply on the HF determinant and selects all connected single and double + excitations (of the same symmetry). Auto-generated by the ``generate_h_apply`` script. + + +h_apply_mrcepa_pt2_slave_inproc + Computes a buffer using threads + + +h_apply_mrcepa_pt2_slave_tcp + Computes a buffer over the network + + +`h_matrix_dressed `_ Dressed H with Delta_ij -`h_u_0_mrcc `_ +`h_s2_u_0_mrcc_nstates `_ + Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + .br + n : number of determinants + .br + H_jj : array of + .br + S2_jj : array of + + +`h_u_0_mrcc_nstates `_ Computes v_0 = H|u_0> .br n : number of determinants @@ -392,7 +526,15 @@ h_apply_mrcc_pt2_monoexc Hermite polynomial -`hij_mrcc `_ +`hh_exists `_ + Undocumented + + +`hh_shortcut `_ + Undocumented + + +`hij_mrcc `_ < ref | H | Non-ref > matrix @@ -523,7 +665,7 @@ h_apply_mrcc_pt2_monoexc to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -541,6 +683,10 @@ h_apply_mrcc_pt2_monoexc iradix should be -1 in input. +`is_generable `_ + Undocumented + + `iset_order `_ array A has already been sorted, and iorder has contains the new order of elements of A. This subroutine changes the order of x to match the new order of A. @@ -559,15 +705,19 @@ h_apply_mrcc_pt2_monoexc contains the new order of the elements. -`lambda_mrcc `_ +`lambda_mrcc `_ cm/ or perturbative 1/Delta_E(m) -`lambda_mrcc_pt2 `_ +`lambda_mrcc_kept `_ cm/ or perturbative 1/Delta_E(m) -`lapack_diag `_ +`lambda_mrcc_pt2 `_ + cm/ or perturbative 1/Delta_E(m) + + +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -578,7 +728,7 @@ h_apply_mrcc_pt2_monoexc .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -589,7 +739,7 @@ h_apply_mrcc_pt2_monoexc .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -600,7 +750,7 @@ h_apply_mrcc_pt2_monoexc .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -611,19 +761,27 @@ h_apply_mrcc_pt2_monoexc .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case +`map_load_from_disk `_ + Undocumented + + +`map_save_to_disk `_ + Undocumented + + `mrcc_dress `_ Undocumented -`mrcc_iterations `_ +`mrmode `_ Undocumented @@ -632,12 +790,24 @@ h_apply_mrcc_pt2_monoexc D(t) =! D(t) +( B(t)*C(t)) -`normalize `_ +`n_ex_exists `_ + Undocumented + + +`n_hh_exists `_ + Undocumented + + +`n_pp_exists `_ + Undocumented + + +`normalize `_ Normalizes vector u u is expected to be aligned in memory. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -659,7 +829,7 @@ h_apply_mrcc_pt2_monoexc .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -677,6 +847,19 @@ h_apply_mrcc_pt2_monoexc .br +`ortho_qr `_ + Orthogonalization using Q.R factorization + .br + A : matrix to orthogonalize + .br + LDA : leftmost dimension of A + .br + n : Number of rows of A + .br + m : Number of columns of A + .br + + `overlap_a_b_c `_ Undocumented @@ -707,6 +890,10 @@ h_apply_mrcc_pt2_monoexc Undocumented +`pp_exists `_ + Undocumented + + `progress_active `_ Current status for displaying progress bars. Global variable. @@ -727,6 +914,14 @@ h_apply_mrcc_pt2_monoexc Current status for displaying progress bars. Global variable. +`psi_non_ref_sorted `_ + Undocumented + + +`psi_non_ref_sorted_idx `_ + Undocumented + + `psi_ref_lock `_ Locks on ref determinants to fill delta_ij @@ -735,6 +930,10 @@ h_apply_mrcc_pt2_monoexc Recenter two polynomials +`rho_mrcc `_ + Undocumented + + `rint `_ .. math:: .br @@ -762,10 +961,6 @@ h_apply_mrcc_pt2_monoexc Undocumented -`run_mrcc `_ - Undocumented - - `run_progress `_ Display a progress bar with documentation of what is happening @@ -774,7 +969,15 @@ h_apply_mrcc_pt2_monoexc Undocumented -`set_generators_bitmasks_as_holes_and_particles `_ +`searchdet `_ + Undocumented + + +`searchexc `_ + Undocumented + + +`set_generators_bitmasks_as_holes_and_particles `_ Undocumented @@ -790,7 +993,7 @@ h_apply_mrcc_pt2_monoexc to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -800,6 +1003,14 @@ h_apply_mrcc_pt2_monoexc contains the new order of the elements. +`sort_det `_ + Undocumented + + +`sort_exc `_ + Undocumented + + `start_progress `_ Starts the progress bar @@ -817,18 +1028,37 @@ h_apply_mrcc_pt2_monoexc .br -`u_dot_u `_ +`tamise_exc `_ + Uncodumented : TODO + + +`transpose `_ + Transpose input matrix A into output matrix B + + +`u_0_h_u_0_mrcc_nstates `_ + Computes e_0 = / + .br + n : number of determinants + .br + + +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`wall_time `_ +`unsortedsearchdet `_ + Undocumented + + +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/plugins/Perturbation/README.rst b/plugins/Perturbation/README.rst index 810a58e1..1657e079 100644 --- a/plugins/Perturbation/README.rst +++ b/plugins/Perturbation/README.rst @@ -88,6 +88,7 @@ Needed Modules * `Properties `_ * `Hartree_Fock `_ +* `Davidson `_ Documentation ============= @@ -107,13 +108,13 @@ Documentation Undocumented -perturb_buffer_by_mono_delta_rho_one_point - Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply +perturb_buffer_by_mono_dipole_moment_z + Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. -perturb_buffer_by_mono_dipole_moment_z - Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply +perturb_buffer_by_mono_dummy + Applly pertubration ``dummy`` to the buffer of determinants generated in the H_apply routine. @@ -152,13 +153,13 @@ perturb_buffer_by_mono_moller_plesset routine. -perturb_buffer_delta_rho_one_point - Applly pertubration ``delta_rho_one_point`` to the buffer of determinants generated in the H_apply +perturb_buffer_dipole_moment_z + Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply routine. -perturb_buffer_dipole_moment_z - Applly pertubration ``dipole_moment_z`` to the buffer of determinants generated in the H_apply +perturb_buffer_dummy + Applly pertubration ``dummy`` to the buffer of determinants generated in the H_apply routine. @@ -197,27 +198,6 @@ perturb_buffer_moller_plesset routine. -`pt2_delta_rho_one_point `_ - compute the perturbatibe contribution to the Integrated Spin density at z = z_one point of one determinant - .br - for the various n_st states, at various level of theory. - .br - c_pert(i) = /( - ) - .br - e_2_pert(i) = c_pert(i) * - .br - H_pert_diag(i) = c_pert(i)^2 * - .br - To get the contribution of the first order : - .br - = sum(over i) e_2_pert(i) - .br - To get the contribution of the diagonal elements of the second order : - .br - [ + + sum(over i) H_pert_diag(i) ] / [1. + sum(over i) c_pert(i) **2] - .br - - `pt2_dipole_moment_z `_ compute the perturbatibe contribution to the dipole moment of one determinant .br @@ -239,7 +219,11 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet `_ +`pt2_dummy `_ + Dummy perturbation to add all connected determinants. + + +`pt2_epstein_nesbet `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states. @@ -250,7 +234,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_2x2 `_ +`pt2_epstein_nesbet_2x2 `_ compute the Epstein-Nesbet 2x2 diagonalization coefficient and energetic contribution .br for the various N_st states. @@ -261,7 +245,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_sc2 `_ +`pt2_epstein_nesbet_sc2 `_ compute the standard Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, but with the CISD_SC2 energies and coefficients @@ -272,7 +256,7 @@ perturb_buffer_moller_plesset .br -`pt2_epstein_nesbet_sc2_no_projected `_ +`pt2_epstein_nesbet_sc2_no_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -296,7 +280,7 @@ perturb_buffer_moller_plesset H_pert_diag = c_pert -`pt2_epstein_nesbet_sc2_projected `_ +`pt2_epstein_nesbet_sc2_projected `_ compute the Epstein-Nesbet perturbative first order coefficient and second order energetic contribution .br for the various N_st states, @@ -331,12 +315,12 @@ perturb_buffer_moller_plesset .br -`pt2_max `_ +`pt2_max `_ The selection process stops when the largest PT2 (for all the state) is lower than pt2_max in absolute value -`pt2_moller_plesset `_ +`pt2_moller_plesset `_ compute the standard Moller-Plesset perturbative first order coefficient and second order energetic contribution .br for the various n_st states. @@ -368,7 +352,7 @@ perturb_buffer_moller_plesset Threshold to select determinants. Set by selection routines. -`var_pt2_ratio `_ +`var_pt2_ratio `_ The selection process stops when the energy ratio variational/(variational+PT2) is equal to var_pt2_ratio diff --git a/plugins/Psiref_CAS/.gitignore b/plugins/Psiref_CAS/.gitignore index 69ebdc69..d79d94d9 100644 --- a/plugins/Psiref_CAS/.gitignore +++ b/plugins/Psiref_CAS/.gitignore @@ -3,6 +3,7 @@ .ninja_log AO_Basis Bitmask +Davidson Determinants Electrons Ezfio_files diff --git a/plugins/Psiref_CAS/README.rst b/plugins/Psiref_CAS/README.rst index 5d511317..a217e36c 100644 --- a/plugins/Psiref_CAS/README.rst +++ b/plugins/Psiref_CAS/README.rst @@ -58,6 +58,7 @@ Needed Modules .. image:: tree_dependency.png * `Psiref_Utils `_ +* `Davidson `_ Documentation ============= diff --git a/plugins/Psiref_Utils/README.rst b/plugins/Psiref_Utils/README.rst index 35232d23..2ceb6b98 100644 --- a/plugins/Psiref_Utils/README.rst +++ b/plugins/Psiref_Utils/README.rst @@ -154,11 +154,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -181,19 +181,19 @@ Documentation Binomial coefficients -`dble_fact `_ +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -219,6 +219,10 @@ Documentation contains the new order of the elements. +`dtranspose `_ + Transpose input matrix A into output matrix B + + `erf0 `_ Undocumented @@ -236,11 +240,11 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -270,7 +274,7 @@ Documentation Returns the index of the determinant in the ``psi_ref_sorted_bit`` array -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -531,7 +535,7 @@ Documentation to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -571,7 +575,7 @@ Documentation contains the new order of the elements. -`lapack_diag `_ +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -582,7 +586,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -593,7 +597,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -604,7 +608,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -615,14 +619,22 @@ Documentation .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case +`map_load_from_disk `_ + Undocumented + + +`map_save_to_disk `_ + Undocumented + + `multiply_poly `_ Multiply two polynomials D(t) =! D(t) +( B(t)*C(t)) @@ -635,12 +647,12 @@ Documentation idx_non_ref_rev gives the reverse. -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -662,7 +674,7 @@ Documentation .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -680,6 +692,19 @@ Documentation .br +`ortho_qr `_ + Orthogonalization using Q.R factorization + .br + A : matrix to orthogonalize + .br + LDA : leftmost dimension of A + .br + n : Number of rows of A + .br + m : Number of columns of A + .br + + `overlap_a_b_c `_ Undocumented @@ -860,7 +885,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -887,18 +912,22 @@ Documentation .br -`u_dot_u `_ +`transpose `_ + Transpose input matrix A into output matrix B + + +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`wall_time `_ +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/plugins/Selectors_full/README.rst b/plugins/Selectors_full/README.rst index 393e9421..fc264fc1 100644 --- a/plugins/Selectors_full/README.rst +++ b/plugins/Selectors_full/README.rst @@ -161,15 +161,19 @@ Documentation n_double_selectors = number of double excitations in the selectors determinants -`psi_selectors `_ +`psi_selectors `_ Determinants on which we apply for perturbation. -`psi_selectors_coef `_ +`psi_selectors_coef `_ Determinants on which we apply for perturbation. -`psi_selectors_diag_h_mat `_ +`psi_selectors_coef_transp `_ + Transposed psi_selectors + + +`psi_selectors_diag_h_mat `_ Diagonal elements of the H matrix for each selectors @@ -177,7 +181,7 @@ Documentation Undocumented -`zmq_get_psi `_ +`zmq_get_psi `_ Get the wave function from the qp_run scheduler diff --git a/plugins/Selectors_no_sorted/tree_dependency.png b/plugins/Selectors_no_sorted/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore new file mode 100644 index 00000000..7d9ee55d --- /dev/null +++ b/plugins/mrcepa0/.gitignore @@ -0,0 +1,36 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Davidson +Determinants +Electrons +Ezfio_files +Generators_full +Hartree_Fock +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +MRCC_Utils +Makefile +Makefile.depend +Nuclei +Perturbation +Properties +Pseudo +Psiref_CAS +Psiref_Utils +Selectors_full +Utils +ZMQ +ezfio_interface.irp.f +irpf90.make +irpf90_entities +mrcc +mrcepa0 +mrsc2 +tags \ No newline at end of file diff --git a/plugins/mrcepa0/README.rst b/plugins/mrcepa0/README.rst index 997d005e..9e66ca0d 100644 --- a/plugins/mrcepa0/README.rst +++ b/plugins/mrcepa0/README.rst @@ -6,7 +6,203 @@ Needed Modules ============== .. Do not edit this section It was auto-generated .. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Perturbation `_ +* `Selectors_full `_ +* `Generators_full `_ +* `Psiref_CAS `_ +* `MRCC_Utils `_ +* `ZMQ `_ + Documentation ============= .. Do not edit this section It was auto-generated .. by the `update_README.py` script. + + +`active_sorb `_ + Undocumented + + +`blokmwen `_ + Undocumented + + +`cepa0_shortcut `_ + Undocumented + + +`child_num `_ + Undocumented + + +`delta_cas `_ + Undocumented + + +`delta_ii `_ + Undocumented + + +`delta_ii_mrcc `_ + Undocumented + + +`delta_ii_old `_ + Undocumented + + +`delta_ij `_ + Undocumented + + +`delta_ij_mrcc `_ + Undocumented + + +`delta_ij_old `_ + Undocumented + + +`delta_mrcepa0_ii `_ + Undocumented + + +`delta_mrcepa0_ij `_ + Undocumented + + +`delta_sub_ii `_ + Undocumented + + +`delta_sub_ij `_ + Undocumented + + +`det_cepa0 `_ + Undocumented + + +`det_cepa0_active `_ + Undocumented + + +`det_cepa0_idx `_ + Undocumented + + +`det_ref_active `_ + Undocumented + + +`filter_tq `_ + Undocumented + + +`filter_tq_micro `_ + Undocumented + + +`gethp `_ + Undocumented + + +`h_ `_ + Undocumented + + +`hp `_ + Undocumented + + +`isincassd `_ + Undocumented + + +`lambda_type `_ + lambda type + + +`linked `_ + Undocumented + + +`mrcc_part_dress `_ + Undocumented + + +`mrcepa0 `_ + Undocumented + + +`mrsc2 `_ + Undocumented + + +`mrsc2_dressing_collector `_ + Collects results from the AO integral calculation + + +`mrsc2_dressing_slave `_ + Task for parallel MR-SC2 + + +`mrsc2_dressing_slave_inproc `_ + Task for parallel MR-SC2 + + +`mrsc2_dressing_slave_tcp `_ + Task for parallel MR-SC2 + + +`mrsc2sub `_ + Undocumented + + +`n_it_max_dressed_ci `_ + Maximum number of dressed CI iterations + + +`nlink `_ + Undocumented + + +`print_cas_coefs `_ + Undocumented + + +`pull_mrsc2_results `_ + Push integrals in the push socket + + +`push_mrsc2_results `_ + Push integrals in the push socket + + +`run `_ + Undocumented + + +`run_pt2 `_ + Undocumented + + +`run_pt2_old `_ + Undocumented + + +`searchance `_ + Undocumented + + +`set_det_bit `_ + Undocumented + + +`thresh_dressed_ci `_ + Threshold on the convergence of the dressed CI energy + diff --git a/plugins/mrcepa0/tree_dependency.png b/plugins/mrcepa0/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/src/AO_Basis/README.rst b/src/AO_Basis/README.rst index ae9acdf0..d67a3a63 100644 --- a/src/AO_Basis/README.rst +++ b/src/AO_Basis/README.rst @@ -133,7 +133,7 @@ Documentation :math:`\int \chi_i(r) \chi_j(r) dr)` -`ao_overlap_abs `_ +`ao_overlap_abs `_ Overlap between absolute value of atomic basis functions: :math:`\int |\chi_i(r)| |\chi_j(r)| dr)` diff --git a/src/Davidson/README.rst b/src/Davidson/README.rst new file mode 100644 index 00000000..15e9b46a --- /dev/null +++ b/src/Davidson/README.rst @@ -0,0 +1,322 @@ +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Determinants `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`ci_eigenvectors `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_s2 `_ + Eigenvectors/values of the CI matrix + + +`ci_eigenvectors_s2_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_electronic_energy `_ + Eigenvectors/values of the CI matrix + + +`ci_electronic_energy_mono `_ + Eigenvectors/values of the CI matrix + + +`ci_energy `_ + N_states lowest eigenvalues of the CI matrix + + +`dav_det `_ + Temporary arrays for parallel davidson + .br + Touched in davidson_miniserver_get + + +`dav_size `_ + Size of the arrays for Davidson + .br + Touched in davidson_miniserver_get + + +`dav_ut `_ + Temporary arrays for parallel davidson + .br + Touched in davidson_miniserver_get + + +`davidson_add_task `_ + Undocumented + + +`davidson_collect `_ + Undocumented + + +`davidson_collector `_ + Undocumented + + +`davidson_converged `_ + True if the Davidson algorithm is converged + + +`davidson_criterion `_ + Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] + + +`davidson_diag `_ + Davidson diagonalization. + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit number for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`davidson_diag_hjj `_ + Davidson diagonalization with specific diagonal elements of the H matrix + .br + H_jj : specific diagonal H matrix elements to diagonalize de Davidson + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + N_st_diag : Number of states in which H is diagonalized + .br + iunit : Unit for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`davidson_diag_hjj_sjj `_ + Davidson diagonalization with specific diagonal elements of the H matrix + .br + H_jj : specific diagonal H matrix elements to diagonalize de Davidson + .br + S2_jj : specific diagonal S^2 matrix elements + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + N_st_diag : Number of states in which H is diagonalized. Assumed > sze + .br + iunit : Unit for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`davidson_diag_hs2 `_ + Davidson diagonalization. + .br + dets_in : bitmasks corresponding to determinants + .br + u_in : guess coefficients on the various states. Overwritten + on exit + .br + dim_in : leftmost dimension of u_in + .br + sze : Number of determinants + .br + N_st : Number of eigenstates + .br + iunit : Unit number for the I/O + .br + Initial guess vectors are not necessarily orthonormal + + +`davidson_init `_ + Undocumented + + +`davidson_iter_max `_ + Max number of Davidson iterations + + +`davidson_miniserver_end `_ + Undocumented + + +`davidson_miniserver_get `_ + Undocumented + + +`davidson_miniserver_run `_ + Undocumented + + +`davidson_process `_ + Undocumented + + +`davidson_pull_results `_ + Undocumented + + +`davidson_push_results `_ + Undocumented + + +`davidson_run `_ + Undocumented + + +`davidson_run_slave `_ + Undocumented + + +`davidson_slave `_ + Undocumented + + +`davidson_slave_inproc `_ + Undocumented + + +`davidson_slave_tcp `_ + Undocumented + + +`davidson_slave_work `_ + Undocumented + + +`davidson_sze_max `_ + Max number of Davidson sizes + + +`det_inf `_ + Ordering function for determinants + + +`diagonalize_ci `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + + +`diagonalize_ci_mono `_ + Replace the coefficients of the CI states by the coefficients of the + eigenstates of the CI matrix + + +`first_guess `_ + Select all the determinants with the lowest energy as a starting point. + + +`h_s2_u_0_nstates `_ + Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + .br + n : number of determinants + .br + H_jj : array of + .br + S2_jj : array of + + +`h_u_0_nstates `_ + Computes v_0 = H|u_0> + .br + n : number of determinants + .br + H_jj : array of + + +`max_blocksize `_ + Undocumented + + +`n_states_diag `_ + n_states_diag + + +`provide_everything `_ + Undocumented + + +`psi_energy `_ + Energy of the current wave function + + +`shortcut_ `_ + Undocumented + + +`sort_dets_ab `_ + Uncodumented : TODO + + +`sort_dets_ab_v `_ + Uncodumented : TODO + + +`sort_dets_ba_v `_ + Uncodumented : TODO + + +`sort_idx_ `_ + Undocumented + + +`sorted_ `_ + Undocumented + + +`tamiser `_ + Uncodumented : TODO + + +`threshold_davidson `_ + Thresholds of Davidson's algorithm + + +`u_0_h_u_0 `_ + Computes e_0 = / + .br + n : number of determinants + .br + + +`version_ `_ + Undocumented + diff --git a/src/Davidson/tree_dependency.png b/src/Davidson/tree_dependency.png new file mode 100644 index 00000000..e69de29b diff --git a/src/Determinants/README.rst b/src/Determinants/README.rst index c6685945..9ad0f1a3 100644 --- a/src/Determinants/README.rst +++ b/src/Determinants/README.rst @@ -15,23 +15,31 @@ Documentation .. by the `update_README.py` script. -`a_operator `_ +`a_operator `_ Needed for diag_H_mat_elem -`abs_psi_coef_max `_ +`abs_psi_coef_max `_ Max and min values of the coefficients -`abs_psi_coef_min `_ +`abs_psi_coef_min `_ Max and min values of the coefficients -`ac_operator `_ +`ac_operator `_ Needed for diag_H_mat_elem -`apply_excitation `_ +`apply_excitation `_ + Undocumented + + +`apply_hole `_ + Undocumented + + +`apply_holes `_ Undocumented @@ -39,16 +47,24 @@ Documentation Undocumented +`apply_particle `_ + Undocumented + + +`apply_particles `_ + Undocumented + + `bi_elec_ref_bitmask_energy `_ Energy of the reference bitmask used in Slater rules -`bitstring_to_list_ab `_ +`bitstring_to_list_ab `_ Gives the inidices(+1) of the bits set to 1 in the bit string For alpha/beta determinants -`bitstring_to_list_ab_old `_ +`bitstring_to_list_ab_old `_ Gives the inidices(+1) of the bits set to 1 in the bit string For alpha/beta determinants @@ -58,72 +74,15 @@ Documentation determinant. F_00 is = E0. -`ci_eigenvectors `_ - Eigenvectors/values of the CI matrix - - -`ci_eigenvectors_mono `_ - Eigenvectors/values of the CI matrix - - -`ci_eigenvectors_s2 `_ - Eigenvectors/values of the CI matrix - - -`ci_eigenvectors_s2_mono `_ - Eigenvectors/values of the CI matrix - - -`ci_electronic_energy `_ - Eigenvectors/values of the CI matrix - - -`ci_electronic_energy_mono `_ - Eigenvectors/values of the CI matrix - - -`ci_energy `_ - N_states lowest eigenvalues of the CI matrix - - -`ci_sc2_eigenvectors `_ - Eigenvectors/values of the CI matrix - - -`ci_sc2_electronic_energy `_ - Eigenvectors/values of the CI matrix - - -`ci_sc2_energy `_ - N_states_diag lowest eigenvalues of the CI matrix - - `cisd `_ Undocumented -`cisd_sc2 `_ - CISD+SC2 method :: take off all the disconnected terms of a CISD (selected or not) - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - Initial guess vectors are not necessarily orthonormal - - -`connected_to_ref `_ +`connected_to_ref `_ Undocumented -`connected_to_ref_by_mono `_ +`connected_to_ref_by_mono `_ Undocumented @@ -136,11 +95,11 @@ Documentation Undocumented -`create_minilist `_ +`create_minilist `_ Undocumented -`create_minilist_find_previous `_ +`create_minilist_find_previous `_ Undocumented @@ -149,62 +108,6 @@ Documentation of alpha and beta determinants -`davidson_converged `_ - True if the Davidson algorithm is converged - - -`davidson_criterion `_ - Can be : [ energy | residual | both | wall_time | cpu_time | iterations ] - - -`davidson_diag `_ - Davidson diagonalization. - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit number for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`davidson_diag_hjj `_ - Davidson diagonalization with specific diagonal elements of the H matrix - .br - H_jj : specific diagonal H matrix elements to diagonalize de Davidson - .br - dets_in : bitmasks corresponding to determinants - .br - u_in : guess coefficients on the various states. Overwritten - on exit - .br - dim_in : leftmost dimension of u_in - .br - sze : Number of determinants - .br - N_st : Number of eigenstates - .br - iunit : Unit for the I/O - .br - Initial guess vectors are not necessarily orthonormal - - -`davidson_iter_max `_ - Max number of Davidson iterations - - -`davidson_sze_max `_ - Max number of Davidson sizes - - `decode_exc `_ Decodes the exc arrays returned by get_excitation. h1,h2 : Holes @@ -213,6 +116,14 @@ Documentation degree : Degree of excitation +`decode_exc_int2 `_ + Decodes the exc arrays returned by get_excitation. + h1,h2 : Holes + p1,p2 : Particles + s1,s2 : Spins (1:alpha, 2:beta) + degree : Degree of excitation + + `det_alpha_norm `_ Norm of the alpha and beta spin determinants in the wave function: .br @@ -225,15 +136,11 @@ Documentation ||Da||_i \sum_j C_{ij}**2 -`det_coef `_ +`det_coef `_ det_coef -`det_inf `_ - Undocumented - - -`det_occ `_ +`det_occ `_ det_occ @@ -245,44 +152,29 @@ Documentation Transform a determinant to an occupation pattern -`diag_algorithm `_ +`detcmp `_ + Undocumented + + +`deteq `_ + Undocumented + + +`diag_algorithm `_ Diagonalization algorithm (Davidson or Lapack) -`diag_h_elements_sc2 `_ - Eigenvectors/values of the CI matrix - - -`diag_h_mat_elem `_ +`diag_h_mat_elem `_ Computes -`diag_h_mat_elem_fock `_ +`diag_h_mat_elem_fock `_ Computes when i is at most a double excitation from a reference. -`diagonalize_ci `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - - -`diagonalize_ci_mono `_ - Replace the coefficients of the CI states by the coefficients of the - eigenstates of the CI matrix - - -`diagonalize_ci_sc2 `_ - Replace the coefficients of the CI states_diag by the coefficients of the - eigenstates of the CI matrix - - -`diagonalize_s2 `_ - Diagonalize the S^2 operator within the n_states_diag states required. Notice : the vectors are sorted by increasing S^2 values. - - -`diagonalize_s2_betweenstates `_ - You enter with nstates vectors in psi_coefs_inout that may be coupled by S^2 +`diagonalize_s2_betweenstates `_ + You enter with nstates vectors in u_0 that may be coupled by S^2 The subroutine diagonalize the S^2 operator in the basis of these states. The vectors that you obtain in output are no more coupled by S^2, which does not necessary mean that they are eigenfunction of S^2. @@ -349,7 +241,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_i_h_psi0 `_ +`filter_connected_i_h_psi0 `_ returns the array idx which contains the index of the .br determinants in the array key1 that interact @@ -359,7 +251,7 @@ Documentation idx(0) is the number of determinants that interact with key1 -`filter_connected_i_h_psi0_sc2 `_ +`filter_connected_i_h_psi0_sc2 `_ standard filter_connected_i_H_psi but returns in addition .br the array of the index of the non connected determinants to key1 @@ -371,18 +263,22 @@ Documentation to repeat the excitations -`first_guess `_ - Select all the determinants with the lowest energy as a starting point. +`flip_generators `_ + Undocumented `generate_all_alpha_beta_det_products `_ Create a wave function from all possible alpha x beta determinants -`get_double_excitation `_ +`get_double_excitation `_ Returns the two excitation operators between two doubly excited determinants and the phase +`get_double_excitation_phase `_ + Undocumented + + `get_excitation `_ Returns the excitation operators between two determinants and the phase @@ -391,7 +287,7 @@ Documentation Returns the excitation degree between two determinants -`get_excitation_degree_vector `_ +`get_excitation_degree_vector `_ Applies get_excitation_degree to an array of determinants @@ -407,27 +303,23 @@ Documentation Returns the index of the determinant in the ``psi_det_sorted_bit`` array -`get_mono_excitation `_ +`get_mono_excitation `_ Returns the excitation operator between two singly excited determinants and the phase -`get_occ_from_key `_ +`get_occ_from_key `_ Returns a list of occupation numbers from a bitstring +`get_phase `_ + Returns the phase between key1 and key2 + + `get_s2 `_ Returns -`get_s2_u0 `_ - Undocumented - - -`get_s2_u0_old `_ - Undocumented - - -`get_uj_s2_ui `_ +`get_uj_s2_ui `_ returns the matrix elements of S^2 "s2(i,j)" between the "nstates" states psi_coefs_tmp(:,i) and psi_coefs_tmp(:,j) @@ -458,27 +350,19 @@ Documentation Undocumented -`h_u_0 `_ - Computes v_0 = H|u_0> - .br - n : number of determinants - .br - H_jj : array of - - -`i_h_j `_ +`i_h_j `_ Returns where i and j are determinants -`i_h_j_phase_out `_ +`i_h_j_phase_out `_ Returns where i and j are determinants -`i_h_j_verbose `_ +`i_h_j_verbose `_ Returns where i and j are determinants -`i_h_psi `_ +`i_h_psi `_ Computes = \sum_J c_J . .br Uses filter_connected_i_H_psi0 to get all the |J> to which |i> @@ -487,14 +371,14 @@ Documentation minilists -`i_h_psi_minilist `_ +`i_h_psi_minilist `_ Computes = \sum_J c_J . .br 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. -`i_h_psi_sc2 `_ +`i_h_psi_sc2 `_ for the various Nstate .br returns in addition @@ -508,7 +392,7 @@ Documentation to repeat the excitations -`i_h_psi_sc2_verbose `_ +`i_h_psi_sc2_verbose `_ for the various Nstate .br returns in addition @@ -522,10 +406,17 @@ Documentation to repeat the excitations -`i_h_psi_sec_ord `_ +`i_h_psi_sec_ord `_ for the various Nstates +`i_s2_psi_minilist `_ + Computes = \sum_J c_J . + .br + 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. + + `idx_cas `_ CAS wave function, defined from the application of the CAS bitmask on the determinants. idx_cas gives the indice of the CAS determinant in psi_det. @@ -537,11 +428,15 @@ Documentation idx_non_cas gives the indice of the determinant in psi_det. -`is_connected_to `_ +`is_connected_to `_ Undocumented -`is_connected_to_by_mono `_ +`is_connected_to_by_mono `_ + Undocumented + + +`is_generable_cassd `_ Undocumented @@ -557,7 +452,7 @@ Documentation Undocumented -`max_degree_exc `_ +`max_degree_exc `_ Maximum degree of excitation in the wf @@ -573,7 +468,7 @@ Documentation Undocumented -`n_det `_ +`n_det `_ Number of determinants in the wave function @@ -598,7 +493,7 @@ Documentation Maximum number of determinants diagonalized by Jacobi -`n_det_max_property `_ +`n_det_max_property `_ Max number of determinants in the wave function when you select for a given property @@ -630,10 +525,6 @@ Documentation Number of states to consider -`n_states_diag `_ - Number of states to consider for the diagonalization - - `neutral_no_hund_in_couple `_ n_couples is the number of couples of orbitals to be checked couples(i,1) = first orbital of the ith couple @@ -696,15 +587,15 @@ Documentation rho(alpha) - rho(beta) -`only_single_double_dm `_ +`only_single_double_dm `_ If true, The One body DM is calculated with ignoring the Double<->Doubles extra diag elements -`psi_average_norm_contrib `_ +`psi_average_norm_contrib `_ Contribution of determinants to the state-averaged density -`psi_average_norm_contrib_sorted `_ +`psi_average_norm_contrib_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) @@ -756,7 +647,7 @@ Documentation function. -`psi_coef `_ +`psi_coef `_ The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file is empty @@ -765,26 +656,26 @@ Documentation Undocumented -`psi_coef_max `_ +`psi_coef_max `_ Max and min values of the coefficients -`psi_coef_min `_ +`psi_coef_min `_ Max and min values of the coefficients -`psi_coef_sorted `_ +`psi_coef_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_coef_sorted_bit `_ +`psi_coef_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave function. -`psi_det `_ +`psi_det `_ The wave function determinants. Initialized with Hartree-Fock if the EZFIO file is empty @@ -805,15 +696,15 @@ Documentation Unique beta determinants -`psi_det_size `_ +`psi_det_size `_ Size of the psi_det/psi_coef arrays -`psi_det_sorted `_ +`psi_det_sorted `_ Wave function sorted by determinants contribution to the norm (state-averaged) -`psi_det_sorted_bit `_ +`psi_det_sorted_bit `_ Determinants on which we apply for perturbation. They are sorted by determinants interpreted as integers. Useful to accelerate the search of a random determinant in the wave @@ -860,7 +751,7 @@ Documentation Undocumented -`read_dets `_ +`read_dets `_ Reads the determinants from the EZFIO file @@ -885,11 +776,25 @@ Documentation be set before calling this function. -`s2_eig `_ +`s2_eig `_ Force the wave function to be an eigenfunction of S^2 -`s2_values `_ +`s2_u_0 `_ + Computes v_0 = S^2|u_0> + .br + n : number of determinants + .br + + +`s2_u_0_nstates `_ + Computes v_0 = S^2|u_0> + .br + n : number of determinants + .br + + +`s2_values `_ array of the averaged values of the S^2 operator on the various states @@ -913,23 +818,23 @@ Documentation Save natural orbitals, obtained by diagonalization of the one-body density matrix in the MO basis -`save_ref_determinant `_ +`save_ref_determinant `_ Undocumented -`save_wavefunction `_ +`save_wavefunction `_ Save the wave function into the EZFIO file -`save_wavefunction_general `_ +`save_wavefunction_general `_ Save the wave function into the EZFIO file -`save_wavefunction_specified `_ +`save_wavefunction_specified `_ Save the wave function into the EZFIO file -`save_wavefunction_unsorted `_ +`save_wavefunction_unsorted `_ Save the wave function into the EZFIO file @@ -947,49 +852,25 @@ Documentation for a given couple of hole/particle excitations i. -`sort_dets_ab `_ - Uncodumented : TODO - - -`sort_dets_ab_v `_ - Uncodumented : TODO - - -`sort_dets_ba_v `_ - Uncodumented : TODO - - -`sort_dets_by_det_search_key `_ +`sort_dets_by_det_search_key `_ Determinants are sorted are sorted according to their det_search_key. Useful to accelerate the search of a random determinant in the wave function. `spin_det_search_key `_ - Return an integer*8 corresponding to a determinant index for searching + Return an integer(8) corresponding to a determinant index for searching `state_average_weight `_ Weights in the state-average calculation of the density matrix -`tamiser `_ - Uncodumented : TODO - - -`target_energy `_ +`target_energy `_ Energy that should be obtained when truncating the wave function (optional) -`threshold_convergence_sc2 `_ - convergence of the correlation energy of SC2 iterations - - -`threshold_davidson `_ - Thresholds of Davidson's algorithm - - -`threshold_generators `_ +`threshold_generators `_ Thresholds on generators (fraction of the norm) @@ -997,8 +878,8 @@ Documentation Thresholds on selectors (fraction of the norm) -`u0_h_u_0 `_ - Computes e_0 = / +`u_0_s2_u_0 `_ + Computes e_0 = / .br n : number of determinants .br diff --git a/src/Electrons/README.rst b/src/Electrons/README.rst index d1c342b5..484617bb 100644 --- a/src/Electrons/README.rst +++ b/src/Electrons/README.rst @@ -44,7 +44,7 @@ Documentation .. by the `update_README.py` script. -`elec_alpha_num `_ +`elec_alpha_num `_ Numbers of electrons alpha ("up") diff --git a/src/Ezfio_files/README.rst b/src/Ezfio_files/README.rst index 6b494339..ad87e7f5 100644 --- a/src/Ezfio_files/README.rst +++ b/src/Ezfio_files/README.rst @@ -219,6 +219,10 @@ output_cas_sd Initial CPU and wall times when printing in the output files +output_davidson + Output file for Davidson + + output_determinants Output file for Determinants @@ -235,6 +239,10 @@ output_full_ci Output file for Full_CI +output_full_ci_zmq + Output file for Full_CI_ZMQ + + output_generators_cas Output file for Generators_CAS @@ -267,14 +275,14 @@ output_moguess Output file for MOGuess -output_mrcc_cassd - Output file for MRCC_CASSD - - output_mrcc_utils Output file for MRCC_Utils +output_mrcepa0 + Output file for mrcepa0 + + output_nuclei Output file for Nuclei diff --git a/src/Integrals_Bielec/README.rst b/src/Integrals_Bielec/README.rst index 98fbbb92..f6644db4 100644 --- a/src/Integrals_Bielec/README.rst +++ b/src/Integrals_Bielec/README.rst @@ -45,7 +45,7 @@ Documentation .. by the `update_README.py` script. -`add_integrals_to_map `_ +`add_integrals_to_map `_ Adds integrals to tha MO map according to some bitmask @@ -54,7 +54,7 @@ Documentation i(r1) j(r1) 1/r12 k(r2) l(r2) -`ao_bielec_integral_schwartz `_ +`ao_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -68,7 +68,7 @@ Documentation i(r1) j(r2) 1/r12 k(r1) l(r2) -`ao_bielec_integrals_in_map_collector `_ +`ao_bielec_integrals_in_map_collector `_ Collects results from the AO integral calculation @@ -84,11 +84,23 @@ Documentation Computes a buffer of integrals. i is the ID of the current thread. +`ao_integrals_cache `_ + Cache of AO integrals for fast access + + +`ao_integrals_cache_max `_ + Min and max values of the AOs for which the integrals are in the cache + + +`ao_integrals_cache_min `_ + Min and max values of the AOs for which the integrals are in the cache + + `ao_integrals_map `_ AO integrals -`ao_integrals_threshold `_ +`ao_integrals_threshold `_ If || < ao_integrals_threshold then is zero @@ -108,11 +120,11 @@ Documentation Undocumented -`clear_ao_map `_ +`clear_ao_map `_ Frees the memory of the AO map -`clear_mo_map `_ +`clear_mo_map `_ Frees the memory of the MO map @@ -120,15 +132,15 @@ Documentation Compute AO 1/r12 integrals for all i and fixed j,k,l -`compute_ao_integrals_jl `_ +`compute_ao_integrals_jl `_ Parallel client for AO integrals -`disk_access_ao_integrals `_ +`disk_access_ao_integrals `_ Read/Write AO integrals from/to disk [ Write | Read | None ] -`disk_access_mo_integrals `_ +`disk_access_mo_integrals `_ Read/Write MO integrals from/to disk [ Write | Read | None ] @@ -136,15 +148,15 @@ Documentation Compute integrals on the fly -`dump_ao_integrals `_ +`dump_ao_integrals `_ Save to disk the $ao integrals -`dump_mo_integrals `_ +`dump_mo_integrals `_ Save to disk the $ao integrals -`eri `_ +`eri `_ ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) @@ -166,148 +178,156 @@ Documentation t_w(i,2,k) = t(i) -`general_primitive_integral `_ +`general_primitive_integral `_ Computes the integral where p,q,r,s are Gaussian primitives -`get_ao_bielec_integral `_ +`get_ao_bielec_integral `_ Gets one AO bi-electronic integral from the AO map -`get_ao_bielec_integrals `_ +`get_ao_bielec_integrals `_ Gets multiple AO bi-electronic integral from the AO map . All i are retrieved for j,k,l fixed. -`get_ao_bielec_integrals_non_zero `_ +`get_ao_bielec_integrals_non_zero `_ Gets multiple AO bi-electronic integral from the AO map . All non-zero i are retrieved for j,k,l fixed. -`get_ao_map_size `_ +`get_ao_map_size `_ Returns the number of elements in the AO map -`get_mo_bielec_integral `_ +`get_mo_bielec_integral `_ Returns one integral in the MO basis -`get_mo_bielec_integral_schwartz `_ +`get_mo_bielec_integral_schwartz `_ Returns one integral in the MO basis -`get_mo_bielec_integrals `_ +`get_mo_bielec_integrals `_ Returns multiple integrals in the MO basis, all i for j,k,l fixed. -`get_mo_bielec_integrals_ij `_ +`get_mo_bielec_integrals_ij `_ Returns multiple integrals in the MO basis, all i(1)j(2) 1/r12 k(1)l(2) i, j for k,l fixed. -`get_mo_map_size `_ +`get_mo_map_size `_ Return the number of elements in the MO map -`give_polynom_mult_center_x `_ +`give_polynom_mult_center_x `_ subroutine that returns the explicit polynom in term of the "t" variable of the following polynomw : I_x1(a_x, d_x,p,q) * I_x1(a_y, d_y,p,q) * I_x1(a_z, d_z,p,q) -`i_x1_new `_ +`i_x1_new `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult `_ +`i_x1_pol_mult `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a1 `_ +`i_x1_pol_mult_a1 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_a2 `_ +`i_x1_pol_mult_a2 `_ recursive function involved in the bielectronic integral -`i_x1_pol_mult_recurs `_ +`i_x1_pol_mult_recurs `_ recursive function involved in the bielectronic integral -`i_x2_new `_ +`i_x2_new `_ recursive function involved in the bielectronic integral -`i_x2_pol_mult `_ +`i_x2_pol_mult `_ recursive function involved in the bielectronic integral -`insert_into_ao_integrals_map `_ +`insert_into_ao_integrals_map `_ Create new entry into AO map -`insert_into_mo_integrals_map `_ +`insert_into_mo_integrals_map `_ Create new entry into MO map, or accumulate in an existing entry -`integrale_new `_ +`integrale_new `_ calculate the integral of the polynom :: I_x1(a_x+b_x, c_x+d_x,p,q) * I_x1(a_y+b_y, c_y+d_y,p,q) * I_x1(a_z+b_z, c_z+d_z,p,q) between ( 0 ; 1) -`load_ao_integrals `_ +`load_ao_integrals `_ Read from disk the $ao integrals -`load_mo_integrals `_ +`load_mo_integrals `_ Read from disk the $ao integrals -`mo_bielec_integral `_ +`mo_bielec_integral `_ Returns one integral in the MO basis -`mo_bielec_integral_jj `_ +`mo_bielec_integral_jj `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_anti `_ +`mo_bielec_integral_jj_anti `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_anti_from_ao `_ +`mo_bielec_integral_jj_anti_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_exchange `_ +`mo_bielec_integral_jj_exchange `_ mo_bielec_integral_jj(i,j) = J_ij mo_bielec_integral_jj_exchange(i,j) = K_ij mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_exchange_from_ao `_ +`mo_bielec_integral_jj_exchange_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_jj_from_ao `_ +`mo_bielec_integral_jj_from_ao `_ mo_bielec_integral_jj_from_ao(i,j) = J_ij mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij -`mo_bielec_integral_schwartz `_ +`mo_bielec_integral_mipi `_ + and - . Indices are (i,m,p) + + +`mo_bielec_integral_mipi_anti `_ + and - . Indices are (i,m,p) + + +`mo_bielec_integral_schwartz `_ Needed to compute Schwartz inequalities @@ -319,11 +339,23 @@ Documentation Computes an unique index for i,j,k,l integrals -`mo_integrals_map `_ +`mo_integrals_cache `_ + Cache of MO integrals for fast access + + +`mo_integrals_cache_max `_ + Min and max values of the MOs for which the integrals are in the cache + + +`mo_integrals_cache_min `_ + Min and max values of the MOs for which the integrals are in the cache + + +`mo_integrals_map `_ MO integrals -`mo_integrals_threshold `_ +`mo_integrals_threshold `_ If || < ao_integrals_threshold then is zero @@ -331,20 +363,16 @@ Documentation Aligned n_pt_max_integrals -`n_pt_sup `_ +`n_pt_sup `_ Returns the upper boundary of the degree of the polynomial involved in the bielctronic integral : Ix(a_x,b_x,c_x,d_x) * Iy(a_y,b_y,c_y,d_y) * Iz(a_z,b_z,c_z,d_z) -`provide_all_mo_integrals `_ +`provide_all_mo_integrals `_ Undocumented -`pull_integrals `_ - How the collector pulls the computed integrals - - `push_integrals `_ Push integrals in the push socket diff --git a/src/Integrals_Monoelec/README.rst b/src/Integrals_Monoelec/README.rst index d92cea0a..7e926fd5 100644 --- a/src/Integrals_Monoelec/README.rst +++ b/src/Integrals_Monoelec/README.rst @@ -102,7 +102,7 @@ Documentation interaction nuclear electron -`ao_nucl_elec_integral_per_atom `_ +`ao_nucl_elec_integral_per_atom `_ ao_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom @@ -115,7 +115,7 @@ Documentation Local pseudo-potential -`ao_pseudo_integral_non_local `_ +`ao_pseudo_integral_non_local `_ Local pseudo-potential @@ -153,19 +153,19 @@ Documentation Undocumented -`give_polynom_mult_center_mono_elec `_ +`give_polynom_mult_center_mono_elec `_ Undocumented -`i_x1_pol_mult_mono_elec `_ +`i_x1_pol_mult_mono_elec `_ Undocumented -`i_x2_pol_mult_mono_elec `_ +`i_x2_pol_mult_mono_elec `_ Undocumented -`int_gaus_pol `_ +`int_gaus_pol `_ Undocumented @@ -200,7 +200,7 @@ Documentation interaction nuclear electron on the MO basis -`mo_nucl_elec_integral_per_atom `_ +`mo_nucl_elec_integral_per_atom `_ mo_nucl_elec_integral_per_atom(i,j,k) = - where Rk is the geometry of the kth atom @@ -227,7 +227,7 @@ Documentation array of the integrals of MO_i * z^2 MO_j -`nai_pol_mult `_ +`nai_pol_mult `_ Undocumented @@ -259,27 +259,27 @@ Documentation Undocumented -`pseudo_dz_k_transp `_ +`pseudo_dz_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_dz_kl_transp `_ +`pseudo_dz_kl_transp `_ Transposed arrays for pseudopotentials -`pseudo_n_k_transp `_ +`pseudo_n_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_n_kl_transp `_ +`pseudo_n_kl_transp `_ Transposed arrays for pseudopotentials -`pseudo_v_k_transp `_ +`pseudo_v_k_transp `_ Transposed arrays for pseudopotentials -`pseudo_v_kl_transp `_ +`pseudo_v_kl_transp `_ Transposed arrays for pseudopotentials @@ -299,23 +299,23 @@ Documentation Undocumented -`v_e_n `_ +`v_e_n `_ Undocumented -`v_phi `_ +`v_phi `_ Undocumented -`v_r `_ +`v_r `_ Undocumented -`v_theta `_ +`v_theta `_ Undocumented -`wallis `_ +`wallis `_ Undocumented diff --git a/src/Nuclei/README.rst b/src/Nuclei/README.rst index bf7e6f52..356b8e9e 100644 --- a/src/Nuclei/README.rst +++ b/src/Nuclei/README.rst @@ -38,7 +38,7 @@ Documentation Array of the name of element, sorted by nuclear charge (integer) -`nucl_charge `_ +`nucl_charge `_ Nuclear charges diff --git a/src/Utils/README.rst b/src/Utils/README.rst index 03ec80f5..902a5250 100644 --- a/src/Utils/README.rst +++ b/src/Utils/README.rst @@ -28,11 +28,11 @@ Documentation Compute 1st dimension such that it is aligned for vectorization. -`apply_rotation `_ +`apply_rotation `_ Apply the rotation found by find_rotation -`approx_dble `_ +`approx_dble `_ Undocumented @@ -55,19 +55,19 @@ Documentation Binomial coefficients -`dble_fact `_ +`dble_fact `_ Undocumented -`dble_fact_even `_ +`dble_fact_even `_ n!! -`dble_fact_odd `_ +`dble_fact_odd `_ n!! -`dble_logfact `_ +`dble_logfact `_ n!! @@ -93,6 +93,10 @@ Documentation contains the new order of the elements. +`dtranspose `_ + Transpose input matrix A into output matrix B + + `erf0 `_ Undocumented @@ -106,11 +110,11 @@ Documentation n! -`fact_inv `_ +`fact_inv `_ 1/n! -`find_rotation `_ +`find_rotation `_ Find A.C = B @@ -136,7 +140,7 @@ Documentation Undocumented -`get_pseudo_inverse `_ +`get_pseudo_inverse `_ Find C = A^-1 @@ -372,7 +376,7 @@ Documentation to be in integer*8 format -`inv_int `_ +`inv_int `_ 1/i @@ -408,7 +412,7 @@ Documentation contains the new order of the elements. -`lapack_diag `_ +`lapack_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -419,7 +423,7 @@ Documentation .br -`lapack_diag_s2 `_ +`lapack_diag_s2 `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -430,7 +434,7 @@ Documentation .br -`lapack_diagd `_ +`lapack_diagd `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -441,7 +445,7 @@ Documentation .br -`lapack_partial_diag `_ +`lapack_partial_diag `_ Diagonalize matrix H .br H is untouched between input and ouptut @@ -452,25 +456,33 @@ Documentation .br -`logfact `_ +`logfact `_ n! -`lowercase `_ +`lowercase `_ Transform to lower case +`map_load_from_disk `_ + Undocumented + + +`map_save_to_disk `_ + Undocumented + + `multiply_poly `_ Multiply two polynomials D(t) =! D(t) +( B(t)*C(t)) -`normalize `_ +`normalize `_ Normalizes vector u u is expected to be aligned in memory. -`nproc `_ +`nproc `_ Number of current OpenMP threads @@ -492,7 +504,7 @@ Documentation .br -`ortho_lowdin `_ +`ortho_lowdin `_ Compute C_new=C_old.S^-1/2 orthogonalization. .br overlap : overlap matrix @@ -510,6 +522,19 @@ Documentation .br +`ortho_qr `_ + Orthogonalization using Q.R factorization + .br + A : matrix to orthogonalize + .br + LDA : leftmost dimension of A + .br + n : Number of rows of A + .br + m : Number of columns of A + .br + + `overlap_a_b_c `_ Undocumented @@ -607,7 +632,7 @@ Documentation to be in integer*8 format -`set_zero_extra_diag `_ +`set_zero_extra_diag `_ Undocumented @@ -634,18 +659,22 @@ Documentation .br -`u_dot_u `_ +`transpose `_ + Transpose input matrix A into output matrix B + + +`u_dot_u `_ Compute -`u_dot_v `_ +`u_dot_v `_ Compute -`wall_time `_ +`wall_time `_ The equivalent of cpu_time, but for the wall time. -`write_git_log `_ +`write_git_log `_ Write the last git commit in file iunit. diff --git a/src/ZMQ/README.rst b/src/ZMQ/README.rst index 187af23e..b73dc42d 100644 --- a/src/ZMQ/README.rst +++ b/src/ZMQ/README.rst @@ -21,59 +21,67 @@ Documentation .. by the `update_README.py` script. -`add_task_to_taskserver `_ +`add_task_to_taskserver `_ Get a task from the task server -`connect_to_taskserver `_ +`connect_to_taskserver `_ Connect to the task server and obtain the worker ID -`disconnect_from_taskserver `_ +`disconnect_from_taskserver `_ Disconnect from the task server -`end_parallel_job `_ +`end_parallel_job `_ End a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' -`end_zmq_pair_socket `_ +`end_zmq_pair_socket `_ Terminate socket on which the results are sent. -`end_zmq_pull_socket `_ +`end_zmq_pull_socket `_ Terminate socket on which the results are sent. -`end_zmq_push_socket `_ +`end_zmq_push_socket `_ Terminate socket on which the results are sent. -`end_zmq_to_qp_run_socket `_ +`end_zmq_sub_socket `_ + Terminate socket on which the results are sent. + + +`end_zmq_to_qp_run_socket `_ Terminate the socket from the application to qp_run -`get_task_from_taskserver `_ +`get_task_from_taskserver `_ Get a task from the task server -`new_parallel_job `_ +`new_parallel_job `_ Start a new parallel job with name 'name'. The slave tasks execute subroutine 'slave' -`new_zmq_pair_socket `_ +`new_zmq_pair_socket `_ Socket on which the collector and the main communicate -`new_zmq_pull_socket `_ +`new_zmq_pull_socket `_ Socket on which the results are sent. If thread is 1, use inproc -`new_zmq_push_socket `_ +`new_zmq_push_socket `_ Socket on which the results are sent. If thread is 1, use inproc -`new_zmq_to_qp_run_socket `_ +`new_zmq_sub_socket `_ + Socket to read the state published by the Task server + + +`new_zmq_to_qp_run_socket `_ Socket on which the qp_run process replies @@ -82,29 +90,41 @@ Documentation Example : tcp://130.120.229.139:12345 -`reset_zmq_addresses `_ - Undocumented +`reset_zmq_addresses `_ + Socket which pulls the results (2) -`switch_qp_run_to_master `_ +`switch_qp_run_to_master `_ Address of the master qp_run socket Example : tcp://130.120.229.139:12345 -`task_done_to_taskserver `_ +`task_done_to_taskserver `_ Get a task from the task server +`wait_for_next_state `_ + Undocumented + + +`wait_for_state `_ + Wait for the ZMQ state to be ready + + +`wait_for_states `_ + Wait for the ZMQ state to be ready + + `zmq_context `_ Context for the ZeroMQ library -`zmq_delete_task `_ +`zmq_delete_task `_ When a task is done, it has to be removed from the list of tasks on the qp_run queue. This guarantees that the results have been received in the pull. -`zmq_port `_ +`zmq_port `_ Return the value of the ZMQ port from the corresponding integer @@ -113,6 +133,10 @@ Documentation Example : tcp://130.120.229.139:12345 +`zmq_set_running `_ + Set the job to Running in QP-run + + `zmq_socket_pair_inproc_address `_ Socket which pulls the results (2) @@ -133,6 +157,10 @@ Documentation Socket which pulls the results (2) -`zmq_state `_ +`zmq_socket_sub_tcp_address `_ + Socket which pulls the results (2) + + +`zmq_state `_ Threads executing work through the ZeroMQ interface diff --git a/src/ZMQ/tree_dependency.png b/src/ZMQ/tree_dependency.png new file mode 100644 index 00000000..e69de29b From 1a6caf66b5659c763522a45506191ab9ff14fbfe Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 2 Nov 2016 12:12:36 +0100 Subject: [PATCH 058/188] Corrected print bug for excited states: --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 1 + src/Davidson/diagonalization_hs2.irp.f | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index c81b1266..64296ce3 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -86,6 +86,7 @@ program fci_zmq print*,'Last iteration only to compute the PT2' threshold_selectors = 1.d0 threshold_generators = 0.9999d0 + TOUCH threshold_selectors threshold_generators E_CI_before(1:N_states) = CI_energy(1:N_states) call ZMQ_selection(0, pt2) print *, 'Final step' diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index d7ec11b6..b2eb8af1 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -305,7 +305,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,A30))') iter, to_print(:,1:N_st), '' + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,X))') iter, to_print(1:3,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) do k=1,N_st if (residual_norm(k) > 1.e4) then From 124d918021e3e71c2d3b91edd70f56ce0336a401 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 2 Nov 2016 16:01:01 +0100 Subject: [PATCH 059/188] 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 060/188] 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 061/188] 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 062/188] 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 From 33e5b93866b7712ac9ce7cf45a5c0a8f6fe17a21 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 3 Nov 2016 00:29:49 +0100 Subject: [PATCH 063/188] Corrected bug for excited stated MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 84bca0b4..48fa2e80 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -821,9 +821,10 @@ END_PROVIDER rho_mrcc_init = 0d0 - allocate(lref(N_det_ref)) - !$OMP PARALLEL DO default(shared) schedule(static, 1) & + !$OMP PARALLEL default(shared) & !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) + allocate(lref(N_det_ref)) + !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(active(pp)) cycle @@ -852,7 +853,9 @@ END_PROVIDER end do end do end do - !$OMP END PARALLEL DO + !$OMP END DO + deallocate(lref) + !$OMP END PARALLEL x_new = x From a59214374448dc64423e1c41188cc5059bb106e8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 3 Nov 2016 12:05:19 +0100 Subject: [PATCH 064/188] Working on mrpt --- plugins/MRCC_Utils/davidson.irp.f | 190 ++++++++-------------------- plugins/MRPT_Utils/give_2h2p.irp.f | 35 +++++ plugins/MRPT_Utils/mrpt_utils.irp.f | 160 ++++++++++++----------- 3 files changed, 169 insertions(+), 216 deletions(-) create mode 100644 plugins/MRPT_Utils/give_2h2p.irp.f diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index a67ca676..69faf00c 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -94,7 +94,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u - integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 @@ -144,7 +143,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s sze_8 = align_double(sze) allocate( & - kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & W(sze_8,N_st_diag,davidson_sze_max), & U(sze_8,N_st_diag,davidson_sze_max), & R(sze_8,N_st_diag), & @@ -360,7 +358,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s call write_time(iunit) deallocate ( & - kl_pairs, & W, residual_norm, & U, overlap, & R, c, & @@ -649,7 +646,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u - integer, allocatable :: kl_pairs(:,:) integer :: k_pairs, kl integer :: iter2 @@ -661,7 +657,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall - integer :: shift, shift2 + integer :: shift, shift2, itermax include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda @@ -710,23 +706,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz else delta = 0.d0 endif - - allocate( & - kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & - W(sze_8,N_st_diag*davidson_sze_max), & - U(sze_8,N_st_diag*davidson_sze_max), & - R(sze_8,N_st_diag), & - S(sze_8,N_st_diag*davidson_sze_max), & - h(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - y(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - s_(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - s_tmp(N_st_diag*davidson_sze_max,N_st_diag*davidson_sze_max), & - residual_norm(N_st_diag), & - overlap(N_st_diag,N_st_diag), & - c(N_st_diag*davidson_sze_max), & - s2(N_st_diag*davidson_sze_max), & - lambda(N_st_diag*davidson_sze_max)) + itermax = min(davidson_sze_max, sze/N_st_diag) + allocate( & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + + ASSERT (N_st > 0) ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) @@ -738,25 +741,25 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz converged = .False. - do k=1,N_st - call normalize(u_in(1,k),sze) - enddo - - do k=N_st+1,N_st_diag + double precision :: r1, r2 + do k=N_st+1,N_st_diag-2,2 do i=1,sze - double precision :: r1, r2 call random_number(r1) call random_number(r2) - u_in(i,k) = dsqrt(-2.d0*dlog(r1))*dcos(dtwo_pi*r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + u_in(i,k+1) = r1*dsin(r2) + enddo + enddo + do k=N_st_diag-1,N_st_diag + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) enddo - - ! Gram-Schmidt - ! ------------ - call dgemv('T',sze,k-1,1.d0,u_in,size(u_in,1), & - u_in(1,k),1,0.d0,c,1) - call dgemv('N',sze,k-1,-1.d0,u_in,size(u_in,1), & - c,1,1.d0,u_in(1,k),1) - call normalize(u_in(1,k),sze) enddo @@ -773,10 +776,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter + call ortho_qr(U,size(U,1),sze,shift2) ! Compute |W_k> = \sum_i |i> ! ----------------------------------------- - call H_S2_u_0_mrcc_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,& istate,N_st_diag,sze_8) @@ -786,19 +789,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ------------------------------------------- -! do l=1,N_st_diag -! do k=1,N_st_diag -! do iter2=1,iter-1 -! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) -! h(k,iter,l,iter2) = h(k,iter2,l,iter) -! enddo -! enddo -! do k=1,l -! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) -! h(l,iter,k,iter) = h(k,iter,l,iter) -! enddo -! enddo - call dgemm('T','N', shift2, N_st_diag, sze, & 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & 0.d0, h(1,shift+1), size(h,1)) @@ -829,7 +819,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo do k=1,shift2 if (.not. state_ok(k)) then @@ -851,22 +841,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Express eigenvectors of h in the determinant basis ! -------------------------------------------------- -! do k=1,N_st_diag -! do i=1,sze -! U(i,shift2+k) = 0.d0 -! W(i,shift2+k) = 0.d0 -! S(i,shift2+k) = 0.d0 -! enddo -! do l=1,N_st_diag*iter -! do i=1,sze -! U(i,shift2+k) = U(i,shift2+k) + U(i,l)*y(l,k) -! W(i,shift2+k) = W(i,shift2+k) + W(i,l)*y(l,k) -! S(i,shift2+k) = S(i,shift2+k) + S(i,l)*y(l,k) -! enddo -! enddo -! enddo -! -! call dgemm('N','N', sze, N_st_diag, shift2, & 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) call dgemm('N','N', sze, N_st_diag, shift2, & @@ -876,83 +850,39 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute residual vector ! ----------------------- - -! do k=1,N_st_diag -! print *, s2(k) -! s2(k) = u_dot_v(U(1,shift2+k), S(1,shift2+k), sze) + S_z2_Sz -! print *, s2(k) -! print *, '' -! pause -! enddo + do k=1,N_st_diag do i=1,sze - R(i,k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz) + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) enddo if (k <= N_st) then - residual_norm(k) = u_dot_u(R(1,k),sze) + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion to_print(2,k) = s2(k) to_print(3,k) = residual_norm(k) - if (residual_norm(k) > 1.e9) then - stop 'Davidson failed' - endif endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(:,1:N_st) + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e8) then + print *, '' + stop 'Davidson failed' + endif + enddo if (converged) then exit endif - - ! Davidson step - ! ------------- - - do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = - R(i,k)/max(H_jj(i) - lambda(k),1.d-2) - enddo - enddo - - ! Gram-Schmidt - ! ------------ - - do k=1,N_st_diag - -! do l=1,N_st_diag*iter -! c(1) = u_dot_v(U(1,shift2+k),U(1,l),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,l) -! enddo -! enddo -! - call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & - U(1,shift2+k),1,0.d0,c,1) - call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & - c,1,1.d0,U(1,shift2+k),1) -! -! do l=1,k-1 -! c(1) = u_dot_v(U(1,shift2+k),U(1,shift2+l),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,shift2+k) - c(1) * U(i,shift2+l) -! enddo -! enddo -! - call dgemv('T',sze,k-1,1.d0,U(1,shift2+1),size(U,1), & - U(1,shift2+k),1,0.d0,c,1) - call dgemv('N',sze,k-1,-1.d0,U(1,shift2+1),size(U,1), & - c,1,1.d0,U(1,shift2+k),1) - - call normalize( U(1,shift2+k), sze ) - enddo enddo if (.not.converged) then - iter = davidson_sze_max-1 + iter = itermax-1 endif - + ! Re-contract to u_in ! ----------- @@ -960,15 +890,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz energies(k) = lambda(k) enddo -! do k=1,N_st_diag -! do i=1,sze -! do l=1,iter*N_st_diag -! u_in(i,k) += U(i,l)*y(l,k) -! enddo -! enddo -! enddo -! enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) @@ -983,7 +904,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz call write_time(iunit) deallocate ( & - kl_pairs, & W, residual_norm, & U, overlap, & R, c, S, & diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/plugins/MRPT_Utils/give_2h2p.irp.f new file mode 100644 index 00000000..df71e594 --- /dev/null +++ b/plugins/MRPT_Utils/give_2h2p.irp.f @@ -0,0 +1,35 @@ +subroutine give_2h2p(contrib_2h2p) + implicit none + double precision, intent(out) :: contrib_2h2p(N_states) + integer :: i,j,k,l,m + integer :: iorb,jorb,korb,lorb + + double precision :: get_mo_bielec_integral + double precision :: direct_int,exchange_int + double precision :: numerator,denominator(N_states) + + contrib_2h2p = 0.d0 + do i = 1, n_inact_orb + iorb = list_inact(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_virt_orb + korb = list_virt(k) + do l = 1, n_virt_orb + lorb = list_virt(l) + direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map) + exchange_int = get_mo_bielec_integral(iorb,jorb,lorb,korb ,mo_integrals_map) + numerator = 3.d0 * direct_int*direct_int + exchange_int*exchange_int -2.d0 * exchange_int * direct_int + do m = 1, N_states + denominator(m) = fock_core_inactive_total_spin_trace(iorb,m) + fock_core_inactive_total_spin_trace(jorb,m) & + -fock_virt_total_spin_trace(korb,m) - fock_virt_total_spin_trace(lorb,m) + contrib_2h2p(m) += numerator / denominator(m) + enddo + enddo + enddo + enddo + enddo + contrib_2h2p = contrib_2h2p*0.5d0 + +end + diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 80739aa2..d7b1f0f6 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -262,89 +262,87 @@ END_PROVIDER 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 if (diag_algorithm == "Lapack") then - 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) + 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) + CI_electronic_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. + call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& + N_det,size(eigenvectors,1)) + do j=1,N_det + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif enddo - 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 + if(i_state .ne.0)then + ! Fill the first "i_state" states that have a correct S^2 value + do j = 1, i_state + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + enddo + CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_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 + do i=1,N_det + CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + enddo + CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + enddo + + else + print*,'' + print*,'!!!!!!!! WARNING !!!!!!!!!' + print*,' Within the ',N_det,'determinants selected' + print*,' and the ',N_states_diag,'states requested' + print*,' We did not find any state with S^2 values close to ',expected_s2 + print*,' We will then set the first N_states eigenvectors of the H matrix' + print*,' as the CI_eigenvectors' + print*,' You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space' + print*,'' + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2_eigvalues(j) + enddo + endif + deallocate(index_good_state_array,good_state_array) + deallocate(s2_eigvalues) + else + call u_0_S2_u_0(CI_eigenvectors_s2,eigenvectors,N_det,psi_det,N_int,& + min(N_det,N_states_diag),size(eigenvectors,1)) + ! Select the "N_states_diag" states of lowest energy + do j=1,min(N_det,N_states_diag) + do i=1,N_det + CI_eigenvectors(i,j) = eigenvectors(i,j) + enddo + CI_electronic_energy(j) = eigenvalues(j) + enddo + endif + deallocate(eigenvectors,eigenvalues) + endif END_PROVIDER From 09ead73dc791c25f292d964fe5cdc5c92c8357e5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 00:57:37 +0100 Subject: [PATCH 065/188] Improvde Davdison in MRCC --- plugins/MRCC_Utils/davidson.irp.f | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 69faf00c..7033ea61 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -643,13 +643,12 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: i,j,k,l,m logical :: converged - double precision, allocatable :: overlap(:,:) double precision :: u_dot_v, u_dot_u integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), R(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -660,7 +659,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: shift, shift2, itermax include 'constants.include.F' - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, S, y, h, lambda + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag > sze) then stop 'error in Davidson : N_st_diag > sze' endif @@ -905,8 +904,8 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & W, residual_norm, & - U, overlap, & - R, c, S, & + U, & + c, S, & h, & y, s_, s_tmp, & lambda & From a5a34a02f1fb8cc36f496c010e9a06b471fdccea Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 14:45:08 +0100 Subject: [PATCH 066/188] Fixed get_ao_bielec_integral --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 4 ++-- src/Determinants/occ_pattern.irp.f | 21 --------------------- src/Integrals_Bielec/map_integrals.irp.f | 8 +++++--- 3 files changed, 7 insertions(+), 26 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 64296ce3..964edf62 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -84,8 +84,8 @@ program fci_zmq if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = 1.d0 - threshold_generators = 0.9999d0 + threshold_selectors = threshold_selectors_pt2 + threshold_generators = threshold_generators_pt2 TOUCH threshold_selectors threshold_generators E_CI_before(1:N_states) = CI_energy(1:N_states) call ZMQ_selection(0, pt2) diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 8e802fd6..902b54db 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -76,27 +76,6 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) enddo enddo -! !TODO DEBUG -! integer :: j,s -! do i=1,nd -! do j=1,i-1 -! na=0 -! do k=1,Nint -! if((d(k,1,j) /= d(k,1,i)).or. & -! (d(k,2,j) /= d(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( j== 0 ) then -! print *, 'det ',i,' and ',j,' equal:' -! call debug_det(d(1,1,j),Nint) -! call debug_det(d(1,1,i),Nint) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG end recursive subroutine rec_occ_pattern_to_dets(list_todo,nt,list_a,na,d,nd,sze,amax,Nint) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 53b45060..5f6df0bd 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -152,7 +152,7 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ] END_PROVIDER -double precision function get_ao_bielec_integral(i,j,k,l,map) +double precision function get_ao_bielec_integral(i,j,k,l,map) result(result) use map_module implicit none BEGIN_DOC @@ -179,15 +179,16 @@ double precision function get_ao_bielec_integral(i,j,k,l,map) call bielec_integrals_index(i,j,k,l,idx) !DIR$ FORCEINLINE call map_get(map,idx,tmp) - get_ao_bielec_integral = dble(tmp) + tmp = tmp else ii = l-ao_integrals_cache_min ii = ior( ishft(ii,6), k-ao_integrals_cache_min) ii = ior( ishft(ii,6), j-ao_integrals_cache_min) ii = ior( ishft(ii,6), i-ao_integrals_cache_min) - get_ao_bielec_integral = ao_integrals_cache(ii) + tmp = ao_integrals_cache(ii) endif endif + result = tmp end @@ -676,6 +677,7 @@ integer function load_$ao_integrals(filename) real(integral_kind), pointer :: val(:) integer :: iknd, kknd integer*8 :: n, j + double precision :: get_$ao_bielec_integral load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd From 6cea98112e029efea44fe837686246108469aba5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 17:31:39 +0100 Subject: [PATCH 067/188] Corrected bug with S2 in davidson --- src/Davidson/diagonalization_hs2.irp.f | 13 +++++++------ src/Determinants/occ_pattern.irp.f | 25 +++---------------------- 2 files changed, 10 insertions(+), 28 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index b2eb8af1..af94f121 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -229,13 +229,14 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Compute h_kl = = ! ------------------------------------------- - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & - 0.d0, h(1,shift+1), size(h,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U(1,1), size(U,1), W(1,1), size(W,1), & + 0.d0, h(1,1), size(h,1)) + + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U(1,1), size(U,1), S(1,1), size(S,1), & + 0.d0, s_(1,1), size(s_,1)) - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), S(1,shift+1), size(S,1), & - 0.d0, s_(1,shift+1), size(s_,1)) ! Diagonalize h ! ------------- diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 902b54db..6abdf13e 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -35,7 +35,7 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) bmax += popcnt( o(k,1) ) amax -= popcnt( o(k,2) ) enddo - sze = int( min(binom_func(bmax, amax), 1.d8) ) + sze = 2*int( min(binom_func(bmax, amax), 1.d8) ) end @@ -205,26 +205,7 @@ end enddo deallocate(iorder,duplicate,bit_tmp,tmp_array) -! !TODO DEBUG -! integer :: s -! do i=1,N_occ_pattern -! do j=i+1,N_occ_pattern -! s = 0 -! do k=1,N_int -! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. & -! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then -! s=1 -! exit -! endif -! enddo -! if ( s == 0 ) then -! print *, 'Error : occ ', j, 'already in wf' -! call debug_det(psi_occ_pattern(1,1,j),N_int) -! stop -! endif -! enddo -! enddo -! !TODO DEBUG + END_PROVIDER subroutine make_s2_eigenfunction @@ -232,7 +213,7 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new + integer :: N_det_new, iproc integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction From 225c1f607e2fe729612e103ec1ac7e15afac7620 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 17:34:05 +0100 Subject: [PATCH 068/188] Manu changes --- plugins/MRPT_Utils/psi_active_prov.irp.f | 61 +++--------------------- plugins/Perturbation/pt2_new.irp.f | 8 +++- src/Davidson/diagonalization_hs2.irp.f | 4 +- src/Davidson/u0Hu0.irp.f | 5 +- 4 files changed, 17 insertions(+), 61 deletions(-) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index f08af1d5..67501727 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -182,7 +182,11 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) double precision :: delta_e_inactive(N_states) integer :: i_hole_inact - + call get_excitation_degree(det_1,det_2,degree,N_int) + if(degree>2)then + delta_e_final = -1.d+10 + return + endif call give_holes_in_inactive_space(det_2,n_holes_spin,n_holes,holes_list) delta_e_inactive = 0.d0 @@ -307,32 +311,11 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) else if (n_holes_act == 1 .and. n_particles_act == 0) then 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 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) @@ -344,9 +327,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -356,9 +336,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -368,14 +345,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -390,11 +359,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -410,11 +374,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -429,10 +388,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) enddo 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) @@ -442,7 +397,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) ! second particle kspin = particle_list_practical(1,3) k_particle_act = particle_list_practical(2,3) - 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 @@ -464,12 +418,8 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) ! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif - - 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' @@ -479,6 +429,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,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 +!write(*,'(100(f16.10,X))'), delta_e_final(1) , delta_e_act(1) , delta_e_inactive(1) , delta_e_virt(1) end diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f index efe7f375..2f9cfbfb 100644 --- a/plugins/Perturbation/pt2_new.irp.f +++ b/plugins/Perturbation/pt2_new.irp.f @@ -32,6 +32,7 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, coef_pert = 0.d0 call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx) + double precision :: coef_array(Nstate) if (Nstate == 1) then do ii=1,idx(0) @@ -40,8 +41,11 @@ subroutine i_H_psi_pert_new_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet, !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) - + do i = 1, Nstate + coef_array(i) = coef(i_in_coef,i) + enddo + call get_delta_e_dyall(keys(1,1,i_in_key),key,coef_array,hij,delta_e_final) + coef_pert += coef(i_in_coef,1)*hij / delta_e_final enddo if (coef_pert * i_H_psi_array(1) > 0.d0)then diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index b2eb8af1..c15cd8ee 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -305,10 +305,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3,X))') iter, to_print(1:3,1:N_st) + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) do k=1,N_st - if (residual_norm(k) > 1.e4) then + if (residual_norm(k) > 1.e8) then print *, '' stop 'Davidson failed' endif diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 3787370a..9ab30476 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -209,7 +209,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) integer, external :: align_double integer :: blockb, blockb2, istep - double precision :: ave_workload, workload + double precision :: ave_workload, workload, target_workload_inv integer(ZMQ_PTR) :: handler @@ -250,6 +250,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) end do enddo ave_workload = ave_workload/dble(shortcut(0,1)) + target_workload_inv = 0.001d0/ave_workload do sh=1,shortcut(0,1),1 @@ -259,7 +260,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) workload += (shortcut(j+1,2) - shortcut(j, 2))**2 end do end do - istep = 1+ int(0.5d0*workload/ave_workload) + istep = 1+ int(workload*target_workload_inv) do blockb2=0, istep-1 call davidson_add_task(handler, sh, blockb2, istep) enddo From e8e35c82155a29e33caaa4bb47c626b82161a76e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:03:32 +0100 Subject: [PATCH 069/188] Corrected S2 bug in Davidson of MRCC --- plugins/MRCC_Utils/davidson.irp.f | 25 ++++++------------------ plugins/MRPT_Utils/psi_active_prov.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 8 ++++---- 3 files changed, 11 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 7033ea61..5783c5d9 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -207,19 +207,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ------------------------------------------- -! do l=1,N_st_diag -! do k=1,N_st_diag -! do iter2=1,iter-1 -! h(k,iter2,l,iter) = u_dot_v(U(1,k,iter2),W(1,l,iter),sze) -! h(k,iter,l,iter2) = h(k,iter2,l,iter) -! enddo -! enddo -! do k=1,l -! h(k,iter,l,iter) = u_dot_v(U(1,k,iter),W(1,l,iter),sze) -! h(l,iter,k,iter) = h(k,iter,l,iter) -! enddo -! enddo - call dgemm('T','N', N_st_diag*iter, N_st_diag, sze, & 1.d0, U, size(U,1), W(1,1,iter), size(W,1), & 0.d0, h(1,1,1,iter), size(h,1)*size(h,2)) @@ -788,13 +775,13 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ------------------------------------------- - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), W(1,shift+1), size(W,1), & - 0.d0, h(1,shift+1), size(h,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) - call dgemm('T','N', shift2, N_st_diag, sze, & - 1.d0, U, size(U,1), S(1,shift+1), size(S,1), & - 0.d0, s_(1,shift+1), size(s_,1)) + call dgemm('T','N', shift2, shift2, sze, & + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) ! Diagonalize h ! ------------- diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 67501727..794742b4 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -415,7 +415,7 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) i_hole = list_inact_reverse(h1) i_part = list_virt_reverse(p1) do i_state = 1, N_states -! delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) + delta_e_act(i_state) += one_anhil_one_creat_inact_virt(i_hole,i_part,i_state) enddo endif else if (n_holes_act .ge. 2 .and. n_particles_act .ge.2) then diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 12265810..d82d9f84 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -230,12 +230,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ------------------------------------------- call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), W(1,1), size(W,1), & - 0.d0, h(1,1), size(h,1)) + 1.d0, U, size(U,1), W, size(W,1), & + 0.d0, h, size(h,1)) call dgemm('T','N', shift2, shift2, sze, & - 1.d0, U(1,1), size(U,1), S(1,1), size(S,1), & - 0.d0, s_(1,1), size(s_,1)) + 1.d0, U, size(U,1), S, size(S,1), & + 0.d0, s_, size(s_,1)) ! Diagonalize h From 6f075d8c37f6ee5851b4329cf15736cde945393e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:08:20 +0100 Subject: [PATCH 070/188] Repaired map_integrals --- src/Integrals_Bielec/map_integrals.irp.f | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 5f6df0bd..1f2a7a1b 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -677,7 +677,6 @@ integer function load_$ao_integrals(filename) real(integral_kind), pointer :: val(:) integer :: iknd, kknd integer*8 :: n, j - double precision :: get_$ao_bielec_integral load_$ao_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') read(66,err=98,end=98) iknd, kknd @@ -712,7 +711,7 @@ integer function load_$ao_integrals(filename) end -SUBST [ ao_integrals_map, ao_integrals, ao_num , get_ao_bielec_integral ] -ao_integrals_map ; ao_integrals ; ao_num ; get_ao_bielec_integral ;; -mo_integrals_map ; mo_integrals ; mo_tot_num ; get_mo_bielec_integral ;; +SUBST [ ao_integrals_map, ao_integrals, ao_num ] +ao_integrals_map ; ao_integrals ; ao_num ;; +mo_integrals_map ; mo_integrals ; mo_tot_num ;; END_TEMPLATE From 4aec6f2f008a5ff03639b832435aaa27017d3135 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 18:39:36 +0100 Subject: [PATCH 071/188] Gained 10% by merging selection files --- plugins/Full_CI_ZMQ/selection.irp.f | 1084 ++++++++++++++++++++ plugins/Full_CI_ZMQ/selection_double.irp.f | 726 ------------- plugins/Full_CI_ZMQ/selection_single.irp.f | 354 ------- 3 files changed, 1084 insertions(+), 1080 deletions(-) delete mode 100644 plugins/Full_CI_ZMQ/selection_double.irp.f delete mode 100644 plugins/Full_CI_ZMQ/selection_single.irp.f diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index a0209cc5..b2fda694 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -104,3 +104,1087 @@ end subroutine +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + delta_E = E0(istate) - Hii + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do genl +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + if (delta_E < 0.d0) then + e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + else + e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + endif + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection_double.irp.f b/plugins/Full_CI_ZMQ/selection_double.irp.f deleted file mode 100644 index 977622fd..00000000 --- a/plugins/Full_CI_ZMQ/selection_double.irp.f +++ /dev/null @@ -1,726 +0,0 @@ - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) - if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - diff --git a/plugins/Full_CI_ZMQ/selection_single.irp.f b/plugins/Full_CI_ZMQ/selection_single.irp.f deleted file mode 100644 index f107db11..00000000 --- a/plugins/Full_CI_ZMQ/selection_single.irp.f +++ /dev/null @@ -1,354 +0,0 @@ - - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert - double precision, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - val = vect(istate, p1) - delta_E = E0(istate) - Hii - if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do genl -end subroutine - - - From ab7735e3f362a8f7430484c96dae716dc116c1ee Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 19:15:45 +0100 Subject: [PATCH 072/188] Accelerated (7%) access to integrals in PT2 --- plugins/Full_CI_ZMQ/selection.irp.f | 40 +++++++++++++++++++---------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index b2fda694..3f351004 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -6,8 +6,20 @@ double precision function integral8(i,j,k,l) integer, intent(in) :: i,j,k,l double precision, external :: get_mo_bielec_integral - - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif end function @@ -179,7 +191,7 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, logical :: ok integer :: s1, s2, p1, p2, ib, istate integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp double precision, external :: diag_H_mat_elem_fock @@ -195,13 +207,13 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, max_e_pert = 0d0 do istate=1,N_states - val = vect(istate, p1) + val = vect(istate, p1) + vect(istate, p1) delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + tmp = -tmp endif + e_pert = 0.5d0 * ( tmp - delta_E) pt2(istate) += e_pert if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert end do @@ -632,7 +644,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d logical :: ok integer :: s1, s2, p1, p2, ib, j, istate integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp double precision, external :: diag_H_mat_elem_fock logical, external :: detEq @@ -664,14 +676,14 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d do istate=1,N_states delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) if (delta_E < 0.d0) then - e_pert = 0.5d0 * (-dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) - else - e_pert = 0.5d0 * ( dsqrt(delta_E * delta_E + 4.d0 * val * val) - delta_E) + tmp = -tmp endif - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) end do if(dabs(max_e_pert) > buf%mini) then From f0c30cc7f28a910fcab23766ff7b4dea88e152ef Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Fri, 4 Nov 2016 16:00:47 -0500 Subject: [PATCH 073/188] Update qp_convert_qmcpack_to_ezfio.py --- plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py | 4 ---- 1 file changed, 4 deletions(-) diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index e911af28..a1f47ccd 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -364,10 +364,6 @@ for line_raw in det_without_header.split("\n"): try: float(line) except ValueError: - - print line_raw.strip(), len(line_raw.strip()) - print l_order_mo, len(l_order_mo) - line_order = [line_raw[i] for i in l_order_mo] line= "".join([d_rep[x] if x in d_rep else x for x in line_raw]) From ea36e3aa284b4bf69d360f443abf1ea3446810eb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 22:31:55 +0100 Subject: [PATCH 074/188] Cleaned MRPT --- .../MRPT_Utils.main.irp.f | 0 plugins/MRPT/NEEDED_CHILDREN_MODULES | 1 + plugins/MRPT/README.rst | 14 +++++++ plugins/MRPT/mrpt.irp.f | 38 +++++++++++++++++++ plugins/{MRPT_Utils => MRPT}/print_1h2p.irp.f | 0 plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES | 2 +- 6 files changed, 54 insertions(+), 1 deletion(-) rename plugins/{MRPT_Utils => MRPT}/MRPT_Utils.main.irp.f (100%) create mode 100644 plugins/MRPT/NEEDED_CHILDREN_MODULES create mode 100644 plugins/MRPT/README.rst create mode 100644 plugins/MRPT/mrpt.irp.f rename plugins/{MRPT_Utils => MRPT}/print_1h2p.irp.f (100%) diff --git a/plugins/MRPT_Utils/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f similarity index 100% rename from plugins/MRPT_Utils/MRPT_Utils.main.irp.f rename to plugins/MRPT/MRPT_Utils.main.irp.f diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..7340c609 --- /dev/null +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/README.rst b/plugins/MRPT/README.rst new file mode 100644 index 00000000..a9a0860c --- /dev/null +++ b/plugins/MRPT/README.rst @@ -0,0 +1,14 @@ +==== +MRPT +==== + +Executables for Multi-reference perturbation. + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/MRPT/mrpt.irp.f b/plugins/MRPT/mrpt.irp.f new file mode 100644 index 00000000..8c8d746d --- /dev/null +++ b/plugins/MRPT/mrpt.irp.f @@ -0,0 +1,38 @@ +program MRPT + implicit none + BEGIN_DOC +! TODO + END_DOC + print *, ' _/ ' + print *, ' -:\_?, _Jm####La ' + print *, 'J"(:" > _]#AZ#Z#UUZ##, ' + print *, '_,::./ %(|i%12XmX1*1XL _?, ' + print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' + print *, ' .:< ]J=mQD?WXn|,)nr" ' + print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' + print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' + print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' + print *, ' miX#L -~`""!!1}oSoe|i7 ' + print *, ' 4cn#m, v221=|v[ ' + print *, ' ]hI3Zma,;..__wXSe=+vo ' + print *, ' ]Zov*XSUXXZXZXSe||vo2 ' + print *, ' ]Z#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/print_1h2p.irp.f rename to plugins/MRPT/print_1h2p.irp.f diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES index a613d5f2..34de8ddb 100644 --- a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Selectors_full Generators_full Davidson +Determinants Davidson From 4cd2976678d673a8cd7d12e2a6ebd9295d194aeb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 23:17:38 +0100 Subject: [PATCH 075/188] Fixed bug in occ_pattern --- src/Davidson/diagonalization_hs2.irp.f | 6 +----- src/Determinants/occ_pattern.irp.f | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index d82d9f84..8a4cb2d2 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -320,10 +320,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- @@ -331,7 +327,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s energies(k) = lambda(k) enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & + call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 6abdf13e..3f6a2c87 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -186,7 +186,7 @@ end endif enddo j+=1 - if (j>N_det) then + if (j>=N_det) then exit endif enddo From af2780860e563ed3d128201150b0d82cbcce97f0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 4 Nov 2016 23:44:14 +0100 Subject: [PATCH 076/188] Removed s2_eig -> Bug --- scripts/generate_h_apply.py | 2 +- src/Determinants/H_apply.irp.f | 4 ++-- src/Determinants/occ_pattern.irp.f | 11 +++++++---- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index cfb1d6bf..c7714e8a 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -422,7 +422,7 @@ class H_apply(object): if (s2_eig) then call make_s2_eigenfunction endif -! SOFT_TOUCH psi_det psi_coef N_det + SOFT_TOUCH psi_det psi_coef N_det selection_criterion_min = min(selection_criterion_min, maxval(select_max))*0.1d0 selection_criterion = selection_criterion_min call write_double(output_determinants,selection_criterion,'Selection criterion') diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 20eb3e83..887b8938 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -248,7 +248,6 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) enddo if (found_duplicates) then - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') k=0 do i=1,N_det if (.not.duplicate(i)) then @@ -258,7 +257,8 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) endif enddo N_det = k - TOUCH N_det psi_det psi_coef + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') + SOFT_TOUCH N_det psi_det psi_coef endif deallocate (duplicate,bit_tmp) end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 3f6a2c87..42032937 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -213,10 +213,13 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new, iproc + integer :: N_det_new integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction + return + stop 'make_s2_eigenfunction has a bug. It should not be used!!!' + allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 N_det_new = 0 @@ -248,13 +251,13 @@ 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) - call write_int(output_determinants,N_det_new, 'Added determinants for S^2') + call copy_H_apply_buffer_to_wf + SOFT_TOUCH N_det psi_coef psi_det + print *, 'Added determinants for S^2' end From 7ac373c1b3e814945048a064965de4c71408c8f3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 10:24:36 +0100 Subject: [PATCH 077/188] Fixed make_s2_eigenfunction --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 17 ++++++----- src/Determinants/H_apply.irp.f | 1 + src/Determinants/occ_pattern.irp.f | 49 ++++++++++++++++++++---------- 3 files changed, 44 insertions(+), 23 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 964edf62..45f3362e 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -122,13 +122,15 @@ subroutine ZMQ_selection(N_in, pt2) double precision, intent(out) :: pt2(N_states) - N = max(N_in,1) - provide nproc - provide ci_electronic_energy - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) + if (.True.) then + N = max(N_in,1) + provide nproc + provide ci_electronic_energy + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif integer :: i_generator, i_generator_start, i_generator_max, step ! step = int(max(1.,10*elec_num/mo_tot_num) @@ -154,6 +156,7 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() + call make_s2_eigenfunction endif end subroutine diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 887b8938..c8f32c3a 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -259,6 +259,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) N_det = k call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') SOFT_TOUCH N_det psi_det psi_coef + stop 'duplicates in psi_det' endif deallocate (duplicate,bit_tmp) end diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 42032937..df7a5f00 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -35,7 +35,8 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) bmax += popcnt( o(k,1) ) amax -= popcnt( o(k,2) ) enddo - sze = 2*int( min(binom_func(bmax, amax), 1.d8) ) + sze = int( min(binom_func(bmax, amax), 1.d8) ) + sze = sze*sze end @@ -123,8 +124,8 @@ end implicit none BEGIN_DOC ! array of the occ_pattern present in the wf - ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation - ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation + ! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupations + ! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupations END_DOC integer :: i,j,k @@ -144,7 +145,7 @@ end logical,allocatable :: duplicate(:) - allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) ) + allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,N_det) ) do i=1,N_det iorder(i) = i @@ -161,18 +162,16 @@ end duplicate(i) = .False. enddo - i=1 - integer (bit_kind) :: occ_pattern_tmp - do i=1,N_det - duplicate(i) = .False. - enddo - + ! Find duplicates do i=1,N_det-1 if (duplicate(i)) then cycle endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) + if (j>N_det) then + exit + endif if (duplicate(j)) then j+=1 cycle @@ -186,12 +185,10 @@ end endif enddo j+=1 - if (j>=N_det) then - exit - endif enddo enddo + ! Copy filtered result N_occ_pattern=0 do i=1,N_det if (duplicate(i)) then @@ -204,6 +201,28 @@ end enddo enddo +!- Check +! do i=1,N_occ_pattern +! do j=i+1,N_occ_pattern +! duplicate(1) = .True. +! do k=1,N_int +! if (psi_occ_pattern(k,1,i) /= psi_occ_pattern(k,1,j)) then +! duplicate(1) = .False. +! exit +! endif +! if (psi_occ_pattern(k,2,i) /= psi_occ_pattern(k,2,j)) then +! duplicate(1) = .False. +! exit +! endif +! enddo +! if (duplicate(1)) then +! call debug_det(psi_occ_pattern(1,1,i),N_int) +! call debug_det(psi_occ_pattern(1,1,j),N_int) +! stop 'DUPLICATE' +! endif +! enddo +! enddo +!- deallocate(iorder,duplicate,bit_tmp,tmp_array) END_PROVIDER @@ -217,9 +236,6 @@ subroutine make_s2_eigenfunction integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction - return - stop 'make_s2_eigenfunction has a bug. It should not be used!!!' - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) smax = 1 N_det_new = 0 @@ -258,6 +274,7 @@ subroutine make_s2_eigenfunction call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' +! call remove_duplicates_in_psi_det end From 86494251887721ca7f9d3fa376727f96fbabeae3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 12:05:07 +0100 Subject: [PATCH 078/188] Fixed make_s2_eigenfunction --- config/gfortran_debug.cfg | 2 +- src/Determinants/occ_pattern.irp.f | 38 ++++++++++++++++++++++++++---- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 03663eea..4b06c5e9 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --assert --align=32 +IRPF90_FLAGS : --ninja --align=32 # Global options ################ diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index df7a5f00..6ee54677 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -69,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd + integer :: ne(2), l + l=0 do i=1,nd + ne(1) = 0 + ne(2) = 0 + l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) + d(k,1,l) = ior(d(k,1,i),o(k,2)) + d(k,2,l) = ior(d(k,2,i),o(k,2)) + ne(1) += popcnt(d(k,1,l)) + ne(2) += popcnt(d(k,2,l)) enddo + if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then + l = l-1 + endif enddo + sze = l end @@ -169,11 +180,11 @@ end endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) - if (j>N_det) then - exit - endif if (duplicate(j)) then j+=1 + if (j>N_det) then + exit + endif cycle endif duplicate(j) = .True. @@ -185,6 +196,9 @@ end endif enddo j+=1 + if (j>N_det) then + exit + endif enddo enddo @@ -256,6 +270,20 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo +! integer :: ne(2) +! ne(:) = 0 +! do k=1,N_int +! ne(1) += popcnt(d(k,1,j)) +! ne(2) += popcnt(d(k,2,j)) +! enddo +! if (ne(1) /= elec_alpha_num) then +! call debug_det(d(1,1,j),N_int) +! stop "ALPHA" +! endif +! if (ne(2) /= elec_beta_num) then +! call debug_det(d(1,1,j),N_int) +! stop "BETA" +! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 From ee4e3eaa8ebacbca972a7a680676febb2139e0f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 12:05:07 +0100 Subject: [PATCH 079/188] Fixed make_s2_eigenfunction --- config/gfortran_debug.cfg | 2 +- src/Determinants/H_apply.irp.f | 6 +++- src/Determinants/occ_pattern.irp.f | 45 ++++++++++++++++++++++++------ 3 files changed, 43 insertions(+), 10 deletions(-) diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 03663eea..4b06c5e9 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -13,7 +13,7 @@ FC : gfortran -g -ffree-line-length-none -I . -static-libgcc LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 -IRPF90_FLAGS : --ninja --assert --align=32 +IRPF90_FLAGS : --ninja --align=32 # Global options ################ diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index c8f32c3a..88affa21 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -222,7 +222,11 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) do while (bit_tmp(j)==bit_tmp(i)) if (duplicate(j)) then j += 1 - cycle + if (j > N_det) then + exit + else + cycle + endif endif duplicate(j) = .True. do k=1,N_int diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index df7a5f00..42bca8eb 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -52,8 +52,8 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) integer(bit_kind),intent(out) :: d(Nint,2,sze) integer :: i, k, nt, na, nd, amax - integer :: list_todo(n_alpha) - integer :: list_a(n_alpha) + integer :: list_todo(2*n_alpha) + integer :: list_a(2*n_alpha) amax = n_alpha do k=1,Nint @@ -69,13 +69,24 @@ subroutine occ_pattern_to_dets(o,d,sze,n_alpha,Nint) sze = nd + integer :: ne(2), l + l=0 do i=1,nd + ne(1) = 0 + ne(2) = 0 + l=l+1 ! Doubly occupied orbitals do k=1,Nint - d(k,1,i) = ior(d(k,1,i),o(k,2)) - d(k,2,i) = ior(d(k,2,i),o(k,2)) + d(k,1,l) = ior(d(k,1,i),o(k,2)) + d(k,2,l) = ior(d(k,2,i),o(k,2)) + ne(1) += popcnt(d(k,1,l)) + ne(2) += popcnt(d(k,2,l)) enddo + if ( (ne(1) /= elec_alpha_num).or.(ne(2) /= elec_beta_num) ) then + l = l-1 + endif enddo + sze = l end @@ -169,11 +180,11 @@ end endif j = i+1 do while (bit_tmp(j)==bit_tmp(i)) - if (j>N_det) then - exit - endif if (duplicate(j)) then j+=1 + if (j>N_det) then + exit + endif cycle endif duplicate(j) = .True. @@ -185,6 +196,9 @@ end endif enddo j+=1 + if (j>N_det) then + exit + endif enddo enddo @@ -256,6 +270,20 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo +! integer :: ne(2) +! ne(:) = 0 +! do k=1,N_int +! ne(1) += popcnt(d(k,1,j)) +! ne(2) += popcnt(d(k,2,j)) +! enddo +! if (ne(1) /= elec_alpha_num) then +! call debug_det(d(1,1,j),N_int) +! stop "ALPHA" +! endif +! if (ne(2) /= elec_beta_num) then +! call debug_det(d(1,1,j),N_int) +! stop "BETA" +! endif if (N_det_new == bufsze) then call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) N_det_new = 0 @@ -274,7 +302,8 @@ subroutine make_s2_eigenfunction call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' -! call remove_duplicates_in_psi_det +! logical :: found +! call remove_duplicates_in_psi_det(found) end From a1a2d888267b782bd83d0fc2e36d17eeb8c41767 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 16:59:29 +0100 Subject: [PATCH 080/188] Removed ZMQ parallelization in Davidson --- src/Davidson/diagonalization_hs2.irp.f | 1 + src/Davidson/u0Hu0.irp.f | 155 ++++++++++++++++++++++++- 2 files changed, 155 insertions(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 8a4cb2d2..778a5702 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -223,6 +223,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- +! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 9ab30476..d13b4db4 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -177,7 +177,7 @@ BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] END_PROVIDER -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) use bitmasks use f77_zmq implicit none @@ -280,3 +280,156 @@ end +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + integer :: blockb, blockb2, istep + double precision :: ave_workload, workload, target_workload_inv + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate(ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(i,istate) + enddo + enddo + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + org_j = sort_idx(j,1) + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + endif + enddo + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),i-1 + org_j = sort_idx(j,2) + ext = 0 + do ni=1,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + end if + end do + end do + enddo + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do istate=1,N_st + do i=n,1,-1 + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + s_0(i,istate) = s_0(i,istate) + st(istate,i) + enddo + enddo + !$OMP END CRITICAL + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + From 2d1f40cae70041ef9c6ccfb10e5657be97f7b829 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 8 Nov 2016 23:03:11 +0100 Subject: [PATCH 081/188] Better convergence of MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 30 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 48fa2e80..5a35a792 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -884,28 +884,26 @@ END_PROVIDER !$OMP END PARALLEL + + res = 0.d0 - - - if (res < resold) then - do a_coll=1,nactive ! nex - a_col = active_pp_idx(a_coll) - do j=1,N_det_non_ref - i = A_ind(j,a_coll) - if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) - enddo - res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) - X(a_col) = X_new(a_col) - end do - factor = 1.d0 - else + do a_coll=1,nactive ! nex + a_col = active_pp_idx(a_coll) + do j=1,N_det_non_ref + i = A_ind(j,a_coll) + if (i==0) exit + rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) + enddo + res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) + X(a_col) = X_new(a_col) + end do + if (res > resold) then factor = -factor * 0.5d0 endif resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res + print *, "res ", k, res, factor end if if(res < 1d-9) exit From 2a2e099bca536b1f27f34859f410459690a67a76 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 9 Nov 2016 15:42:27 +0100 Subject: [PATCH 082/188] Cleaned MRCC --- plugins/MRCC_Utils/amplitudes.irp.f | 228 +++++++++++++++++++++++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 237 ++++++-------------------- plugins/mrcepa0/mrcepa0_general.irp.f | 2 +- src/Determinants/slater_rules.irp.f | 2 +- 4 files changed, 282 insertions(+), 187 deletions(-) create mode 100644 plugins/MRCC_Utils/amplitudes.irp.f diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f new file mode 100644 index 00000000..718d5340 --- /dev/null +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -0,0 +1,228 @@ + BEGIN_PROVIDER [ integer, n_exc_active ] +&BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ] +&BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ] +&BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ] + implicit none + BEGIN_DOC + ! is_active_exc : True if the excitation involves at least one active MO + ! + ! n_exc_active : Number of active excitations : Number of excitations without the inactive ones. + ! + ! active_hh_idx : + ! + ! active_pp_idx : + END_DOC + integer :: hh, pp, II + integer :: ind + logical :: ok + integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) + + integer, allocatable :: pathTo(:) + integer, external :: searchDet + + allocate(pathTo(N_det_non_ref)) + + pathTo(:) = 0 + is_active_exc(:) = .false. + n_exc_active = 0 + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + do II = 1, N_det_ref + + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind == -1) cycle + + ind = psi_non_ref_sorted_idx(ind) + if(pathTo(ind) == 0) then + pathTo(ind) = pp + else + is_active_exc(pp) = .true. + is_active_exc(pathTo(ind)) = .true. + end if + end do + end do + end do + + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(is_active_exc(pp)) then + n_exc_active = n_exc_active + 1 + active_hh_idx(n_exc_active) = hh + active_pp_idx(n_exc_active) = pp + end if + end do + end do + + deallocate(pathTo) + + print *, n_exc_active, "inactive excitations /", hh_nex + +END_PROVIDER + + + BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active) ] +&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active) ] + implicit none + BEGIN_DOC + ! Sparse matrix A containing the matrix to transform the active excitations to + ! determinants : A | \Psi_0 > = | \Psi_SD > + END_DOC + integer :: s, ppp, pp, hh, II, ind, wk, i + integer, allocatable :: lref(:) + integer(bit_kind) :: myDet(N_int,2), myMask(N_int,2) + double precision :: phase + logical :: ok + integer, external :: searchDet + + + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& + !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& + !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, & + !$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)& + !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& + !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) + allocate(lref(N_det_non_ref)) + !$OMP DO schedule(static,10) + do ppp=1,n_exc_active + active_excitation_to_determinants_val(:,:,ppp) = 0d0 + active_excitation_to_determinants_idx(:,ppp) = 0 + pp = active_pp_idx(ppp) + hh = active_hh_idx(ppp) + lref = 0 + do II = 1, N_det_ref + call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) + if(.not. ok) cycle + call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) + if(.not. ok) cycle + ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) + if(ind /= -1) then + call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) + if (phase > 0.d0) then + lref(psi_non_ref_sorted_idx(ind)) = II + else + lref(psi_non_ref_sorted_idx(ind)) = -II + endif + end if + end do + wk = 0 + do i=1, N_det_non_ref + if(lref(i) > 0) then + wk += 1 + do s=1,N_states + active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) + enddo + active_excitation_to_determinants_idx(wk, ppp) = i + else if(lref(i) < 0) then + wk += 1 + do s=1,N_states + active_excitation_to_determinants_val(s,wk, ppp) = -psi_ref_coef(-lref(i), s) + enddo + active_excitation_to_determinants_idx(wk, ppp) = i + end if + end do + active_excitation_to_determinants_idx(0,ppp) = wk + end do + !$OMP END DO + deallocate(lref) + !$OMP END PARALLEL + +END_PROVIDER + + BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] +&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] + implicit none + BEGIN_DOC + ! A is active_excitation_to_determinants in At.A + END_DOC + integer :: AtA_size, i,k + integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s + double precision, allocatable :: t(:), A_val_mwen(:,:) + integer, allocatable :: A_ind_mwen(:) + + mrcc_AtA_ind(:) = 0 + mrcc_AtA_val(:,:) = 0.d0 + mrcc_col_shortcut(:) = 0 + mrcc_N_col(:) = 0 + AtA_size = 0 + + + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& + !$OMP active_excitation_to_determinants_val, hh_nex) & + !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, n_exc_active, active_pp_idx) + allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) + + !$OMP DO schedule(dynamic, 100) + do at_roww = 1, n_exc_active ! hh_nex + at_row = active_pp_idx(at_roww) + wk = 0 + if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", hh_nex + + do a_coll = 1, n_exc_active + a_col = active_pp_idx(a_coll) + t(:) = 0d0 + r1 = 1 + r2 = 1 + do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) + if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then + r2 = r2+1 + else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then + r1 = r1+1 + else + do s=1,N_states + t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) + enddo + r1 = r1+1 + r2 = r2+1 + end if + end do + + if(a_col == at_row) then + do s=1,N_states + t(s) = t(s) + 1.d0 + enddo + end if + if(sum(abs(t)) /= 0.d0) then + wk += 1 + A_ind_mwen(wk) = a_col + do s=1,N_states + A_val_mwen(s,wk) = t(s) + enddo + end if + end do + + if(wk /= 0) then + !$OMP CRITICAL + mrcc_col_shortcut(at_roww) = AtA_size+1 + mrcc_N_col(at_roww) = wk + if (AtA_size+wk > size(mrcc_AtA_ind,1)) then + print *, AtA_size+wk , size(mrcc_AtA_ind,1) + stop 'too small' + endif + do i=1,wk + mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) + do s=1,N_states + mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) + enddo + enddo + AtA_size += wk + !$OMP END CRITICAL + end if + end do + !$OMP END DO NOWAIT + deallocate (A_ind_mwen, A_val_mwen, t) + !$OMP END PARALLEL + + print *, "ATA SIZE", ata_size + +END_PROVIDER + diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 5a35a792..191866aa 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -614,207 +614,60 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ] + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] implicit none logical :: ok - integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, nex, a_col, at_row + integer :: i, j, k, s, II, pp, ppp, hh, ind, wk, a_col, at_row integer, external :: searchDet, unsortedSearchDet integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) - integer :: N, INFO, AtA_size, r1, r2 - double precision , allocatable :: AtB(:), AtA_val(:), A_val(:,:), x(:), x_new(:), A_val_mwen(:) - double precision :: t, norm, cx, res - integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:) + integer :: N, INFO, r1, r2 + double precision , allocatable :: AtB(:), x(:), x_new(:), A_val_mwen(:,:), t(:) + double precision :: norm, cx, res + integer, allocatable :: lref(:), A_ind_mwen(:) double precision :: phase +! double precision , allocatable :: mrcc_AtA_val(:,:) +! integer, allocatable :: mrcc_AtA_ind(:), col_shortcut(:), , mrcc_N_col(:) - integer, allocatable :: pathTo(:), active_hh_idx(:), active_pp_idx(:) - logical, allocatable :: active(:) double precision, allocatable :: rho_mrcc_init(:,:) - integer :: nactive + integer :: a_coll, at_roww - nex = hh_shortcut(hh_shortcut(0)+1)-1 - print *, "TI", nex, N_det_non_ref - - allocate(pathTo(N_det_non_ref), active(nex)) - allocate(active_pp_idx(nex), active_hh_idx(nex)) - allocate(rho_mrcc_init(N_det_non_ref, N_states)) - - pathTo = 0 - active = .false. - nactive = 0 - - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - ind = psi_non_ref_sorted_idx(ind) - if(pathTo(ind) == 0) then - pathTo(ind) = pp - else - active(pp) = .true. - active(pathTo(ind)) = .true. - end if - end do - end do - end do - - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) then - nactive = nactive + 1 - active_hh_idx(nactive) = hh - active_pp_idx(nactive) = pp - end if - end do - end do - - print *, nactive, "inact/", size(active) - - allocate(A_ind(0:N_det_ref+1, nactive), A_val(N_det_ref+1, nactive)) - allocate(AtA_ind(N_det_ref * nactive), AtA_val(N_det_ref * nactive)) - allocate(x(nex), AtB(nex)) - allocate(N_col(nactive), col_shortcut(nactive)) - allocate(x_new(nex)) - + print *, "TI", hh_nex, N_det_non_ref - do s=1, N_states - - A_val = 0d0 - A_ind = 0 - AtA_ind = 0 - AtB = 0d0 - AtA_val = 0d0 - x = 0d0 - N_col = 0 - col_shortcut = 0 - - !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind)& - !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref)& - !$OMP shared(active, active_hh_idx, active_pp_idx, nactive) & - !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh) - allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) - do ppp=1,nactive - pp = active_pp_idx(ppp) - hh = active_hh_idx(ppp) - lref = 0 - do II = 1, N_det_ref - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind /= -1) then - call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - if (phase > 0.d0) then - lref(psi_non_ref_sorted_idx(ind)) = II - else - lref(psi_non_ref_sorted_idx(ind)) = -II - endif - end if - end do - wk = 0 - do i=1, N_det_non_ref - if(lref(i) > 0) then - wk += 1 - A_val(wk, ppp) = psi_ref_coef(lref(i), s) - A_ind(wk, ppp) = i - else if(lref(i) < 0) then - wk += 1 - A_val(wk, ppp) = -psi_ref_coef(-lref(i), s) - A_ind(wk, ppp) = i - end if - end do - A_ind(0,ppp) = wk - end do - !$OMP END DO - deallocate(lref) - !$OMP END PARALLEL - - - print *, 'Done building A_val, A_ind' - - AtA_size = 0 - col_shortcut = 0 - N_col = 0 - integer :: a_coll, at_roww - - - !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref)& + + allocate(rho_mrcc_init(N_det_non_ref, N_states)) + + allocate(x(hh_nex), AtB(hh_nex)) + x = 0d0 + allocate(x_new(hh_nex)) + + + do s=1,N_states + + AtB(:) = 0.d0 + !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& + !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s, nactive, active_pp_idx) - allocate(A_val_mwen(nex), A_ind_mwen(nex)) + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) + allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) !$OMP DO schedule(dynamic, 100) - do at_roww = 1, nactive ! nex + do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) - wk = 0 - if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", nex - do i=1,A_ind(0,at_roww) - j = active_pp_idx(i) - AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_roww), s) * A_val(i, at_roww) + do i=1,active_excitation_to_determinants_idx(0,at_roww) + AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) end do - - do a_coll = 1, nactive - a_col = active_pp_idx(a_coll) - t = 0d0 - r1 = 1 - r2 = 1 - do while ((A_ind(r1, at_roww) /= 0).and.(A_ind(r2, a_coll) /= 0)) - if(A_ind(r1, at_roww) > A_ind(r2, a_coll)) then - r2 = r2+1 - else if(A_ind(r1, at_roww) < A_ind(r2, a_coll)) then - r1 = r1+1 - else - t = t - A_val(r1, at_roww) * A_val(r2, a_coll) - r1 = r1+1 - r2 = r2+1 - end if - end do - - if(a_col == at_row) then - t = t + 1.d0 - end if - if(t /= 0.d0) then - wk += 1 - A_ind_mwen(wk) = a_col - A_val_mwen(wk) = t - end if - end do - - if(wk /= 0) then - !$OMP CRITICAL - col_shortcut(at_roww) = AtA_size+1 - N_col(at_roww) = wk - if (AtA_size+wk > size(AtA_ind,1)) then - print *, AtA_size+wk , size(AtA_ind,1) - stop 'too small' - endif - do i=1,wk - AtA_ind(AtA_size+i) = A_ind_mwen(i) - AtA_val(AtA_size+i) = A_val_mwen(i) - enddo - AtA_size += wk - !$OMP END CRITICAL - end if end do !$OMP END DO NOWAIT deallocate (A_ind_mwen, A_val_mwen) !$OMP END PARALLEL - - print *, "ATA SIZE", ata_size + x = 0d0 - do a_coll = 1, nactive + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) X(a_col) = AtB(a_col) end do @@ -827,7 +680,7 @@ END_PROVIDER !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(active(pp)) cycle + if(is_active_exc(pp)) cycle lref = 0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) @@ -872,11 +725,11 @@ END_PROVIDER !$OMP END DO !$OMP DO - do a_coll = 1, nactive !: nex + do a_coll = 1, n_exc_active !: hh_nex a_col = active_pp_idx(a_coll) cx = 0d0 - do i=col_shortcut(a_coll), col_shortcut(a_coll) + N_col(a_coll) - 1 - cx = cx + x(AtA_ind(i)) * AtA_val(i) + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) end do x_new(a_col) = AtB(a_col) + cx * factor end do @@ -887,12 +740,12 @@ END_PROVIDER res = 0.d0 - do a_coll=1,nactive ! nex + do a_coll=1,n_exc_active ! hh_nex a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref - i = A_ind(j,a_coll) + i = active_excitation_to_determinants_idx(j,a_coll) if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + A_val(j,a_coll) * X_new(a_col) + rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col) enddo res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) @@ -1051,6 +904,7 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) + f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f @@ -1180,9 +1034,21 @@ end function BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] &BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] +&BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] +&BEGIN_PROVIDER [ integer, hh_nex ] implicit none + BEGIN_DOC + ! + ! hh_exists : + ! + ! pp_exists : + ! + ! hh_shortcut : + ! + ! hh_nex : Total number of excitation operators + ! + END_DOC integer*2,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i integer*2 :: h1, h2, p1, p2 @@ -1248,6 +1114,7 @@ end function end if end do end do + hh_nex = hh_shortcut(hh_shortcut(0)+1)-1 END_PROVIDER diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 63f03360..c7b31ea9 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -66,7 +66,7 @@ subroutine print_cas_coefs print *, 'CAS' print *, '===' do i=1,N_det_cas - print *, psi_cas_coef(i,:) + print *, (psi_cas_coef(i,j), j=1,N_states) call debug_det(psi_cas(1,1,i),N_int) enddo call write_double(6,ci_energy(1),"Initial CI energy") diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ed299447..789dc93c 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -513,7 +513,7 @@ subroutine i_H_j(key_i,key_j,Nint,hij) integer :: occ(Nint*bit_kind_size,2) double precision :: diag_H_mat_elem, phase,phase_2 integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map + PROVIDE mo_bielec_integrals_in_map mo_integrals_map big_array_exchange_integrals ASSERT (Nint > 0) ASSERT (Nint == N_int) From 5c56e066fc66a5ca2eb660f4a638672ccea172f0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 9 Nov 2016 22:00:44 +0100 Subject: [PATCH 083/188] MRCC eigenfunction of S2 --- plugins/MRCC_Utils/amplitudes.irp.f | 25 ++++++++++--- plugins/MRCC_Utils/mrcc_utils.irp.f | 29 +++++++++------- src/Determinants/s2.irp.f | 54 ++++++++++++++--------------- 3 files changed, 63 insertions(+), 45 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 718d5340..2694aa75 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -137,6 +137,7 @@ END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_AtS2A_val, (N_states, N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] implicit none @@ -145,11 +146,15 @@ END_PROVIDER END_DOC integer :: AtA_size, i,k integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s - double precision, allocatable :: t(:), A_val_mwen(:,:) + double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) + integer(bit_kind) :: det1(N_int,2), det2(N_int,2) + double precision :: sij + PROVIDE psi_non_ref S_z2_Sz S_z mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 + mrcc_AtS2A_val(:,:) = 0.d0 mrcc_col_shortcut(:) = 0 mrcc_N_col(:) = 0 AtA_size = 0 @@ -157,9 +162,11 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & - !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, n_exc_active, active_pp_idx) - allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) + !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& + !$OMP det1,det2,As2_val_mwen, a_coll, at_roww,sij) & + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref,N_int,S_z2_Sz, mrcc_AtS2A_val) + allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -170,6 +177,7 @@ END_PROVIDER do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) t(:) = 0d0 + ts(:) = 0d0 r1 = 1 r2 = 1 do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) @@ -178,8 +186,12 @@ END_PROVIDER else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then r1 = r1+1 else + det1(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r1,at_roww)) + det2(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r2,a_coll)) + call get_s2(det1, det2,N_int,sij) do s=1,N_states t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) + ts(s) = ts(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) * sij enddo r1 = r1+1 r2 = r2+1 @@ -189,6 +201,7 @@ END_PROVIDER if(a_col == at_row) then do s=1,N_states t(s) = t(s) + 1.d0 + ts(s) = ts(s) + S_z2_Sz enddo end if if(sum(abs(t)) /= 0.d0) then @@ -196,6 +209,7 @@ END_PROVIDER A_ind_mwen(wk) = a_col do s=1,N_states A_val_mwen(s,wk) = t(s) + As2_val_mwen(s,wk) = ts(s) enddo end if end do @@ -212,6 +226,7 @@ END_PROVIDER mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) do s=1,N_states mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) + mrcc_AtS2A_val(s,AtA_size+i) = As2_val_mwen(s,i) enddo enddo AtA_size += wk @@ -219,7 +234,7 @@ END_PROVIDER end if end do !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen, t) + deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t, ts) !$OMP END PARALLEL print *, "ATA SIZE", ata_size diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 191866aa..f864dd08 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -626,8 +626,6 @@ END_PROVIDER double precision :: norm, cx, res integer, allocatable :: lref(:), A_ind_mwen(:) double precision :: phase -! double precision , allocatable :: mrcc_AtA_val(:,:) -! integer, allocatable :: mrcc_AtA_ind(:), col_shortcut(:), , mrcc_N_col(:) double precision, allocatable :: rho_mrcc_init(:,:) @@ -635,13 +633,10 @@ END_PROVIDER print *, "TI", hh_nex, N_det_non_ref - - allocate(rho_mrcc_init(N_det_non_ref, N_states)) - + allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) x = 0d0 - allocate(x_new(hh_nex)) do s=1,N_states @@ -712,28 +707,37 @@ END_PROVIDER x_new = x + double precision :: s2(N_states), s2_local, dx double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll, s2_local) !$OMP DO do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i,s) ! 0d0 + rho_mrcc(i,s) = rho_mrcc_init(i,s) enddo !$OMP END DO + s2(s) = 0.d0 !$OMP DO - do a_coll = 1, n_exc_active !: hh_nex + do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) - cx = 0d0 + cx = 0.d0 + dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) + dx = dx + x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) + s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) end do - x_new(a_col) = AtB(a_col) + cx * factor + x_new(a_col) = AtB(a_col) + (cx+dx) * factor end do !$OMP END DO + + !$OMP CRITICAL + s2(s) = s2(s) + s2_local + !$OMP END CRITICAL !$OMP END PARALLEL @@ -756,14 +760,13 @@ END_PROVIDER resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res, factor + print *, "res ", k, res, s2(s) end if if(res < 1d-9) exit end do - norm = 0.d0 do i=1,N_det_non_ref norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index c6bb8390..7e62befb 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,36 +1,36 @@ subroutine get_s2(key_i,key_j,Nint,s2) - implicit none - use bitmasks - BEGIN_DOC -! Returns - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2) - integer(bit_kind), intent(in) :: key_j(Nint,2) - double precision, intent(out) :: s2 - integer :: exc(0:2,2,2) - integer :: degree - double precision :: phase_spsm - integer :: nup, i - - s2 = 0.d0 - !$FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case(2) - call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) - if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta - if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then - s2 = -phase_spsm - endif - endif - case(0) + implicit none + use bitmasks + BEGIN_DOC + ! Returns + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + integer(bit_kind), intent(in) :: key_j(Nint,2) + double precision, intent(out) :: s2 + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase_spsm + integer :: nup, i + + s2 = 0.d0 + !$FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case(2) + call get_double_excitation(key_j,key_i,exc,phase_spsm,Nint) + if (exc(0,1,1) == 1) then ! Mono alpha + mono-beta + if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then + s2 = -phase_spsm + endif + endif + case(0) nup = 0 do i=1,Nint nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) enddo s2 = dble(nup) - end select + end select end BEGIN_PROVIDER [ double precision, S_z ] From 12d3c31b48fce17e041b87ba5a800856b650fbad Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:27:06 +0100 Subject: [PATCH 084/188] Version with S2A in MRCC. Broken --- plugins/MRCC_Utils/amplitudes.irp.f | 85 ++++++++++++++++++++++++----- plugins/MRCC_Utils/mrcc_utils.irp.f | 40 ++++++++++---- 2 files changed, 101 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 2694aa75..77360d93 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -49,7 +49,7 @@ end do end do end do - +!is_active_exc=.true. do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) then @@ -133,6 +133,55 @@ END_PROVIDER deallocate(lref) !$OMP END PARALLEL +END_PROVIDER + + BEGIN_PROVIDER [ integer, mrcc_S2A_ind, (0:N_det_ref*mo_tot_num, n_exc_active) ] +&BEGIN_PROVIDER [ double precision, mrcc_S2A_val, (N_states, N_det_ref*mo_tot_num, n_exc_active) ] + implicit none + BEGIN_DOC + ! A is active_excitation_to_determinants in S^2. + END_DOC + integer :: a_coll, a_col + integer :: i,j,idx,s + double precision :: sij + double precision, allocatable :: tmp(:,:) + logical, allocatable :: ok(:) + mrcc_S2A_val = 0.d0 + print *, 'Computing S2A' + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(a_coll,idx,i,sij,s,tmp,ok,j) + allocate(tmp(N_states,N_det_non_ref), ok(N_det_non_ref)) + !$OMP DO + do a_coll=1, n_exc_active + tmp = 0.d0 + ok = .False. + do idx=1, active_excitation_to_determinants_idx(0,a_coll) + i = active_excitation_to_determinants_idx(idx,a_coll) + do j=1,N_det_non_ref + call get_s2(psi_non_ref(1,1,i), psi_non_ref(1,1,j), N_int, sij) + if (sij /= 0.d0) then + do s=1,N_states + tmp(s,j) = tmp(s,j) + sij*active_excitation_to_determinants_val(s,idx,a_coll) + enddo + ok(j) = .True. + endif + enddo + enddo + idx = 0 + do j=1,N_det_non_ref + if (ok(j)) then + idx = idx+1 + mrcc_S2A_ind(idx,a_coll) = j + do s=1,N_states + mrcc_S2A_val(s,idx,a_coll) = tmp(s,j) + enddo + endif + enddo + mrcc_S2A_ind(0,a_coll) = idx + enddo + !$OMP END DO + deallocate(tmp,ok) + !$OMP END PARALLEL + END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] @@ -148,9 +197,8 @@ END_PROVIDER integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) - integer(bit_kind) :: det1(N_int,2), det2(N_int,2) double precision :: sij - PROVIDE psi_non_ref S_z2_Sz S_z + PROVIDE psi_non_ref mrcc_S2A_val mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -163,9 +211,9 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& - !$OMP det1,det2,As2_val_mwen, a_coll, at_roww,sij) & - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & - !$OMP n_exc_active, active_pp_idx,psi_non_ref,N_int,S_z2_Sz, mrcc_AtS2A_val) + !$OMP As2_val_mwen, a_coll, at_roww,sij) & + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_S2A_val, mrcc_S2A_ind, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref,mrcc_AtS2A_val) allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) !$OMP DO schedule(dynamic, 100) @@ -177,7 +225,6 @@ END_PROVIDER do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) t(:) = 0d0 - ts(:) = 0d0 r1 = 1 r2 = 1 do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) @@ -186,12 +233,25 @@ END_PROVIDER else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then r1 = r1+1 else - det1(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r1,at_roww)) - det2(:,:) = psi_non_ref(:,:, active_excitation_to_determinants_idx(r2,a_coll)) - call get_s2(det1, det2,N_int,sij) do s=1,N_states t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) - ts(s) = ts(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) * sij + enddo + r1 = r1+1 + r2 = r2+1 + end if + end do + + ts(:) = 0d0 + r1 = 1 + r2 = 1 + do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(mrcc_S2A_ind(r2, a_coll) /= 0)) + if(active_excitation_to_determinants_idx(r1, at_roww) > mrcc_S2A_ind(r2, a_coll)) then + r2 = r2+1 + else if(active_excitation_to_determinants_idx(r1, at_roww) < mrcc_S2A_ind(r2, a_coll)) then + r1 = r1+1 + else + do s=1,N_states + ts(s) = ts(s) + active_excitation_to_determinants_val(s,r1, at_roww) * mrcc_S2A_val(s,r2, a_coll) enddo r1 = r1+1 r2 = r2+1 @@ -201,10 +261,9 @@ END_PROVIDER if(a_col == at_row) then do s=1,N_states t(s) = t(s) + 1.d0 - ts(s) = ts(s) + S_z2_Sz enddo end if - if(sum(abs(t)) /= 0.d0) then + if(sum(abs(t)+abs(ts)) /= 0.d0) then wk += 1 A_ind_mwen(wk) = a_col do s=1,N_states diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f864dd08..970802de 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -707,12 +707,24 @@ END_PROVIDER x_new = x - double precision :: s2(N_states), s2_local, dx + double precision :: s2(N_states), s2_local, dx, s2_init(N_states) double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) + + s2_init(s) = S_z2_Sz + do hh = 1, hh_shortcut(0) + do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 + if(is_active_exc(pp)) cycle + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + s2_init(s) = s2_init(s) + X(pp)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + end do + enddo + end do + do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll, s2_local) + s2_local = s2_init(s) + !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -720,7 +732,15 @@ END_PROVIDER enddo !$OMP END DO - s2(s) = 0.d0 + !$OMP DO REDUCTION(+:s2_local) + do a_coll = 1, n_exc_active + a_col = active_pp_idx(a_coll) + do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 + s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + end do + end do + !$OMP END DO + !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) @@ -728,23 +748,19 @@ END_PROVIDER dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) - dx = dx + x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) - s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) + dx = dx + (s2_local-expected_s2)*x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) end do x_new(a_col) = AtB(a_col) + (cx+dx) * factor end do !$OMP END DO - !$OMP CRITICAL - s2(s) = s2(s) + s2_local - !$OMP END CRITICAL - !$OMP END PARALLEL + s2(s) = s2_local res = 0.d0 - do a_coll=1,n_exc_active ! hh_nex + do a_coll=1,n_exc_active a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref i = active_excitation_to_determinants_idx(j,a_coll) @@ -765,7 +781,7 @@ END_PROVIDER if(res < 1d-9) exit end do - + s2(s) = s2_local norm = 0.d0 do i=1,N_det_non_ref @@ -928,6 +944,7 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) + print *, 'S^2 |T Psi_0> = ', s2(s) do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -936,6 +953,7 @@ END_PROVIDER do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo +rho_mrcc = 1.d0 ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant From 76a0d69d3bf117af847036524b93fb4b99e6c30c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:30:41 +0100 Subject: [PATCH 085/188] Removed S2 in MRCC --- plugins/MRCC_Utils/amplitudes.irp.f | 95 +++-------------------------- plugins/MRCC_Utils/mrcc_utils.irp.f | 33 +--------- 2 files changed, 9 insertions(+), 119 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 77360d93..095eebbe 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -135,58 +135,9 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer, mrcc_S2A_ind, (0:N_det_ref*mo_tot_num, n_exc_active) ] -&BEGIN_PROVIDER [ double precision, mrcc_S2A_val, (N_states, N_det_ref*mo_tot_num, n_exc_active) ] - implicit none - BEGIN_DOC - ! A is active_excitation_to_determinants in S^2. - END_DOC - integer :: a_coll, a_col - integer :: i,j,idx,s - double precision :: sij - double precision, allocatable :: tmp(:,:) - logical, allocatable :: ok(:) - mrcc_S2A_val = 0.d0 - print *, 'Computing S2A' - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(a_coll,idx,i,sij,s,tmp,ok,j) - allocate(tmp(N_states,N_det_non_ref), ok(N_det_non_ref)) - !$OMP DO - do a_coll=1, n_exc_active - tmp = 0.d0 - ok = .False. - do idx=1, active_excitation_to_determinants_idx(0,a_coll) - i = active_excitation_to_determinants_idx(idx,a_coll) - do j=1,N_det_non_ref - call get_s2(psi_non_ref(1,1,i), psi_non_ref(1,1,j), N_int, sij) - if (sij /= 0.d0) then - do s=1,N_states - tmp(s,j) = tmp(s,j) + sij*active_excitation_to_determinants_val(s,idx,a_coll) - enddo - ok(j) = .True. - endif - enddo - enddo - idx = 0 - do j=1,N_det_non_ref - if (ok(j)) then - idx = idx+1 - mrcc_S2A_ind(idx,a_coll) = j - do s=1,N_states - mrcc_S2A_val(s,idx,a_coll) = tmp(s,j) - enddo - endif - enddo - mrcc_S2A_ind(0,a_coll) = idx - enddo - !$OMP END DO - deallocate(tmp,ok) - !$OMP END PARALLEL - -END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] -&BEGIN_PROVIDER [ double precision, mrcc_AtS2A_val, (N_states, N_det_ref * n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] &BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] implicit none @@ -195,14 +146,13 @@ END_PROVIDER END_DOC integer :: AtA_size, i,k integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s - double precision, allocatable :: t(:), ts(:), A_val_mwen(:,:), As2_val_mwen(:,:) + double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref mrcc_S2A_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 - mrcc_AtS2A_val(:,:) = 0.d0 mrcc_col_shortcut(:) = 0 mrcc_N_col(:) = 0 AtA_size = 0 @@ -210,11 +160,11 @@ END_PROVIDER !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & - !$OMP private(at_row, a_col, t, ts, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& + !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& !$OMP As2_val_mwen, a_coll, at_roww,sij) & - !$OMP shared(N_states,mrcc_col_shortcut, mrcc_S2A_val, mrcc_S2A_ind, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & - !$OMP n_exc_active, active_pp_idx,psi_non_ref,mrcc_AtS2A_val) - allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states), ts(N_states)) + !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & + !$OMP n_exc_active, active_pp_idx,psi_non_ref) + allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) ) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -241,36 +191,6 @@ END_PROVIDER end if end do - ts(:) = 0d0 - r1 = 1 - r2 = 1 - do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(mrcc_S2A_ind(r2, a_coll) /= 0)) - if(active_excitation_to_determinants_idx(r1, at_roww) > mrcc_S2A_ind(r2, a_coll)) then - r2 = r2+1 - else if(active_excitation_to_determinants_idx(r1, at_roww) < mrcc_S2A_ind(r2, a_coll)) then - r1 = r1+1 - else - do s=1,N_states - ts(s) = ts(s) + active_excitation_to_determinants_val(s,r1, at_roww) * mrcc_S2A_val(s,r2, a_coll) - enddo - r1 = r1+1 - r2 = r2+1 - end if - end do - - if(a_col == at_row) then - do s=1,N_states - t(s) = t(s) + 1.d0 - enddo - end if - if(sum(abs(t)+abs(ts)) /= 0.d0) then - wk += 1 - A_ind_mwen(wk) = a_col - do s=1,N_states - A_val_mwen(s,wk) = t(s) - As2_val_mwen(s,wk) = ts(s) - enddo - end if end do if(wk /= 0) then @@ -285,7 +205,6 @@ END_PROVIDER mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) do s=1,N_states mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) - mrcc_AtS2A_val(s,AtA_size+i) = As2_val_mwen(s,i) enddo enddo AtA_size += wk @@ -293,7 +212,7 @@ END_PROVIDER end if end do !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t, ts) + deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t) !$OMP END PARALLEL print *, "ATA SIZE", ata_size diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 970802de..e81fce53 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -707,23 +707,11 @@ END_PROVIDER x_new = x - double precision :: s2(N_states), s2_local, dx, s2_init(N_states) double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - s2_init(s) = S_z2_Sz - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - if(is_active_exc(pp)) cycle - do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 - s2_init(s) = s2_init(s) + X(pp)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) - end do - enddo - end do - do k=0,100000 - s2_local = s2_init(s) !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) !$OMP DO @@ -732,31 +720,18 @@ END_PROVIDER enddo !$OMP END DO - !$OMP DO REDUCTION(+:s2_local) - do a_coll = 1, n_exc_active - a_col = active_pp_idx(a_coll) - do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 - s2_local = s2_local + X(a_col)*X(mrcc_AtA_ind(i))*mrcc_AtS2A_val(s,i) - end do - end do - !$OMP END DO - !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) cx = 0.d0 - dx = 0.d0 do i=mrcc_col_shortcut(a_coll), mrcc_col_shortcut(a_coll) + mrcc_N_col(a_coll) - 1 cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) - dx = dx + (s2_local-expected_s2)*x(mrcc_AtA_ind(i)) * mrcc_AtS2A_val(s,i) end do - x_new(a_col) = AtB(a_col) + (cx+dx) * factor + x_new(a_col) = AtB(a_col) + cx * factor end do !$OMP END DO !$OMP END PARALLEL - s2(s) = s2_local - res = 0.d0 @@ -776,12 +751,11 @@ END_PROVIDER resold = res if(mod(k, 100) == 0) then - print *, "res ", k, res, s2(s) + print *, "res ", k, res end if if(res < 1d-9) exit end do - s2(s) = s2_local norm = 0.d0 do i=1,N_det_non_ref @@ -923,7 +897,6 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f @@ -944,7 +917,6 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - print *, 'S^2 |T Psi_0> = ', s2(s) do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) @@ -953,7 +925,6 @@ END_PROVIDER do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc(i,s) * f enddo -rho_mrcc = 1.d0 ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant From 57632c6d87c1cd365d4080f905539110be414869 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 13:34:40 +0100 Subject: [PATCH 086/188] Added lambda_type=2 --- plugins/MRCC_Utils/mrcc_utils.irp.f | 11 +++++++++-- plugins/mrcepa0/EZFIO.cfg | 2 +- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index e81fce53..074039e1 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -712,7 +712,7 @@ END_PROVIDER resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, dx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -966,9 +966,16 @@ double precision function get_dij_index(II, i, s, Nint) call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index * rho_mrcc(i,s) - else + else if(lambda_type == 1) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index * rho_mrcc(i,s) call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) get_dij_index = HIi * lambda_mrcc(s, i) + else if(lambda_type == 2) then + call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) + get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index end if end function diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index 61f3392f..b64637e6 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -23,7 +23,7 @@ interface: ezfio type: Threshold doc: Threshold on the convergence of the dressed CI energy interface: ezfio,provider,ocaml -default: 5.e-5 +default: 1.e-5 [n_it_max_dressed_ci] type: Strictly_positive_int From b49fd6280d0bba0de26f55c79a4f9df827653a18 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 10 Nov 2016 14:24:54 +0100 Subject: [PATCH 087/188] Moved threshold_perturbation_pt2 --- plugins/Full_CI/EZFIO.cfg | 12 ------------ plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- plugins/Perturbation/EZFIO.cfg | 12 ++++++++++++ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/plugins/Full_CI/EZFIO.cfg b/plugins/Full_CI/EZFIO.cfg index afb25d2e..9a552cd0 100644 --- a/plugins/Full_CI/EZFIO.cfg +++ b/plugins/Full_CI/EZFIO.cfg @@ -8,15 +8,3 @@ 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/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f864dd08..50079651 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -907,7 +907,7 @@ END_PROVIDER ! Avoid numerical instabilities f = min(f,2.d0) f = max(f,-2.d0) - f = 1.d0 +! f = 1.d0 norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f diff --git a/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index 9023accf..4f0457a2 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -18,3 +18,15 @@ doc: The selection process stops when the energy ratio variational/(variational+ interface: ezfio,provider,ocaml default: 0.75 +[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. + From fe54cb26754a7ef5b78a0990aa9c19bddde0580d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:07:58 +0100 Subject: [PATCH 088/188] Introduced PT2 energy denomitator provider --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 26 ++++++++++--------- .../selection_davidson_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_slave.irp.f | 2 +- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/davidson.irp.f | 23 ++++++---------- plugins/MRCC_Utils/mrcc_utils.irp.f | 5 +--- plugins/Selectors_full/selectors.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 11 ++++---- src/Davidson/u0Hu0.irp.f | 8 +++--- 9 files changed, 36 insertions(+), 45 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index a3488655..e03db458 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -123,11 +123,11 @@ subroutine ZMQ_selection(N_in, pt2) if (.True.) then + PROVIDE pt2_e0_denominator N = max(N_in,1) provide nproc - provide ci_electronic_energy call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,ci_electronic_energy,size(ci_electronic_energy)) + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) call zmq_set_running(zmq_to_qp_run_socket) call create_selection_buffer(N, N*2, b) endif @@ -144,19 +144,21 @@ subroutine ZMQ_selection(N_in, pt2) call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do - !$OMP PARALLEL DEFAULT(none) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) shared(ci_electronic_energy_is_built, n_det_generators_is_built, n_states_is_built, n_int_is_built, nproc_is_built) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') + call end_parallel_job(zmq_to_qp_run_socket, 'selection') if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() - call make_s2_eigenfunction + if (s2_eig) then + call make_s2_eigenfunction + endif endif end subroutine @@ -165,7 +167,7 @@ subroutine selection_slave_inproc(i) implicit none integer, intent(in) :: i - call run_selection_slave(1,i,ci_electronic_energy) + call run_selection_slave(1,i,pt2_e0_denominator) end subroutine selection_collector(b, pt2) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 6e4cf44f..5041e731 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -13,7 +13,7 @@ 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 mo_mono_elec_integral -! PROVIDE ci_electronic_energy mo_tot_num N_int +! PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 06bcf533..b9e530e0 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ 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 -! PROVIDE ci_electronic_energy mo_tot_num N_int + PROVIDE pt2_e0_denominator mo_tot_num N_int end subroutine run_wf diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 095eebbe..053527f7 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -62,7 +62,7 @@ deallocate(pathTo) - print *, n_exc_active, "inactive excitations /", hh_nex + print *, n_exc_active, "active excitations /", hh_nex END_PROVIDER diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 5783c5d9..9d5e8a67 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -315,20 +315,10 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s ! ----------- do k=1,N_st_diag - energies(k) = lambda(k) do i=1,sze u_in(i,k) = 0.d0 enddo enddo -! do k=1,N_st_diag -! do i=1,sze -! do iter2=1,iter -! do l=1,N_st_diag -! u_in(i,k) += U(i,l,iter2)*y(l,iter2,k,1) -! enddo -! enddo -! enddo -! enddo call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & U, size(U,1), y, N_st_diag*davidson_sze_max, & @@ -336,6 +326,9 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s enddo + do k=1,N_st_diag + energies(k) = lambda(k) + enddo write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ ================' @@ -557,7 +550,7 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit, istate integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: energies(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -962,7 +955,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -1004,8 +997,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) + !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -1028,7 +1021,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO ! -------------------------- ! Begin Specific to dressing diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 074039e1..7005fa19 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -712,7 +712,7 @@ END_PROVIDER resold = huge(1.d0) do k=0,100000 - !$OMP PARALLEL default(shared) private(cx, i, j, a_col, a_coll) + !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref @@ -967,9 +967,6 @@ double precision function get_dij_index(II, i, s, Nint) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase get_dij_index = get_dij_index * rho_mrcc(i,s) else if(lambda_type == 1) then - call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) - get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index * rho_mrcc(i,s) call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) get_dij_index = HIi * lambda_mrcc(s, i) else if(lambda_type == 2) then diff --git a/plugins/Selectors_full/selectors.irp.f b/plugins/Selectors_full/selectors.irp.f index fd719136..e8e746c8 100644 --- a/plugins/Selectors_full/selectors.irp.f +++ b/plugins/Selectors_full/selectors.irp.f @@ -14,7 +14,7 @@ BEGIN_PROVIDER [ integer, N_det_selectors] integer :: i double precision :: norm, norm_max call write_time(output_determinants) - N_det_selectors = N_det_generators + N_det_selectors = N_det if (threshold_generators < 1.d0) then norm = 0.d0 do i=1,N_det diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 778a5702..fddac471 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -22,7 +22,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint, iunit integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st), s2_out(N_st_diag) + double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) double precision :: diag_h_mat_elem @@ -116,7 +116,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s stop -1 endif - PROVIDE nuclear_repulsion + PROVIDE nuclear_repulsion expected_s2 call write_time(iunit) call wall_time(wall) @@ -253,6 +253,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call dgemm('T','N',shift2,shift2,shift2, & 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & 0.d0, s_, size(s_,1)) + + do k=1,shift2 s2(k) = s_(k,k) + S_z2_Sz @@ -324,16 +326,13 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - enddo - call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo do k=1,N_st_diag + energies(k) = lambda(k) S2_jj(k) = s2(k) enddo write_buffer = '===== ' diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index d13b4db4..18004e02 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -344,7 +344,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -386,8 +386,8 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo enddo enddo - !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(dynamic) + !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -410,7 +410,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP CRITICAL do istate=1,N_st From b97ca19a8c691e7b9d5b0e2e117664b8e34ad371 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:12:48 +0100 Subject: [PATCH 089/188] Made MRPT_Utils a core module --- {plugins => src}/MRPT_Utils/EZFIO.cfg | 0 {plugins => src}/MRPT_Utils/H_apply.irp.f | 0 {plugins => src}/MRPT_Utils/NEEDED_CHILDREN_MODULES | 0 {plugins => src}/MRPT_Utils/README.rst | 0 {plugins => src}/MRPT_Utils/energies_cas.irp.f | 0 {plugins => src}/MRPT_Utils/excitations_cas.irp.f | 0 {plugins => src}/MRPT_Utils/fock_like_operators.irp.f | 0 {plugins => src}/MRPT_Utils/give_2h2p.irp.f | 0 {plugins => src}/MRPT_Utils/mrpt_dress.irp.f | 0 {plugins => src}/MRPT_Utils/mrpt_utils.irp.f | 0 {plugins => src}/MRPT_Utils/new_way.irp.f | 0 {plugins => src}/MRPT_Utils/new_way_second_order_coef.irp.f | 0 {plugins => src}/MRPT_Utils/psi_active_prov.irp.f | 0 {plugins => src}/MRPT_Utils/second_order_new.irp.f | 0 {plugins => src}/MRPT_Utils/second_order_new_2p.irp.f | 0 {plugins => src}/MRPT_Utils/utils_bitmask.irp.f | 0 16 files changed, 0 insertions(+), 0 deletions(-) rename {plugins => src}/MRPT_Utils/EZFIO.cfg (100%) rename {plugins => src}/MRPT_Utils/H_apply.irp.f (100%) rename {plugins => src}/MRPT_Utils/NEEDED_CHILDREN_MODULES (100%) rename {plugins => src}/MRPT_Utils/README.rst (100%) rename {plugins => src}/MRPT_Utils/energies_cas.irp.f (100%) rename {plugins => src}/MRPT_Utils/excitations_cas.irp.f (100%) rename {plugins => src}/MRPT_Utils/fock_like_operators.irp.f (100%) rename {plugins => src}/MRPT_Utils/give_2h2p.irp.f (100%) rename {plugins => src}/MRPT_Utils/mrpt_dress.irp.f (100%) rename {plugins => src}/MRPT_Utils/mrpt_utils.irp.f (100%) rename {plugins => src}/MRPT_Utils/new_way.irp.f (100%) rename {plugins => src}/MRPT_Utils/new_way_second_order_coef.irp.f (100%) rename {plugins => src}/MRPT_Utils/psi_active_prov.irp.f (100%) rename {plugins => src}/MRPT_Utils/second_order_new.irp.f (100%) rename {plugins => src}/MRPT_Utils/second_order_new_2p.irp.f (100%) rename {plugins => src}/MRPT_Utils/utils_bitmask.irp.f (100%) diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/src/MRPT_Utils/EZFIO.cfg similarity index 100% rename from plugins/MRPT_Utils/EZFIO.cfg rename to src/MRPT_Utils/EZFIO.cfg diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/src/MRPT_Utils/H_apply.irp.f similarity index 100% rename from plugins/MRPT_Utils/H_apply.irp.f rename to src/MRPT_Utils/H_apply.irp.f diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/src/MRPT_Utils/NEEDED_CHILDREN_MODULES similarity index 100% rename from plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES rename to src/MRPT_Utils/NEEDED_CHILDREN_MODULES diff --git a/plugins/MRPT_Utils/README.rst b/src/MRPT_Utils/README.rst similarity index 100% rename from plugins/MRPT_Utils/README.rst rename to src/MRPT_Utils/README.rst diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/src/MRPT_Utils/energies_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/energies_cas.irp.f rename to src/MRPT_Utils/energies_cas.irp.f diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/src/MRPT_Utils/excitations_cas.irp.f similarity index 100% rename from plugins/MRPT_Utils/excitations_cas.irp.f rename to src/MRPT_Utils/excitations_cas.irp.f diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/src/MRPT_Utils/fock_like_operators.irp.f similarity index 100% rename from plugins/MRPT_Utils/fock_like_operators.irp.f rename to src/MRPT_Utils/fock_like_operators.irp.f diff --git a/plugins/MRPT_Utils/give_2h2p.irp.f b/src/MRPT_Utils/give_2h2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/give_2h2p.irp.f rename to src/MRPT_Utils/give_2h2p.irp.f diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/src/MRPT_Utils/mrpt_dress.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_dress.irp.f rename to src/MRPT_Utils/mrpt_dress.irp.f diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/src/MRPT_Utils/mrpt_utils.irp.f similarity index 100% rename from plugins/MRPT_Utils/mrpt_utils.irp.f rename to src/MRPT_Utils/mrpt_utils.irp.f diff --git a/plugins/MRPT_Utils/new_way.irp.f b/src/MRPT_Utils/new_way.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way.irp.f rename to src/MRPT_Utils/new_way.irp.f diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/src/MRPT_Utils/new_way_second_order_coef.irp.f similarity index 100% rename from plugins/MRPT_Utils/new_way_second_order_coef.irp.f rename to src/MRPT_Utils/new_way_second_order_coef.irp.f diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/src/MRPT_Utils/psi_active_prov.irp.f similarity index 100% rename from plugins/MRPT_Utils/psi_active_prov.irp.f rename to src/MRPT_Utils/psi_active_prov.irp.f diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/src/MRPT_Utils/second_order_new.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new.irp.f rename to src/MRPT_Utils/second_order_new.irp.f diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/src/MRPT_Utils/second_order_new_2p.irp.f similarity index 100% rename from plugins/MRPT_Utils/second_order_new_2p.irp.f rename to src/MRPT_Utils/second_order_new_2p.irp.f diff --git a/plugins/MRPT_Utils/utils_bitmask.irp.f b/src/MRPT_Utils/utils_bitmask.irp.f similarity index 100% rename from plugins/MRPT_Utils/utils_bitmask.irp.f rename to src/MRPT_Utils/utils_bitmask.irp.f From b51cfbcfbe973b394e9e248bab72d8479d1e4ce2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 11 Nov 2016 23:42:59 +0100 Subject: [PATCH 090/188] Forgot file --- plugins/Full_CI_ZMQ/energy.irp.f | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 plugins/Full_CI_ZMQ/energy.irp.f diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f new file mode 100644 index 00000000..4999c176 --- /dev/null +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -0,0 +1,11 @@ +BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] + implicit none + BEGIN_DOC + ! E0 in the denominator of the PT2 + END_DOC + pt2_E0_denominator(:) = CI_electronic_energy(:) +! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') +END_PROVIDER + From 23e5036718d98ae8009c8f2a2eab38b367d0af58 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 13:33:36 +0100 Subject: [PATCH 091/188] Better parallelization of Davidson --- src/Davidson/u0Hu0.irp.f | 102 +++++++++++++++++++++------------------ 1 file changed, 55 insertions(+), 47 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 18004e02..e34ba3ce 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -344,50 +344,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(guided) - do sh=1,shortcut(0,1) - do sh2=sh,shortcut(0,1) - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1,1)-1 - end if - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh2,1),endi - org_j = sort_idx(j,1) - ext = exa - do ni=1,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - end do - if(ext <= 4) then - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) - st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) - enddo - endif - enddo - enddo - enddo - enddo - !$OMP END DO - !$OMP DO SCHEDULE(guided) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -410,16 +367,67 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) end do end do enddo - !$OMP END DO + !$OMP END DO NOWAIT + do sh=1,shortcut(0,1) + !$OMP DO SCHEDULE(static,1) + do sh2=sh,shortcut(0,1) + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if - !$OMP CRITICAL + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + if(sh==sh2) then + endi = i-1 + else + endi = shortcut(sh2+1,1)-1 + end if + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),endi + ext = exa + do ni=1,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) + st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + enddo + + !$OMP CRITICAL (u0Hu0) do istate=1,N_st do i=n,1,-1 v_0(i,istate) = v_0(i,istate) + vt(istate,i) s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo enddo - !$OMP END CRITICAL + !$OMP END CRITICAL (u0Hu0) deallocate(vt,st) !$OMP END PARALLEL From 8ef4332406326e1ae3d87d2a301f28c29874a37d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 15:50:28 +0100 Subject: [PATCH 092/188] Introduced CASSD ZMQ --- .travis.yml | 2 +- plugins/CAS_SD_ZMQ/README.rst | 14 + plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 234 ++++ plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f | 79 ++ plugins/CAS_SD_ZMQ/energy.irp.f | 11 + plugins/CAS_SD_ZMQ/ezfio_interface.irp.f | 4 + plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 156 +++ plugins/CAS_SD_ZMQ/selection.irp.f | 1202 ++++++++++++++++++ plugins/CAS_SD_ZMQ/selection_buffer.irp.f | 70 + plugins/CAS_SD_ZMQ/selection_types.f90 | 9 + plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES | 2 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 4 +- src/Integrals_Bielec/ao_bi_integrals.irp.f | 3 +- tests/bats/cassd.bats | 8 +- tests/bats/fci.bats | 6 +- tests/bats/pseudo.bats | 6 +- 16 files changed, 1794 insertions(+), 16 deletions(-) create mode 100644 plugins/CAS_SD_ZMQ/README.rst create mode 100644 plugins/CAS_SD_ZMQ/cassd_zmq.irp.f create mode 100644 plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f create mode 100644 plugins/CAS_SD_ZMQ/energy.irp.f create mode 100644 plugins/CAS_SD_ZMQ/ezfio_interface.irp.f create mode 100644 plugins/CAS_SD_ZMQ/run_selection_slave.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection_buffer.irp.f create mode 100644 plugins/CAS_SD_ZMQ/selection_types.f90 diff --git a/.travis.yml b/.travis.yml index 5e032609..40c09bbc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -26,7 +26,7 @@ python: script: - ./configure --production ./config/gfortran.cfg - - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD mrcepa0 All_singles + - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v diff --git a/plugins/CAS_SD_ZMQ/README.rst b/plugins/CAS_SD_ZMQ/README.rst new file mode 100644 index 00000000..45ba97e4 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/README.rst @@ -0,0 +1,14 @@ +========== +CAS_SD_ZMQ +========== + +Selected CAS+SD module with Zero-MQ parallelization. + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f new file mode 100644 index 00000000..eb2d911f --- /dev/null +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -0,0 +1,234 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: degree + + allocate (pt2(N_states)) + + pt2 = 1.d0 + diag_algorithm = "Lapack" + + if (N_det > N_det_max) then + call diagonalize_CI + call save_wavefunction + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + N_det = N_det_max + soft_touch N_det psi_det psi_coef + call diagonalize_CI + call save_wavefunction + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E+PT2 = ', CI_energy(k) + pt2(k) + print *, '-----' + enddo + endif + double precision :: E_CI_before(N_states) + + + integer :: n_det_before + print*,'Beginning the selection ...' + E_CI_before(1:N_states) = CI_energy(1:N_states) + + do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) + n_det_before = N_det + call ZMQ_selection(max(256-N_det, N_det), pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + if(N_states.gt.1)then + print*,'Variational Energy difference' + do i = 2, N_states + 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_states + print*,'Delta E = ',E_CI_before(i)+ pt2(i) - (E_CI_before(1) + pt2(1)) + enddo + endif + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + enddo + + integer :: exc_max, degree_min + exc_max = 0 + print *, 'CAS determinants : ', N_det_cas + do i=1,min(N_det_cas,10) + do k=i,N_det_cas + call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) + exc_max = max(exc_max,degree) + enddo + print *, psi_cas_coef(i,:) + call debug_det(psi_cas(1,1,i),N_int) + print *, '' + enddo + print *, 'Max excitation degree in the CAS :', exc_max + + if(do_pt2_end)then + print*,'Last iteration only to compute the PT2' + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + TOUCH threshold_selectors threshold_generators + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ZMQ_selection(0, pt2) + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1,N_states + print *, 'State', k + print *, 'PT2 = ', pt2 + print *, 'E = ', E_CI_before + print *, 'E+PT2 = ', E_CI_before+pt2 + print *, '-----' + enddo + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + endif + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + +end + + + + +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + + + if (.True.) then + PROVIDE pt2_e0_denominator + N = max(N_in,1) + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif + + integer :: i_generator, i_generator_start, i_generator_max, step +! step = int(max(1.,10*elec_num/mo_tot_num) + + step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) + step = max(1,step) + do i= N_det_generators, 1, -step + i_generator_start = max(i-step+1,1) + i_generator_max = i + write(task,*) i_generator_start, i_generator_max, 1, N + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif + endif +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,pt2_e0_denominator) +end + +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + done = 0 + more = 1 + pt2(:) = 0d0 + call CPU_TIME(time0) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + pt2 += pt2_mwen + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + end do + done += ntask + call CPU_TIME(time) +! print *, "DONE" , done, time - time0 + end do + + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + call sort_selection_buffer(b) +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f new file mode 100644 index 00000000..fec480f0 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/e_corr_selectors.irp.f @@ -0,0 +1,79 @@ + +use bitmasks + BEGIN_PROVIDER [integer, exc_degree_per_selectors, (N_det_selectors)] +&BEGIN_PROVIDER [integer, double_index_selectors, (N_det_selectors)] +&BEGIN_PROVIDER [integer, n_double_selectors] + implicit none + BEGIN_DOC + ! degree of excitation respect to Hartree Fock for the wave function + ! + ! for the all the selectors determinants + ! + ! double_index_selectors = list of the index of the double excitations + ! + ! n_double_selectors = number of double excitations in the selectors determinants + END_DOC + integer :: i,degree + n_double_selectors = 0 + do i = 1, N_det_selectors + call get_excitation_degree(psi_selectors(1,1,i),ref_bitmask,degree,N_int) + exc_degree_per_selectors(i) = degree + if(degree==2)then + n_double_selectors += 1 + double_index_selectors(n_double_selectors) =i + endif + enddo +END_PROVIDER + + BEGIN_PROVIDER[double precision, coef_hf_selector] + &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf] + &BEGIN_PROVIDER[double precision, inv_selectors_coef_hf_squared] + &BEGIN_PROVIDER[double precision, E_corr_per_selectors, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, i_H_HF_per_selectors, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, Delta_E_per_selector, (N_det_selectors)] + &BEGIN_PROVIDER[double precision, E_corr_double_only ] + &BEGIN_PROVIDER[double precision, E_corr_second_order ] + implicit none + BEGIN_DOC + ! energy of correlation per determinant respect to the Hartree Fock determinant + ! + ! for the all the double excitations in the selectors determinants + ! + ! E_corr_per_selectors(i) = * c(D_i)/c(HF) if |D_i> is a double excitation + ! + ! E_corr_per_selectors(i) = -1000.d0 if it is not a double excitation + ! + ! coef_hf_selector = coefficient of the Hartree Fock determinant in the selectors determinants + END_DOC + PROVIDE ref_bitmask_energy psi_selectors ref_bitmask N_int psi_selectors + integer :: i,degree + double precision :: hij,diag_H_mat_elem + E_corr_double_only = 0.d0 + E_corr_second_order = 0.d0 + do i = 1, N_det_selectors + if(exc_degree_per_selectors(i)==2)then + call i_H_j(ref_bitmask,psi_selectors(1,1,i),N_int,hij) + 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)) + elseif(exc_degree_per_selectors(i) == 0)then + coef_hf_selector = psi_selectors_coef(i,1) + E_corr_per_selectors(i) = -1000.d0 + Delta_E_per_selector(i) = 0.d0 + else + E_corr_per_selectors(i) = -1000.d0 + endif + enddo + if (dabs(coef_hf_selector) > 1.d-8) then + inv_selectors_coef_hf = 1.d0/coef_hf_selector + inv_selectors_coef_hf_squared = inv_selectors_coef_hf * inv_selectors_coef_hf + else + inv_selectors_coef_hf = 0.d0 + inv_selectors_coef_hf_squared = 0.d0 + endif + do i = 1,n_double_selectors + E_corr_per_selectors(double_index_selectors(i)) *=inv_selectors_coef_hf + enddo + E_corr_double_only = E_corr_double_only * inv_selectors_coef_hf + END_PROVIDER diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f new file mode 100644 index 00000000..4999c176 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/energy.irp.f @@ -0,0 +1,11 @@ +BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] + implicit none + BEGIN_DOC + ! E0 in the denominator of the PT2 + END_DOC + pt2_E0_denominator(:) = CI_electronic_energy(:) +! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') +END_PROVIDER + diff --git a/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f new file mode 100644 index 00000000..8adab518 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/ezfio_interface.irp.f @@ -0,0 +1,4 @@ +! DO NOT MODIFY BY HAND +! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py +! from file /home/scemama/quantum_package/src/CAS_SD_ZMQ/EZFIO.cfg + diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f new file mode 100644 index 00000000..36550116 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -0,0 +1,156 @@ + +subroutine run_selection_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf, buf2 + logical :: done + double precision :: pt2(N_states) + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + !call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + buf%N = 0 + ctask = 1 + pt2 = 0d0 + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_generator_start, i_generator_max, step, N + read (task,*) i_generator_start, i_generator_max, step, N + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*3, buf2) + else + if(N /= buf%N) stop "N changed... wtf man??" + end if + !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) + !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) + do i_generator=i_generator_start,i_generator_max,step + call select_connected(i_generator,energy,pt2,buf) + enddo + endif + + if(done .or. ctask == size(task_id)) then + if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + if(ctask > 0) then + call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) + do i=1,buf%cur + call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + enddo + call sort_selection_buffer(buf2) + buf%mini = buf2%mini + pt2 = 0d0 + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2(N_states) + type(selection_buffer), intent(inout) :: b + integer, intent(in) :: ntask, task_id(*) + integer :: rc + + call sort_selection_buffer(b) + + rc = f77_zmq_send( zmq_socket_push, b%cur, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + rc = f77_zmq_send( zmq_socket_push, pt2, 8*N_states, ZMQ_SNDMORE) + if(rc /= 8*N_states) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%val(1), 8*b%cur, ZMQ_SNDMORE) + if(rc /= 8*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, b%det(1,1,1), bit_kind*N_int*2*b%cur, ZMQ_SNDMORE) + if(rc /= bit_kind*N_int*2*b%cur) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "push" + +! Activate is zmq_socket_push is a REQ +! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) +end subroutine + + +subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2(N_states) + double precision, intent(out) :: val(*) + integer(bit_kind), intent(out) :: det(N_int, 2, *) + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2, N_states*8, 0) + if(rc /= 8*N_states) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, val(1), 8*N, 0) + if(rc /= 8*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, det(1,1,1), bit_kind*N_int*2*N, 0) + if(rc /= bit_kind*N_int*2*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id(1), ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! Activate is zmq_socket_pull is a REP +! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) +end subroutine + + + diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f new file mode 100644 index 00000000..6e7ba359 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -0,0 +1,1202 @@ +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end subroutine + + + +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + vect(istate, p1) + delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_selectors(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/selection_buffer.irp.f b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f new file mode 100644 index 00000000..2bcb11d3 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_buffer.irp.f @@ -0,0 +1,70 @@ + +subroutine create_selection_buffer(N, siz, res) + use selection_types + implicit none + + integer, intent(in) :: N, siz + type(selection_buffer), intent(out) :: res + + allocate(res%det(N_int, 2, siz), res%val(siz)) + + res%val = 0d0 + res%det = 0_8 + res%N = N + res%mini = 0d0 + res%cur = 0 +end subroutine + + +subroutine add_to_selection_buffer(b, det, val) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + integer(bit_kind), intent(in) :: det(N_int, 2) + double precision, intent(in) :: val + integer :: i + + if(dabs(val) >= b%mini) then + b%cur += 1 + b%det(:,:,b%cur) = det(:,:) + b%val(b%cur) = val + if(b%cur == size(b%val)) then + call sort_selection_buffer(b) + end if + end if +end subroutine + + +subroutine sort_selection_buffer(b) + use selection_types + implicit none + + type(selection_buffer), intent(inout) :: b + double precision, allocatable :: vals(:), absval(:) + integer, allocatable :: iorder(:) + integer(bit_kind), allocatable :: detmp(:,:,:) + integer :: i, nmwen + logical, external :: detEq + nmwen = min(b%N, b%cur) + + + allocate(iorder(b%cur), detmp(N_int, 2, nmwen), absval(b%cur), vals(nmwen)) + absval = -dabs(b%val(:b%cur)) + do i=1,b%cur + iorder(i) = i + end do + call dsort(absval, iorder, b%cur) + + do i=1, nmwen + detmp(:,:,i) = b%det(:,:,iorder(i)) + vals(i) = b%val(iorder(i)) + end do + b%det(:,:,:nmwen) = detmp(:,:,:) + b%det(:,:,nmwen+1:) = 0_bit_kind + b%val(:nmwen) = vals(:) + b%val(nmwen+1:) = 0d0 + b%mini = max(b%mini,dabs(b%val(b%N))) + b%cur = nmwen +end subroutine + diff --git a/plugins/CAS_SD_ZMQ/selection_types.f90 b/plugins/CAS_SD_ZMQ/selection_types.f90 new file mode 100644 index 00000000..9506629c --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_types.f90 @@ -0,0 +1,9 @@ +module selection_types + type selection_buffer + integer :: N, cur + integer(8), allocatable :: det(:,:,:) + double precision, allocatable :: val(:) + double precision :: mini + endtype +end module + diff --git a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES index cb6ff46e..7ff203d4 100644 --- a/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI_ZMQ/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full ZMQ Full_CI +Perturbation Selectors_full Generators_full ZMQ diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index e03db458..8b9488d2 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -79,7 +79,7 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_energy(CI_energy) + call ezfio_set_full_ci_zmq_energy(CI_energy) enddo if(do_pt2_end)then @@ -99,7 +99,7 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before+pt2 print *, '-----' enddo - call ezfio_set_full_ci_energy_pt2(E_CI_before+pt2) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2) endif call save_wavefunction end diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index d8a18437..68a7a050 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,8 +350,7 @@ 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 + PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 07d79f1a..44b44ee6 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -3,15 +3,15 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { - test_exe cas_sd_selected || skip + test_exe cassd_zmq || skip INPUT=h2o.ezfio qp_edit -c $INPUT ezfio set_file $INPUT ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 1000 + ezfio set determinants n_det_max 2000 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" - qp_run cas_sd_selected $INPUT - energy="$(ezfio get cas_sd energy)" + qp_run cassd_zmq $INPUT + energy="$(ezfio get cas_sd_zmq energy)" eq $energy -76.2221842108163 1.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 174c8f61..79ff91ab 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -20,7 +20,7 @@ function run_FCI() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq || skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -28,9 +28,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 8cccf229..a20b0842 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -23,7 +23,7 @@ function run_HF() { function run_FCI_ZMQ() { thresh=5.e-5 - test_exe full_ci || skip + test_exe fci_zmq|| skip qp_edit -c $1 ezfio set_file $1 ezfio set perturbation do_pt2_end True @@ -31,9 +31,9 @@ function run_FCI_ZMQ() { ezfio set davidson threshold_davidson 1.e-10 qp_run fci_zmq $1 - energy="$(ezfio get full_ci energy)" + energy="$(ezfio get full_ci_zmq energy)" eq $energy $3 $thresh - energy_pt2="$(ezfio get full_ci energy_pt2)" + energy_pt2="$(ezfio get full_ci_zmq energy_pt2)" eq $energy_pt2 $4 $thresh } From 5e1b0775761e333c2416a1f103d5c5dba1d096e2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:41:30 +0100 Subject: [PATCH 093/188] CAS_SD_ZMQ works with is_in_wavefunction --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 1 + plugins/CAS_SD_ZMQ/selection.irp.f | 12 +++++++++++- src/Determinants/H_apply.irp.f | 4 +++- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index eb2d911f..01e57649 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -164,6 +164,7 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() +call remove_duplicates_in_psi_det if (s2_eig) then call make_s2_eigenfunction endif diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 6e7ba359..39131520 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -202,6 +202,10 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(vect(1, p1) == 0d0) cycle call apply_particle(mask, sp, p1, det, ok, N_int) +logical, external :: is_in_wavefunction +if (is_in_wavefunction(det,N_int)) then + cycle +endif Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) max_e_pert = 0d0 @@ -218,7 +222,9 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert end do - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + endif end do end subroutine @@ -669,6 +675,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(banned(p1,p2)) cycle if(mat(1, p1, p2) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) +logical, external :: is_in_wavefunction +if (is_in_wavefunction(det,N_int)) then + cycle +endif Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 88affa21..411fe703 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -258,12 +258,14 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) k += 1 psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) psi_coef(k,:) = psi_coef_sorted_bit(i,:) + else + call debug_det(psi_det_sorted_bit(1,1,i),N_int) + stop 'duplicates in psi_det' endif enddo N_det = k call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') SOFT_TOUCH N_det psi_det psi_coef - stop 'duplicates in psi_det' endif deallocate (duplicate,bit_tmp) end From 1de1e540fe07abbf25d8e4b1b079f473b378349e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:48:46 +0100 Subject: [PATCH 094/188] Forgot file --- plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES diff --git a/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..ae599426 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/NEEDED_CHILDREN_MODULES @@ -0,0 +1,2 @@ +Generators_CAS Perturbation Selectors_CASSD ZMQ + From 576d4df3fb1128d3f581fc286d790dc42558425f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:49:22 +0100 Subject: [PATCH 095/188] Forgot file --- .../Selectors_CASSD/NEEDED_CHILDREN_MODULES | 1 + plugins/Selectors_CASSD/README.rst | 12 ++ plugins/Selectors_CASSD/selectors.irp.f | 95 ++++++++++++++ plugins/Selectors_CASSD/zmq.irp.f | 123 ++++++++++++++++++ 4 files changed, 231 insertions(+) create mode 100644 plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Selectors_CASSD/README.rst create mode 100644 plugins/Selectors_CASSD/selectors.irp.f create mode 100644 plugins/Selectors_CASSD/zmq.irp.f diff --git a/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/plugins/Selectors_CASSD/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ + diff --git a/plugins/Selectors_CASSD/README.rst b/plugins/Selectors_CASSD/README.rst new file mode 100644 index 00000000..19b4ec2b --- /dev/null +++ b/plugins/Selectors_CASSD/README.rst @@ -0,0 +1,12 @@ +=============== +Selectors_CASSD +=============== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f new file mode 100644 index 00000000..9263b706 --- /dev/null +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -0,0 +1,95 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, psi_selectors_size ] + implicit none + psi_selectors_size = psi_det_size +END_PROVIDER + +BEGIN_PROVIDER [ integer, N_det_selectors] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of selectors is 1 : the + ! Hartree-Fock determinant + END_DOC + N_det_selectors = N_det +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_selectors, (N_int,2,psi_selectors_size) ] +&BEGIN_PROVIDER [ double precision, psi_selectors_coef, (psi_selectors_size,N_states) ] + implicit none + BEGIN_DOC + ! Determinants on which we apply for perturbation. + END_DOC + integer :: i, k, l, m + logical :: good + + do i=1,N_det_generators + do k=1,N_int + psi_selectors(k,1,i) = psi_det_generators(k,1,i) + psi_selectors(k,2,i) = psi_det_generators(k,2,i) + enddo + enddo + do k=1,N_states + do i=1,N_det_selectors + psi_selectors_coef(i,k) = psi_coef_generators(i,k) + enddo + enddo + + m=N_det_generators + + do i=1,N_det + do l=1,n_cas_bitmask + good = .True. + do k=1,N_int + good = good .and. ( & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) + enddo + if (good) then + exit + endif + enddo + if (.not.good) then + m = m+1 + do k=1,N_int + psi_selectors(k,1,m) = psi_det_sorted(k,1,i) + psi_selectors(k,2,m) = psi_det_sorted(k,2,i) + enddo + psi_selectors_coef(m,:) = psi_coef_sorted(m,:) + endif + enddo + if (N_det /= m) then + print *, N_det, m + stop 'N_det /= m' + endif +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_coef_transp, (N_states,psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Transposed psi_selectors + END_DOC + integer :: i,k + + do i=1,N_det_selectors + do k=1,N_states + psi_selectors_coef_transp(k,i) = psi_selectors_coef(i,k) + enddo + enddo +END_PROVIDER + +BEGIN_PROVIDER [ double precision, psi_selectors_diag_h_mat, (psi_selectors_size) ] + implicit none + BEGIN_DOC + ! Diagonal elements of the H matrix for each selectors + END_DOC + integer :: i + double precision :: diag_H_mat_elem + do i = 1, N_det_selectors + psi_selectors_diag_h_mat(i) = diag_H_mat_elem(psi_selectors(1,1,i),N_int) + enddo +END_PROVIDER + + diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f new file mode 100644 index 00000000..8046212b --- /dev/null +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -0,0 +1,123 @@ +subroutine zmq_put_psi(zmq_to_qp_run_socket,worker_id, energy, size_energy) + use f77_zmq + implicit none + BEGIN_DOC +! Put the wave function on the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) + integer :: rc + character*(256) :: msg + + write(msg,*) 'put_psi ', worker_id, N_states, N_det, psi_det_size, n_det_generators, n_det_selectors + + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE) + if (rc /= len(trim(msg))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + if (rc /= psi_det_size*N_states*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:rc) /= 'put_psi_reply 1') then + print *, rc, trim(msg) + print *, 'Error in put_psi_reply' + stop 'error' + endif + +end + + + +subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) + use f77_zmq + implicit none + BEGIN_DOC +! Get the wave function from the qp_run scheduler + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket + integer, intent(in) :: worker_id + integer, intent(in) :: size_energy + double precision, intent(out) :: energy(size_energy) + integer :: rc + character*(64) :: msg + + write(msg,*) 'get_psi ', worker_id + + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:13) /= 'get_psi_reply') then + print *, rc, trim(msg) + print *, 'Error in get_psi_reply' + stop 'error' + endif + + integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_det_selectors_read, N_det_generators_read + read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & + N_det_generators_read, N_det_selectors_read + if (rc /= worker_id) then + print *, 'Wrong worker ID' + stop 'error' + endif + + N_states = N_states_read + N_det = N_det_read + psi_det_size = psi_det_size_read + TOUCH psi_det_size N_det N_states + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + if (rc /= psi_det_size*N_states*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' + stop 'error' + endif + TOUCH psi_det psi_coef + + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) + if (rc /= size_energy*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + if (N_det_generators_read > 0) then + N_det_generators = N_det_generators_read + TOUCH N_det_generators + endif + if (N_det_selectors_read > 0) then + N_det_selectors = N_det_selectors_read + TOUCH N_det_selectors + endif + +end + + From 9dcc0ba7d92ca07d1532519c7a35db825812a5b8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:55:33 +0100 Subject: [PATCH 096/188] Forgot file --- plugins/Full_CI_ZMQ/EZFIO.cfg | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 plugins/Full_CI_ZMQ/EZFIO.cfg diff --git a/plugins/Full_CI_ZMQ/EZFIO.cfg b/plugins/Full_CI_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..26f1a8e5 --- /dev/null +++ b/plugins/Full_CI_ZMQ/EZFIO.cfg @@ -0,0 +1,11 @@ +[energy] +type: double precision +doc: Calculated Selected FCI energy +interface: ezfio + +[energy_pt2] +type: double precision +doc: Calculated FCI energy + PT2 +interface: ezfio + + From 5e99f335ba5344a3f4cdc9308f380ebc65eedee4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 17:58:21 +0100 Subject: [PATCH 097/188] Forgot file --- plugins/CAS_SD_ZMQ/EZFIO.cfg | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 plugins/CAS_SD_ZMQ/EZFIO.cfg diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg new file mode 100644 index 00000000..7425c8ba --- /dev/null +++ b/plugins/CAS_SD_ZMQ/EZFIO.cfg @@ -0,0 +1,10 @@ +[energy] +type: double precision +doc: "Calculated CAS-SD energy" +interface: ezfio + +[energy_pt2] +type: double precision +doc: "Calculated selected CAS-SD energy with PT2 correction" +interface: ezfio + From 4bd6cdee2378ed3f19d56c3fd11e3dc1660f2cd0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 18:55:20 +0100 Subject: [PATCH 098/188] Updated tests --- tests/bats/cassd.bats | 4 ++-- tests/bats/mrcepa0.bats | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 44b44ee6..bbc2e1eb 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -8,10 +8,10 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_edit -c $INPUT ezfio set_file $INPUT ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 2000 + ezfio set determinants n_det_max 1000 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2221842108163 1.E-5 + eq $energy -76.2220702263996 1.E-5 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 8b56c606..77c1b756 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.23199784430074 1.e-4 + eq $energy -76.2318658231035 1.e-4 } From ecd9ffd48d0bc9f111e761f81fcc0e18fcf86f8f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:19:00 +0100 Subject: [PATCH 099/188] Removed QP_TASK_DEBUG in tests --- tests/run_tests.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 4664ce82..9e560d38 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -14,7 +14,7 @@ mrcepa0.bats export QP_PREFIX="timeout -s 9 300" -export QP_TASK_DEBUG=1 +#export QP_TASK_DEBUG=1 rm -rf work output From 40d5274daebefa652d2a8ba7d5634fa16260c48c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:32:53 +0100 Subject: [PATCH 100/188] logical comparisons with .eqv. --- .travis.yml | 2 +- plugins/FOBOCI/SC2_1h1p.irp.f | 2 +- plugins/loc_cele/loc_exchange_int.irp.f | 6 +++--- plugins/loc_cele/loc_exchange_int_act.irp.f | 2 +- plugins/loc_cele/loc_exchange_int_inact.irp.f | 2 +- plugins/loc_cele/loc_exchange_int_virt.irp.f | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 40c09bbc..57991ba3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,7 +25,7 @@ python: - "2.6" script: - - ./configure --production ./config/gfortran.cfg + - ./configure --production ./config/travis.cfg - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index b9378575..7733831c 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -210,7 +210,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni 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(out) :: diag_H_elements(0:dim_in) double precision, intent(in) :: convergence integer :: i,j,k,l diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index d7cc5c65..8bb47d89 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -14,7 +14,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb @@ -46,7 +46,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb @@ -78,7 +78,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index b9bbeb82..f332dd5d 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_inact.irp.f b/plugins/loc_cele/loc_exchange_int_inact.irp.f index 2ff3c85f..fcf20ced 100644 --- a/plugins/loc_cele/loc_exchange_int_inact.irp.f +++ b/plugins/loc_cele/loc_exchange_int_inact.irp.f @@ -14,7 +14,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb diff --git a/plugins/loc_cele/loc_exchange_int_virt.irp.f b/plugins/loc_cele/loc_exchange_int_virt.irp.f index 333f189b..8302b5d2 100644 --- a/plugins/loc_cele/loc_exchange_int_virt.irp.f +++ b/plugins/loc_cele/loc_exchange_int_virt.irp.f @@ -15,7 +15,7 @@ program loc_int exchange_int = 0.d0 iorder = 0 print*,'' - if(list_core_inact_check(iorb) == .False.)cycle + if(list_core_inact_check(iorb) .eqv. .False.)cycle do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb From 2b86f755278a07e144959dcdb01adee88d38a1c6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 19:43:07 +0100 Subject: [PATCH 101/188] Fixed travis tests --- plugins/CAS_SD_ZMQ/energy.irp.f | 6 +++--- plugins/Full_CI_ZMQ/energy.irp.f | 6 +++--- plugins/mrcepa0/mrcepa0_general.irp.f | 3 +-- tests/bats/cassd.bats | 2 +- tests/bats/foboci.bats | 8 ++++---- tests/bats/hf.bats | 14 +++++++------- tests/bats/mrcepa0.bats | 2 +- 7 files changed, 20 insertions(+), 21 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/energy.irp.f b/plugins/CAS_SD_ZMQ/energy.irp.f index 4999c176..db1e7d1a 100644 --- a/plugins/CAS_SD_ZMQ/energy.irp.f +++ b/plugins/CAS_SD_ZMQ/energy.irp.f @@ -3,9 +3,9 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(:) = CI_electronic_energy(:) -! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) +! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') END_PROVIDER diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f index 4999c176..db1e7d1a 100644 --- a/plugins/Full_CI_ZMQ/energy.irp.f +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -3,9 +3,9 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(:) = CI_electronic_energy(:) -! pt2_E0_denominator(:) = HF_energy - nuclear_repulsion -! pt2_E0_denominator(:) = barycentric_electronic_energy(:) + pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) +! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion +! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') END_PROVIDER diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index e3a2d1f5..25fe5f53 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -31,7 +31,6 @@ subroutine run(N_st,energy) call write_double(6,ci_energy_dressed(1),"Final MRCC energy") call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) call save_wavefunction - energy(:) = ci_energy_dressed(:) else E_new = 0.d0 delta_E = 1.d0 @@ -55,8 +54,8 @@ subroutine run(N_st,energy) endif enddo call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) endif + energy(1:N_st) = ci_energy_dressed(1:N_st) end diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index bbc2e1eb..8e960b41 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -12,6 +12,6 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2220702263996 1.E-5 + eq $energy -76.2221338928418 1.E-5 } diff --git a/tests/bats/foboci.bats b/tests/bats/foboci.bats index 98255969..08032072 100644 --- a/tests/bats/foboci.bats +++ b/tests/bats/foboci.bats @@ -19,9 +19,9 @@ function run_all_1h_1p() { #=== DHNO -@test "all_1h_1p DHNO chipman-dzp" { - qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio - run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 -} +#@test "all_1h_1p DHNO chipman-dzp" { +# qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio +# run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 +#} diff --git a/tests/bats/hf.bats b/tests/bats/hf.bats index e280c986..3b9b1acd 100644 --- a/tests/bats/hf.bats +++ b/tests/bats/hf.bats @@ -23,13 +23,13 @@ function run_HF() { #=== DHNO -@test "init DHNO chipman-dzp" { - run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio -} - -@test "SCF DHNO chipman-dzp" { - run_HF dhno.ezfio -130.4278777822 -} +#@test "init DHNO chipman-dzp" { +# run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio +#} +# +#@test "SCF DHNO chipman-dzp" { +# run_HF dhno.ezfio -130.4278777822 +#} #=== HBO @test "init HBO STO-3G" { diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 77c1b756..48b2d360 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2318658231035 1.e-4 + eq $energy -76.231997363623 1.e-4 } From 2b6a0b6c65159c171676b2b69ee23c1c253bab3b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 20:07:04 +0100 Subject: [PATCH 102/188] Added travis.cfg --- config/travis.cfg | 62 +++++++++++++++++++++++++++++++++++++++++ tests/bats/cassd.bats | 2 +- tests/bats/foboci.bats | 8 +++--- tests/bats/hf.bats | 14 +++++----- tests/bats/mrcepa0.bats | 8 +++--- 5 files changed, 78 insertions(+), 16 deletions(-) create mode 100644 config/travis.cfg diff --git a/config/travis.cfg b/config/travis.cfg new file mode 100644 index 00000000..024e330b --- /dev/null +++ b/config/travis.cfg @@ -0,0 +1,62 @@ +# Common flags +############## +# +# -ffree-line-length-none : Needed for IRPF90 which produces long lines +# -lblas -llapack : Link with libblas and liblapack libraries provided by the system +# -I . : Include the curent directory (Mandatory) +# +# --ninja : Allow the utilisation of ninja. (Mandatory) +# --align=32 : Align all provided arrays on a 32-byte boundary +# +# +[COMMON] +FC : gfortran -ffree-line-length-none -I . -g +LAPACK_LIB : -llapack -lblas +IRPF90 : irpf90 +IRPF90_FLAGS : --ninja --align=32 + +# Global options +################ +# +# 1 : Activate +# 0 : Deactivate +# +[OPTION] +MODE : OPT ; [ OPT | PROFILE | DEBUG ] : Chooses the section below +CACHE : 1 ; Enable cache_compile.py +OPENMP : 1 ; Append OpenMP flags + +# Optimization flags +#################### +# +# -Ofast : Disregard strict standards compliance. Enables all -O3 optimizations. +# It also enables optimizations that are not valid +# for all standard-compliant programs. It turns on +# -ffast-math and the Fortran-specific +# -fno-protect-parens and -fstack-arrays. +[OPT] +FCFLAGS : -Ofast -march=native + +# Profiling flags +################# +# +[PROFILE] +FC : -p -g +FCFLAGS : -Ofast + +# Debugging flags +################# +# +# -fcheck=all : Checks uninitialized variables, array subscripts, etc... +# -g : Extra debugging information +# +[DEBUG] +FCFLAGS : -fcheck=all -g + +# OpenMP flags +################# +# +[OPENMP] +FC : -fopenmp +IRPF90_FLAGS : --openmp + diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 8e960b41..151997d2 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -12,6 +12,6 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2221338928418 1.E-5 + eq $energy -76.2219518185432 1.E-5 } diff --git a/tests/bats/foboci.bats b/tests/bats/foboci.bats index 08032072..98255969 100644 --- a/tests/bats/foboci.bats +++ b/tests/bats/foboci.bats @@ -19,9 +19,9 @@ function run_all_1h_1p() { #=== DHNO -#@test "all_1h_1p DHNO chipman-dzp" { -# qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio -# run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 -#} +@test "all_1h_1p DHNO chipman-dzp" { + qp_set_mo_class -inact "[1-8]" -act "[9]" -virt "[10-64]" dhno.ezfio + run_all_1h_1p dhno.ezfio 10000 0.0000000001 -130.4466283766202 +} diff --git a/tests/bats/hf.bats b/tests/bats/hf.bats index 3b9b1acd..e280c986 100644 --- a/tests/bats/hf.bats +++ b/tests/bats/hf.bats @@ -23,13 +23,13 @@ function run_HF() { #=== DHNO -#@test "init DHNO chipman-dzp" { -# run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio -#} -# -#@test "SCF DHNO chipman-dzp" { -# run_HF dhno.ezfio -130.4278777822 -#} +@test "init DHNO chipman-dzp" { + run_init dhno.xyz "-b chipman-dzp -m 2" dhno.ezfio +} + +@test "SCF DHNO chipman-dzp" { + run_HF dhno.ezfio -130.4278777822 +} #=== HBO @test "init HBO STO-3G" { diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 48b2d360..ef752b6b 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22903276183061 1.e-4 + eq $energy -76.22880979516251 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -33,7 +33,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22899302846875 1.e-4 + eq $energy -76.22879934337525 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -49,7 +49,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22647345292708 1.e-4 + eq $energy -76.2262119300426 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.231997363623 1.e-4 + eq $energy -76.2315759851904 1.e-4 } From 9a9c5037bb1315ff5adf99136bcb09d7dd5084a3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 20:20:42 +0100 Subject: [PATCH 103/188] Fixed tests --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 1 - tests/bats/cassd.bats | 15 ++++++++++++--- tests/bats/mrcepa0.bats | 16 ++++++++-------- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 01e57649..eb2d911f 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -164,7 +164,6 @@ subroutine ZMQ_selection(N_in, pt2) if (N_in > 0) then call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN call copy_H_apply_buffer_to_wf() -call remove_duplicates_in_psi_det if (s2_eig) then call make_s2_eigenfunction endif diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 151997d2..a1f1a736 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -5,13 +5,22 @@ source $QP_ROOT/tests/bats/common.bats.sh @test "CAS_SD H2O cc-pVDZ" { test_exe cassd_zmq || skip INPUT=h2o.ezfio + rm -rf work/h2o.ezfio/determinants/ qp_edit -c $INPUT ezfio set_file $INPUT - ezfio set perturbation do_pt2_end False - ezfio set determinants n_det_max 1000 + ezfio set perturbation do_pt2_end True + ezfio set determinants n_det_max 16384 qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT + energy="$(ezfio get cas_sd_zmq energy_pt2)" + eq $energy -76.2311177912495 2.E-5 + + ezfio set determinants n_det_max 2048 + ezfio set determinants read_wf True + ezfio set perturbation do_pt2_end True + qp_run cassd_zmq $INPUT + ezfio set determinants read_wf False energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2219518185432 1.E-5 + eq $energy -76.2300888408526 2.E-5 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index ef752b6b..ed69681f 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -15,8 +15,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22880979516251 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238562120457431 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,8 +32,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.22879934337525 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.238527498388962 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,8 +48,8 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2262119300426 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.235833732594187 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,7 +64,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT - energy="$(ezfio get mrcepa0 energy)" - eq $energy -76.2315759851904 1.e-4 + energy="$(ezfio get mrcepa0 energy_pt2)" + eq $energy -76.2418799284763 1.e-4 } From 80d0a9420e6d9fdfbebeb0243958b78d4db2fae6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 14 Nov 2016 23:57:23 +0100 Subject: [PATCH 104/188] Corrected some bugs in MRCC --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 6 +-- plugins/MRCC_Utils/amplitudes.irp.f | 9 ++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 83 +++++++++++++++-------------- plugins/mrcepa0/dressing.irp.f | 58 +++++++++++--------- 4 files changed, 90 insertions(+), 66 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index eb2d911f..92e7fe55 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -99,9 +99,9 @@ program fci_zmq print *, 'N_states = ', N_states do k=1,N_states print *, 'State', k - print *, 'PT2 = ', pt2 - print *, 'E = ', E_CI_before - print *, 'E+PT2 = ', E_CI_before+pt2 + print *, 'PT2 = ', pt2(k) + print *, 'E = ', E_CI_before(k) + print *, 'E+PT2 = ', E_CI_before(k)+pt2(k) print *, '-----' enddo call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 053527f7..82736b8f 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -191,6 +191,15 @@ END_PROVIDER end if end do + if (a_col == at_row) then + t(:) = t(:) + 1.d0 + endif + if (sum(dabs(t(:))) > 0.d0) then + wk = wk+1 + A_ind_mwen(wk) = a_col + A_val_mwen(:,wk) = t(:) + endif + end do if(wk /= 0) then diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 7005fa19..8b72ed29 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -77,18 +77,18 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] END_PROVIDER - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] - implicit none - BEGIN_DOC - ! Dressing matrix in N_det basis - END_DOC - integer :: i,j,m - delta_ij = 0.d0 - delta_ii = 0.d0 - call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) - -END_PROVIDER +! BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] +! implicit none +! BEGIN_DOC +! ! Dressing matrix in N_det basis +! END_DOC +! integer :: i,j,m +! delta_ij = 0.d0 +! delta_ii = 0.d0 +! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) +! +!END_PROVIDER BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] @@ -139,7 +139,6 @@ END_PROVIDER integer :: mrcc_state - mrcc_state = N_states do j=1,min(N_states,N_det) do i=1,N_det CI_eigenvectors_dressed(i,j) = psi_coef(i,j) @@ -148,16 +147,28 @@ END_PROVIDER if (diag_algorithm == "Davidson") then -! call davidson_diag_mrcc(psi_det,CI_eigenvectors_dressed,CI_electronic_energy_dressed,& -! size(CI_eigenvectors_dressed,1),N_det,N_states,N_states_diag,N_int,output_determinants,mrcc_state) - - call davidson_diag_mrcc_HS2(psi_det,CI_eigenvectors_dressed,& - size(CI_eigenvectors_dressed,1), & - CI_electronic_energy_dressed,N_det,N_states,N_states_diag,N_int, & - output_determinants,mrcc_state) - + allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & + eigenvalues(size(CI_electronic_energy_dressed,1))) + do mrcc_state=N_states,1,-1 + do j=1,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& + size(eigenvectors,1), & + eigenvalues,N_det,N_states,N_states_diag,N_int, & + output_determinants,mrcc_state) + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + do mrcc_state=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& - N_states_diag,size(CI_eigenvectors_dressed,1)) + N_states_diag,size(CI_eigenvectors_dressed,1)) + deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -628,12 +639,12 @@ END_PROVIDER double precision :: phase - double precision, allocatable :: rho_mrcc_init(:,:) + double precision, allocatable :: rho_mrcc_init(:) integer :: a_coll, at_roww print *, "TI", hh_nex, N_det_non_ref - allocate(rho_mrcc_init(N_det_non_ref, N_states)) + allocate(rho_mrcc_init(N_det_non_ref)) allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) x = 0d0 @@ -644,9 +655,8 @@ END_PROVIDER AtB(:) = 0.d0 !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & - !$OMP private(at_row, a_col, t, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& + !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) - allocate(A_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states)) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex @@ -655,11 +665,11 @@ END_PROVIDER AtB(at_row) = AtB(at_row) + psi_non_ref_coef(active_excitation_to_determinants_idx(i, at_roww), s) * active_excitation_to_determinants_val(s,i, at_roww) end do end do - !$OMP END DO NOWAIT - deallocate (A_ind_mwen, A_val_mwen) + !$OMP END DO + !$OMP END PARALLEL - x = 0d0 + X(:) = 0d0 do a_coll = 1, n_exc_active @@ -669,10 +679,7 @@ END_PROVIDER rho_mrcc_init = 0d0 - !$OMP PARALLEL default(shared) & - !$OMP private(lref, hh, pp, II, myMask, myDet, ok, ind, phase) allocate(lref(N_det_ref)) - !$OMP DO schedule(static, 1) do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) cycle @@ -694,16 +701,14 @@ END_PROVIDER X(pp) = AtB(pp) / X(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II),s) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II),s) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do - !$OMP END DO deallocate(lref) - !$OMP END PARALLEL x_new = x @@ -716,9 +721,9 @@ END_PROVIDER !$OMP DO do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i,s) + rho_mrcc(i,s) = rho_mrcc_init(i) enddo - !$OMP END DO + !$OMP END DO NOWAIT !$OMP DO do a_coll = 1, n_exc_active @@ -928,7 +933,7 @@ END_PROVIDER ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant - dIj_unique(:size(X), s) = X(:) + dIj_unique(1:size(X), s) = X(1:size(X)) end do END_PROVIDER diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 3646b0b2..9f041cd3 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -317,43 +317,53 @@ end &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] use bitmasks implicit none - integer :: i, j, i_state + integer :: i, j, i_state !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - do i_state = 1, N_states - if(mrmode == 3) then + if(mrmode == 3) then do i = 1, N_det_ref - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do i_state = 1, N_states + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + enddo do j = 1, N_det_non_ref - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + do i_state = 1, N_states + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + enddo end do end do -! -! do i = 1, N_det_ref -! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) -! do j = 1, N_det_non_ref -! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) -! end do -! end do - else if(mrmode == 2) then - do i = 1, N_det_ref + ! + ! do i = 1, N_det_ref + ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) + ! do j = 1, N_det_non_ref + ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) + ! end do + ! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) - do j = 1, N_det_non_ref + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - end do + enddo end do - else if(mrmode == 1) then - do i = 1, N_det_ref + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - do j = 1, N_det_non_ref + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - end do + enddo end do - else - stop "invalid mrmode" - end if - end do + end do + else + stop "invalid mrmode" + end if END_PROVIDER From c366c201eb33cc75b8057a8416763236dfdd3ae3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 10:32:57 +0100 Subject: [PATCH 105/188] Corrected bug for multi-state MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 10 ++++++---- plugins/Psiref_Utils/psi_ref_utils.irp.f | 4 ++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 8b72ed29..281b6760 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -684,6 +684,8 @@ END_PROVIDER do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) cycle lref = 0 + AtB(pp) = 0.d0 + X(pp) = 0.d0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) if(.not. ok) cycle @@ -693,12 +695,12 @@ END_PROVIDER if(ind == -1) cycle ind = psi_non_ref_sorted_idx(ind) call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) += psi_ref_coef(II,s)**2 + X(pp) = X(pp) + psi_ref_coef(II,s)*psi_ref_coef(II,s) AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase lref(II) = ind - if(phase < 0d0) lref(II) = -ind + if(phase < 0.d0) lref(II) = -ind end do - X(pp) = AtB(pp) / X(pp) + X(pp) = AtB(pp) do II=1,N_det_ref if(lref(II) > 0) then rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) @@ -709,7 +711,7 @@ END_PROVIDER end do end do deallocate(lref) - + x_new = x double precision :: factor, resold diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index 41db2f10..c4147ebc 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -97,6 +97,10 @@ END_PROVIDER endif enddo N_det_non_ref = i_non_ref + if (N_det_non_ref < 1) then + print *, 'Error : All determinants are in the reference' + stop -1 + endif END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_non_ref_restart, (N_int,2,psi_det_size) ] From ee658adeb707eda79a38321b59bbab8e30e575dd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 11:23:00 +0100 Subject: [PATCH 106/188] State following in MRCC --- plugins/MRCC_Utils/davidson.irp.f | 72 +++++++++++++++++------------ plugins/MRCC_Utils/mrcc_utils.irp.f | 14 +++--- 2 files changed, 50 insertions(+), 36 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 9d5e8a67..d8b0a2c3 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -628,7 +628,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -688,16 +688,17 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax,N_st_diag*itermax), & lambda(N_st_diag*itermax)) h = 0.d0 @@ -795,26 +796,39 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo - if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + ! Compute overlap with U_in + ! ------------------------- + + integer :: coord(2), order(N_st) + overlap = -1.d0 + do k=1,N_st + do i=1,shift2 + overlap(i,k) = dabs(y(i,k)) enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo - endif + enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(coord(1),coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo ! Express eigenvectors of h in the determinant basis diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 281b6760..0735980d 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -149,7 +149,7 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) - do mrcc_state=N_states,1,-1 + do mrcc_state=1,N_states do j=1,min(N_states,N_det) do i=1,N_det eigenvectors(i,j) = psi_coef(i,j) @@ -161,10 +161,12 @@ END_PROVIDER output_determinants,mrcc_state) CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) - enddo - do mrcc_state=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + if (mrcc_state == 1) then + do mrcc_state=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + endif enddo call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) @@ -685,7 +687,6 @@ END_PROVIDER if(is_active_exc(pp)) cycle lref = 0 AtB(pp) = 0.d0 - X(pp) = 0.d0 do II=1,N_det_ref call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) if(.not. ok) cycle @@ -695,7 +696,6 @@ END_PROVIDER if(ind == -1) cycle ind = psi_non_ref_sorted_idx(ind) call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) - X(pp) = X(pp) + psi_ref_coef(II,s)*psi_ref_coef(II,s) AtB(pp) += psi_non_ref_coef(ind, s) * psi_ref_coef(II, s) * phase lref(II) = ind if(phase < 0.d0) lref(II) = -ind From b13e351f59a98f123b1af50141567a4cb1c6d8bd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 11:35:15 +0100 Subject: [PATCH 107/188] Fixed MRCC --- plugins/MRCC_Utils/mrcc_dummy.irp.f | 4 ---- plugins/MRCC_Utils/mrcc_utils.irp.f | 6 +++--- 2 files changed, 3 insertions(+), 7 deletions(-) delete mode 100644 plugins/MRCC_Utils/mrcc_dummy.irp.f diff --git a/plugins/MRCC_Utils/mrcc_dummy.irp.f b/plugins/MRCC_Utils/mrcc_dummy.irp.f deleted file mode 100644 index 8f1deda8..00000000 --- a/plugins/MRCC_Utils/mrcc_dummy.irp.f +++ /dev/null @@ -1,4 +0,0 @@ -program pouet - - -end diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 0735980d..8ad922cf 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -162,9 +162,9 @@ END_PROVIDER CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) if (mrcc_state == 1) then - do mrcc_state=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + do k=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) + CI_electronic_energy_dressed(k) = eigenvalues(k) enddo endif enddo From 83ff5065b9cb16648819170dd0304c7189d03d2f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 17:40:14 +0100 Subject: [PATCH 108/188] Corrected bug in CAS_SD --- plugins/CAS_SD_ZMQ/selection.irp.f | 5 ----- plugins/Selectors_CASSD/selectors.irp.f | 6 +++--- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 39131520..f90ee488 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -202,11 +202,6 @@ subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, if(vect(1, p1) == 0d0) cycle call apply_particle(mask, sp, p1, det, ok, N_int) -logical, external :: is_in_wavefunction -if (is_in_wavefunction(det,N_int)) then - cycle -endif - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) max_e_pert = 0d0 diff --git a/plugins/Selectors_CASSD/selectors.irp.f b/plugins/Selectors_CASSD/selectors.irp.f index 9263b706..ab36527d 100644 --- a/plugins/Selectors_CASSD/selectors.irp.f +++ b/plugins/Selectors_CASSD/selectors.irp.f @@ -42,9 +42,9 @@ END_PROVIDER good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det_sorted(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det_sorted(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -57,7 +57,7 @@ END_PROVIDER psi_selectors(k,1,m) = psi_det_sorted(k,1,i) psi_selectors(k,2,m) = psi_det_sorted(k,2,i) enddo - psi_selectors_coef(m,:) = psi_coef_sorted(m,:) + psi_selectors_coef(m,:) = psi_coef_sorted(i,:) endif enddo if (N_det /= m) then From 508670f6935ad2ffbfa2496dd96577b431ff303b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 15 Nov 2016 18:39:44 +0100 Subject: [PATCH 109/188] Corrected bug in multi-state MRCC --- plugins/MRCC_Utils/davidson.irp.f | 49 +++++++++++++++----------- plugins/MRCC_Utils/mrcc_utils.irp.f | 3 ++ plugins/mrcepa0/mrcc.irp.f | 10 +++++- plugins/mrcepa0/mrcepa0.irp.f | 12 ++++++- plugins/mrcepa0/mrcepa0_general.irp.f | 1 - plugins/mrcepa0/mrsc2.irp.f | 10 +++++- src/Davidson/diagonalization_hs2.irp.f | 14 ++------ 7 files changed, 63 insertions(+), 36 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index d8b0a2c3..8e0af39e 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -678,14 +678,6 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, external :: align_double sze_8 = align_double(sze) - double precision :: delta - - if (s2_eig) then - delta = 1.d0 - else - delta = 0.d0 - endif - itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & W(sze_8,N_st_diag*itermax), & @@ -722,24 +714,17 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz converged = .False. double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 + do k=N_st+1,N_st_diag do i=1,sze call random_number(r1) call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 u_in(i,k) = r1*dcos(r2) - u_in(i,k+1) = r1*dsin(r2) enddo enddo - do k=N_st_diag-1,N_st_diag - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo @@ -796,14 +781,36 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + ! Compute overlap with U_in ! ------------------------- - integer :: coord(2), order(N_st) + integer :: coord(2), order(N_st_diag) overlap = -1.d0 - do k=1,N_st + do k=1,shift2 do i=1,shift2 - overlap(i,k) = dabs(y(i,k)) + overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 8ad922cf..f28ccf25 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -924,6 +924,9 @@ END_PROVIDER norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) + if (dsqrt(norm) > 1.d0) then + stop 'Error : Norm of the SD larger than the norm of the reference.' + endif do i=1,N_det_ref norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index 91592e62..a28d4be3 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -8,8 +8,16 @@ program mrsc2sub read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0.irp.f b/plugins/mrcepa0/mrcepa0.irp.f index 34d3dec5..aeacbb39 100644 --- a/plugins/mrcepa0/mrcepa0.irp.f +++ b/plugins/mrcepa0/mrcepa0.irp.f @@ -8,8 +8,18 @@ program mrcepa0 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif + call print_cas_coefs + call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 25fe5f53..09c35e52 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -17,7 +17,6 @@ subroutine run(N_st,energy) double precision, allocatable :: lambda(:) allocate (lambda(N_states)) - thresh_mrcc = thresh_dressed_ci n_it_mrcc_max = n_it_max_dressed_ci diff --git a/plugins/mrcepa0/mrsc2.irp.f b/plugins/mrcepa0/mrsc2.irp.f index d0f44a33..948b1b5c 100644 --- a/plugins/mrcepa0/mrsc2.irp.f +++ b/plugins/mrcepa0/mrsc2.irp.f @@ -7,8 +7,16 @@ program mrsc2 mrmode = 2 read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles + if (.True.) then + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors(i,j) + enddo + enddo + TOUCH psi_coef + endif call run(N_states,energy) if(do_pt2_end)then call run_pt2(N_states,energy) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index fddac471..102dcfb8 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -183,24 +183,16 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. double precision :: r1, r2 - do k=N_st+1,N_st_diag-2,2 + do k=N_st+1,N_st_diag do i=1,sze call random_number(r1) - call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 u_in(i,k) = r1*dcos(r2) - u_in(i,k+1) = r1*dsin(r2) enddo enddo - do k=N_st_diag-1,N_st_diag - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) enddo From 3c230b42feec3eca2daf6f77c459b9360133c2f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 10:17:37 +0100 Subject: [PATCH 110/188] Introduced davidson_diag_hjj_sjj_mmap --- src/Davidson/diagonalization_hs2.irp.f | 326 +++++++++++++++++++++++++ src/Davidson/u0Hu0.irp.f | 2 +- src/Utils/LinearAlgebra.irp.f | 29 ++- 3 files changed, 355 insertions(+), 2 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 102dcfb8..c3785d7f 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -46,6 +46,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END PARALLEL call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) +! call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) do i=1,N_st_diag s2_out(i) = S2_jj(i) enddo @@ -345,3 +346,328 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end +subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + use bitmasks + use mmap_module + implicit none + BEGIN_DOC + ! Davidson diagonalization with specific diagonal elements of the H matrix + ! + ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson + ! + ! S2_jj : specific diagonal S^2 matrix elements + ! + ! dets_in : bitmasks corresponding to determinants + ! + ! u_in : guess coefficients on the various states. Overwritten + ! on exit + ! + ! dim_in : leftmost dimension of u_in + ! + ! sze : Number of determinants + ! + ! N_st : Number of eigenstates + ! + ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze + ! + ! iunit : Unit for the I/O + ! + ! Initial guess vectors are not necessarily orthonormal + END_DOC + integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint + integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) + double precision, intent(in) :: H_jj(sze) + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit + double precision, intent(inout) :: u_in(dim_in,N_st_diag) + double precision, intent(out) :: energies(N_st_diag) + + integer :: sze_8 + integer :: iter + integer :: i,j,k,l,m + logical :: converged + + double precision :: u_dot_v, u_dot_u + + integer :: k_pairs, kl + + integer :: iter2 + double precision, pointer :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) + double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) + double precision :: diag_h_mat_elem + double precision, allocatable :: residual_norm(:) + character*(16384) :: write_buffer + double precision :: to_print(3,N_st) + double precision :: cpu, wall + integer :: shift, shift2, itermax + include 'constants.include.F' + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 + endif + + PROVIDE nuclear_repulsion expected_s2 + + call write_time(iunit) + call wall_time(wall) + call cpu_time(cpu) + write(iunit,'(A)') '' + write(iunit,'(A)') 'Davidson Diagonalization' + write(iunit,'(A)') '------------------------' + write(iunit,'(A)') '' + call write_int(iunit,N_st,'Number of states') + call write_int(iunit,N_st_diag,'Number of states in diagonalization') + call write_int(iunit,sze,'Number of determinants') + write(iunit,'(A)') '' + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = ' Iter' + do i=1,N_st + write_buffer = trim(write_buffer)//' Energy S^2 Residual' + enddo + write(iunit,'(A)') trim(write_buffer) + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + + integer, external :: align_double + integer :: fd(3) + type(c_ptr) :: c_pointer(3) + sze_8 = align_double(sze) + + itermax = min(davidson_sze_max, sze/N_st_diag) + + call mmap( & + trim(ezfio_work_dir)//'U', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(1), .False., c_pointer(1)) + call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'W', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(2), .False., c_pointer(2)) + call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) + + call mmap( & + trim(ezfio_work_dir)//'S', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(3), .False., c_pointer(3)) + call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) + + allocate( & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + residual_norm(N_st_diag), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + lambda(N_st_diag*itermax)) + + h = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 + U = 0.d0 + W = 0.d0 + S = 0.d0 + y = 0.d0 + + + ASSERT (N_st > 0) + ASSERT (N_st_diag >= N_st) + ASSERT (sze > 0) + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + ! Davidson iterations + ! =================== + + converged = .False. + + double precision :: r1, r2 + do k=N_st+1,N_st_diag + do i=1,sze + call random_number(r1) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo + enddo + do k=1,N_st_diag + call normalize(u_in(1,k),sze) + enddo + + + do while (.not.converged) + + do k=1,N_st_diag + do i=1,sze + U(i,k) = u_in(i,k) + enddo + enddo + + do iter=1,itermax-1 + + shift = N_st_diag*(iter-1) + shift2 = N_st_diag*iter + + call ortho_qr(U,size(U,1),sze,shift2) + + ! Compute |W_k> = \sum_i |i> + ! ----------------------------------------- + + +! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + + + ! Compute h_kl = = + ! ------------------------------------------- + + do k=1,iter + shift = N_st_diag*(k-1) + call dgemm('T','N', N_st_diag, shift2, sze, & + 1.d0, U(1,shift+1), size(U,1), W, size(W,1), & + 0.d0, h(shift+1,1), size(h,1)) + + call dgemm('T','N', N_st_diag, shift2, sze, & + 1.d0, U(1,shift+1), size(U,1), S, size(S,1), & + 0.d0, s_(shift+1,1), size(s_,1)) + enddo + + + ! Diagonalize h + ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) + + ! Compute S2 for each eigenvector + ! ------------------------------- + + call dgemm('N','N',shift2,shift2,shift2, & + 1.d0, s_, size(s_,1), y, size(y,1), & + 0.d0, s_tmp, size(s_tmp,1)) + + call dgemm('T','N',shift2,shift2,shift2, & + 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & + 0.d0, s_, size(s_,1)) + + + + do k=1,shift2 + s2(k) = s_(k,k) + S_z2_Sz + enddo + + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + endif + + + ! Express eigenvectors of h in the determinant basis + ! -------------------------------------------------- + + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) + + ! Compute residual vector and davidson step + ! ----------------------------------------- + + do k=1,N_st_diag + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + if (k <= N_st) then + residual_norm(k) = u_dot_u(U(1,shift2+k),sze) + to_print(1,k) = lambda(k) + nuclear_repulsion + to_print(2,k) = s2(k) + to_print(3,k) = residual_norm(k) + endif + enddo + + write(iunit,'(X,I3,X,100(X,F16.10,X,F11.6,X,E11.3))') iter, to_print(1:3,1:N_st) + call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) + do k=1,N_st + if (residual_norm(k) > 1.e8) then + print *, '' + stop 'Davidson failed' + endif + enddo + if (converged) then + exit + endif + + enddo + + ! Re-contract to u_in + ! ----------- + + call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & + U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + + enddo + + do k=1,N_st_diag + energies(k) = lambda(k) + S2_jj(k) = s2(k) + enddo + write_buffer = '===== ' + do i=1,N_st + write_buffer = trim(write_buffer)//' ================ =========== ===========' + enddo + write(iunit,'(A)') trim(write_buffer) + write(iunit,'(A)') '' + call write_time(iunit) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(1), c_pointer(1)) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(2), c_pointer(2)) + + call munmap( & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + 8, fd(3), c_pointer(3)) + + deallocate ( & + residual_norm, & + c, & + h, & + y, s_, s_tmp, & + lambda & + ) +end + diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index e34ba3ce..dd5ab1ab 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -422,7 +422,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP CRITICAL (u0Hu0) do istate=1,N_st - do i=n,1,-1 + do i=1,n v_0(i,istate) = v_0(i,istate) + vt(istate,i) s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 9c3b35b5..98845592 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -150,7 +150,7 @@ subroutine ortho_qr(A,LDA,m,n) LWORK=-1 ! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - LWORK=WORK(1) + LWORK=2*WORK(1) deallocate(WORK) allocate(WORK(LWORK)) ! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) @@ -159,6 +159,33 @@ subroutine ortho_qr(A,LDA,m,n) deallocate(WORK,jpvt,tau) end +subroutine ortho_qr_unblocked(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + double precision, intent(inout) :: A(LDA,n) + + integer :: info + integer, allocatable :: jpvt(:) + double precision, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(n)) + call dgeqr2( m, n, A, LDA, TAU, WORK, INFO ) + call dorg2r(m, n, n, A, LDA, tau, WORK, INFO) + deallocate(WORK,jpvt,tau) +end + subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) implicit none BEGIN_DOC From 9e88e7f0de2063b5a25ad105492016c0118222c6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 10:37:35 +0100 Subject: [PATCH 111/188] Put davdison_sze_max in EZFIO --- src/Davidson/EZFIO.cfg | 7 ++++++- src/Davidson/parameters.irp.f | 18 ------------------ src/Utils/LinearAlgebra.irp.f | 2 -- 3 files changed, 6 insertions(+), 21 deletions(-) diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 415e359e..b7c67465 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -6,7 +6,12 @@ default: 1.e-12 [n_states_diag] type: States_number -doc: n_states_diag +doc: Number of states to consider during the Davdison diagonalization default: 10 interface: ezfio,provider,ocaml +[davidson_sze_max] +type: Strictly_positive_int +doc: Number of micro-iterations before re-contracting +default: 10 +interface: ezfio,provider,ocaml diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index 82315495..ae8babaa 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -1,21 +1,3 @@ -BEGIN_PROVIDER [ integer, davidson_iter_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson iterations - END_DOC - davidson_iter_max = 100 -END_PROVIDER - -BEGIN_PROVIDER [ integer, davidson_sze_max ] - implicit none - BEGIN_DOC - ! Max number of Davidson sizes - END_DOC - ASSERT (davidson_sze_max <= davidson_iter_max) - davidson_sze_max = N_states+7 -END_PROVIDER - - BEGIN_PROVIDER [ character(64), davidson_criterion ] implicit none BEGIN_DOC diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 98845592..7be59bcc 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -148,12 +148,10 @@ subroutine ortho_qr(A,LDA,m,n) allocate (jpvt(n), tau(n), work(1)) LWORK=-1 -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) LWORK=2*WORK(1) deallocate(WORK) allocate(WORK(LWORK)) -! call dgeqp3(m, n, A, LDA, jpvt, tau, WORK, LWORK, INFO) call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) deallocate(WORK,jpvt,tau) From 4ab7c939e91814343a1699234dfa2f4626db960a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 13:59:24 +0100 Subject: [PATCH 112/188] Better load balancing in fci and cassd --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 6 +++--- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 9 ++++++--- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 92e7fe55..6844ed90 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -145,9 +145,9 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step - i_generator_start = max(i-step+1,1) - i_generator_max = i + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) write(task,*) i_generator_start, i_generator_max, 1, N call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 8b9488d2..636ed6d1 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -137,9 +137,12 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) - do i= N_det_generators, 1, -step - i_generator_start = max(i-step+1,1) - i_generator_max = i +! do i= N_det_generators, 1, -step +! i_generator_start = max(i-step+1,1) +! i_generator_max = i + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) write(task,*) i_generator_start, i_generator_max, 1, N call add_task_to_taskserver(zmq_to_qp_run_socket,task) end do From ba04ee0170163c7191626edec7024bada3484133 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 14:52:12 +0100 Subject: [PATCH 113/188] Added selection_cassd_slave --- .../CAS_SD_ZMQ/selection_cassd_slave.irp.f | 93 +++++++++++++++++++ plugins/Full_CI_ZMQ/fci_zmq.irp.f | 3 - 2 files changed, 93 insertions(+), 3 deletions(-) create mode 100644 plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f new file mode 100644 index 00000000..b9e530e0 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -0,0 +1,93 @@ +program selection_slave + 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 + PROVIDE pt2_e0_denominator mo_tot_num N_int +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 + double precision :: energy(N_states_diag) + character*(64) :: states(1) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'selection' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,1) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'selection') then + + ! Selection + ! --------- + + print *, 'Selection' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call selection_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'Selection done' + + endif + + end do +end + +subroutine update_energy(energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + BEGIN_DOC +! Update energy when it is received from ZMQ + END_DOC + integer :: j,k + do j=1,N_states + do k=1,N_det + CI_eigenvectors(k,j) = psi_coef(k,j) + enddo + enddo + call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) + if (.True.) then + do k=1,size(ci_electronic_energy) + ci_electronic_energy(k) = energy(k) + enddo + TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors + endif + + call write_double(6,ci_energy,'Energy') +end + +subroutine selection_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + + call run_selection_slave(0,i,energy) +end + diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 636ed6d1..c80b7410 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -137,9 +137,6 @@ subroutine ZMQ_selection(N_in, pt2) step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) step = max(1,step) -! do i= N_det_generators, 1, -step -! i_generator_start = max(i-step+1,1) -! i_generator_max = i do i= 1, N_det_generators,step i_generator_start = i i_generator_max = min(i+step-1,N_det_generators) From 6c452bb63a95867e2589d8e49d4e1715871a20f4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 15:18:24 +0100 Subject: [PATCH 114/188] Fixed selection slave --- plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f | 8 ++++---- plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f | 8 ++++---- plugins/Full_CI_ZMQ/selection_slave.irp.f | 8 ++++---- plugins/Selectors_CASSD/zmq.irp.f | 5 ++--- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f index b9e530e0..5e3f982a 100644 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 5041e731..718d4c67 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(2) integer :: rc, i @@ -48,7 +48,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -76,7 +76,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -99,7 +99,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index b9e530e0..5e3f982a 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -22,7 +22,7 @@ subroutine run_wf integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket - double precision :: energy(N_states_diag) + double precision :: energy(N_states) character*(64) :: states(1) integer :: rc, i @@ -47,7 +47,7 @@ subroutine run_wf ! --------- print *, 'Selection' - call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states_diag) + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() @@ -62,7 +62,7 @@ end subroutine update_energy(energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) BEGIN_DOC ! Update energy when it is received from ZMQ END_DOC @@ -85,7 +85,7 @@ end subroutine selection_slave_tcp(i,energy) implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: i call run_selection_slave(0,i,energy) diff --git a/plugins/Selectors_CASSD/zmq.irp.f b/plugins/Selectors_CASSD/zmq.irp.f index 8046212b..4359a876 100644 --- a/plugins/Selectors_CASSD/zmq.irp.f +++ b/plugins/Selectors_CASSD/zmq.irp.f @@ -88,7 +88,6 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) N_states = N_states_read N_det = N_det_read psi_det_size = psi_det_size_read - TOUCH psi_det_size N_det N_states rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) if (rc /= N_int*2*N_det*bit_kind) then @@ -101,11 +100,11 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' stop 'error' endif - TOUCH psi_det psi_coef + TOUCH psi_det_size N_det N_states psi_det psi_coef rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0) if (rc /= size_energy*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,energy,size_energy*8,0)' stop 'error' endif From 13f2c5d5a9522a63e1644320bb63c5a5a3e23d36 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 20:37:13 +0100 Subject: [PATCH 115/188] Removed state-following in MRCC --- plugins/MRCC_Utils/davidson.irp.f | 68 +++++++++++++++---------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 8e0af39e..0470960a 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -784,7 +784,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 1.d0) enddo do k=1,shift2 if (.not. state_ok(k)) then @@ -803,39 +803,39 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif - ! Compute overlap with U_in - ! ------------------------- - - integer :: coord(2), order(N_st_diag) - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo - enddo - do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - overlap(coord(1),coord(2)) = -1.d0 - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo +! ! Compute overlap with U_in +! ! ------------------------- +! +! integer :: coord(2), order(N_st_diag) +! overlap = -1.d0 +! do k=1,shift2 +! do i=1,shift2 +! overlap(k,i) = dabs(y(k,i)) +! enddo +! enddo +! do k=1,N_st +! coord = maxloc(overlap) +! order( coord(2) ) = coord(1) +! overlap(coord(1),coord(2)) = -1.d0 +! enddo +! overlap = y +! do k=1,N_st +! l = order(k) +! if (k /= l) then +! y(1:shift2,k) = overlap(1:shift2,l) +! endif +! enddo +! do k=1,N_st +! overlap(k,1) = lambda(k) +! overlap(k,2) = s2(k) +! enddo +! do k=1,N_st +! l = order(k) +! if (k /= l) then +! lambda(k) = overlap(l,1) +! s2(k) = overlap(l,2) +! endif +! enddo ! Express eigenvectors of h in the determinant basis From 3407b6df853efe24d4b04902071d0ddbad44b6f7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 21:28:10 +0100 Subject: [PATCH 116/188] Resized array energy --- plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 2 +- plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f | 2 +- plugins/Full_CI_ZMQ/selection_slave.irp.f | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f index 36550116..dfaee629 100644 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f index 5e3f982a..657ad63c 100644 --- a/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/selection_cassd_slave.irp.f @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 36550116..dfaee629 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -4,7 +4,7 @@ subroutine run_selection_slave(thread,iproc,energy) use selection_types implicit none - double precision, intent(in) :: energy(N_states_diag) + double precision, intent(in) :: energy(N_states) integer, intent(in) :: thread, iproc integer :: rc, i diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index 718d4c67..d6204cc3 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -88,7 +88,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 5e3f982a..657ad63c 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -74,7 +74,7 @@ subroutine update_energy(energy) enddo call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) if (.True.) then - do k=1,size(ci_electronic_energy) + do k=1,N_states ci_electronic_energy(k) = energy(k) enddo TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors From 816abadda8533158923e4f1c42840534e1a361ed Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 16 Nov 2016 22:08:43 +0100 Subject: [PATCH 117/188] Bug in random number --- src/Davidson/diagonalization_hs2.irp.f | 1 + src/Utils/LinearAlgebra.irp.f | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index c3785d7f..c70a086c 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -187,6 +187,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=N_st+1,N_st_diag do i=1,sze call random_number(r1) + call random_number(r2) r1 = dsqrt(-2.d0*dlog(r1)) r2 = dtwo_pi*r2 u_in(i,k) = r1*dcos(r2) diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 7be59bcc..44a15ddf 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -469,7 +469,12 @@ subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n) print *, irp_here, ': DSYEV: the ',-info,'-th argument had an illegal value' stop 2 else if( info > 0 ) then - write(*,*)'DSYEV Failed' + write(*,*)'DSYEV Failed : ', info + do i=1,n + do j=1,n + print *, H(i,j) + enddo + enddo stop 1 end if From 2dc3eea92b34b4dbfbcaf8493cdd642a469c1fc2 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 17 Nov 2016 10:32:36 -0600 Subject: [PATCH 118/188] Update qp_convert_output_to_ezfio.py --- .../qp_convert_output_to_ezfio.py | 137 +++++++++++++++++- 1 file changed, 129 insertions(+), 8 deletions(-) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index ff7ad225..aea1aef9 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -12,12 +12,10 @@ Option: """ - import sys import os from functools import reduce - # ~#~#~#~#~#~#~#~ # # Add to the path # # ~#~#~#~#~#~#~#~ # @@ -29,9 +27,9 @@ except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: - sys.path = [QP_ROOT + "/install/EZFIO/Python", - QP_ROOT + "/resultsFile", - QP_ROOT + "/scripts"] + sys.path + sys.path = [ QP_ROOT + "/install/EZFIO/Python", + QP_ROOT + "/resultsFile", + QP_ROOT + "/scripts"] + sys.path # ~#~#~#~#~#~ # # I m p o r t # @@ -39,7 +37,6 @@ else: from ezfio import ezfio - try: from resultsFile import * except: @@ -254,7 +251,7 @@ def write_ezfio(res, filename): for coef in m.vector: MoMatrix.append(coef) - while len(MoMatrix) < len(MOs[0].vector) ** 2: + while len(MoMatrix) < len(MOs[0].vector)**2: MoMatrix.append(0.) # ~#~#~#~#~ # @@ -273,7 +270,130 @@ def write_ezfio(res, filename): # \_| |___/\___|\__,_|\__,_|\___/ # - ezfio.set_pseudo_do_pseudo(False) + # INPUT + # {% for lanel,zcore, l_block in l_atom $} + # #local l_block l=0} + # {label} GEN {zcore} {len(l_block)-1 #lmax_block} + # {% for l_param in l_block%} + # {len(l_param) # list of parameter aka n_max_bock_max(n)} + # {% for coef,n,zeta for l_param} + # {coef,n, zeta} + + # OUTPUT + + # Local are 1 array padded by max(n_max_block) when l == 0 (output:k_loc_max) + # v_k[n-2][atom] = value + + #No Local are 2 array padded with max of lmax_block when l!=0 (output:lmax+1) and max(n_max_block)whem l !=0 (kmax) + # v_kl[l][n-2][atom] = value + + def pad(array, size, value=0): + new_array = array + for add in xrange(len(array), size): + new_array.append(value) + + return new_array + + def parse_str(pseudo_str): + '''Return 4d array atom,l,n, attribute (attribute is coef, n, zeta)''' + matrix = [] + array_l_max_block = [] + array_z_remove = [] + + for block in [b for b in pseudo_str.split('\n\n') if b]: + #First element is header, the rest are l_param + array_party = [i for i in re.split(r"\n\d+\n", block) if i] + + z_remove, l_max_block = map(int, array_party[0].split()[-2:]) + array_l_max_block.append(l_max_block) + array_z_remove.append(z_remove) + + matrix.append([[coef_n_zeta.split()[1:] for coef_n_zeta in l.split('\n')] for l in array_party[1:]]) + + return (matrix, array_l_max_block, array_z_remove) + + def get_local_stuff(matrix): + + matrix_local_unpad = [atom[0] for atom in matrix] + k_loc_max = max(len(i) for i in matrix_local_unpad) + + matrix_local = [ pad(ll, k_loc_max, [0., 2, 0.]) for ll in matrix_local_unpad] + + m_coef = [[float(i[0]) for i in atom] for atom in matrix_local] + m_n = [[int(i[1]) - 2 for i in atom] for atom in matrix_local] + m_zeta = [[float(i[2]) for i in atom] for atom in matrix_local] + return (k_loc_max, m_coef, m_n, m_zeta) + + def get_non_local_stuff(matrix): + + matrix_unlocal_unpad = [atom[1:] for atom in matrix] + l_max_block = max(len(i) for i in matrix_unlocal_unpad) + k_max = max([len(item) for row in matrix_unlocal_unpad for item in row]) + + matrix_unlocal_semipaded = [[pad(item, k_max, [0., 2, 0.]) for item in row] for row in matrix_unlocal_unpad] + + empty_row = [[0., 2, 0.] for k in range(l_max_block)] + matrix_unlocal = [ pad(ll, l_max_block, empty_row) for ll in matrix_unlocal_semipaded ] + + m_coef_noloc = [[[float(k[0]) for k in j] for j in i] for i in matrix_unlocal] + m_n_noloc = [[[int(k[1]) - 2 for k in j] for j in i] for i in matrix_unlocal] + m_zeta_noloc = [[[float(k[2]) for k in j] for j in i] for i in matrix_unlocal] + + return (l_max_block, k_max, m_coef_noloc, m_n_noloc, m_zeta_noloc) + + try: + pseudo_str = res_file.get_pseudo() + except: + ezfio.set_pseudo_do_pseudo(False) + else: + ezfio.set_pseudo_do_pseudo(True) + matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) + + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + # Z _ e f f , a l p h a / b e t a _ e l e c # + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # + + ezfio.pseudo_charge_remove = array_z_remove + ezfio.nuclei_nucl_charge = [ + i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove) + ] + + import math + num_elec = sum(ezfio.nuclei_nucl_charge) + + ezfio.electrons_elec_alpha_num = int(math.ceil(num_elec / 2.)) + ezfio.electrons_elec_beta_num = int(math.floor(num_elec / 2.)) + + # Change all the array 'cause EZFIO + # v_kl (v, l) => v_kl(l,v) + # v_kl => zip(*_v_kl) + # [[7.0, 79.74474797, -49.45159098], [1.0, 5.41040609, -4.60151975]] + # [(7.0, 1.0), (79.74474797, 5.41040609), (-49.45159098, -4.60151975)] + + # ~#~#~#~#~ # + # L o c a l # + # ~#~#~#~#~ # + + klocmax, m_coef, m_n, m_zeta = get_local_stuff(matrix) + ezfio.pseudo_pseudo_klocmax = klocmax + + ezfio.pseudo_pseudo_v_k = zip(*m_coef) + ezfio.pseudo_pseudo_n_k = zip(*m_n) + ezfio.pseudo_pseudo_dz_k = zip(*m_zeta) + + # ~#~#~#~#~#~#~#~#~ # + # N o n _ L o c a l # + # ~#~#~#~#~#~#~#~#~ # + + l_max_block, k_max, m_coef_noloc, m_n_noloc, m_zeta_noloc = get_non_local_stuff( + matrix) + + ezfio.pseudo_pseudo_lmax = l_max_block - 1 + ezfio.pseudo_pseudo_kmax = k_max + + ezfio.pseudo_pseudo_v_kl = zip(*m_coef_noloc) + ezfio.pseudo_pseudo_n_kl = zip(*m_n_noloc) + ezfio.pseudo_pseudo_dz_kl = zip(*m_zeta_noloc) def get_full_path(file_path): @@ -282,6 +402,7 @@ def get_full_path(file_path): file_path = os.path.abspath(file_path) return file_path + if __name__ == '__main__': arguments = docopt(__doc__) From 2376fc2f2d8d4330e6f56990f49e958b07a69681 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 17 Nov 2016 10:38:58 -0600 Subject: [PATCH 119/188] Create a main for MRPT_Utils --- src/MRPT_Utils/MRPT_Utils_main.irp.f | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 src/MRPT_Utils/MRPT_Utils_main.irp.f diff --git a/src/MRPT_Utils/MRPT_Utils_main.irp.f b/src/MRPT_Utils/MRPT_Utils_main.irp.f new file mode 100644 index 00000000..fb17f054 --- /dev/null +++ b/src/MRPT_Utils/MRPT_Utils_main.irp.f @@ -0,0 +1,3 @@ + program MRPT_Utils_main + print *, "I'm a core module, I need an main! (maybe a stupid rule)" + end program MRPT_Utils_main From 16f43222f23cca4814d498aa274b737aef64c40f Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Thu, 17 Nov 2016 10:47:43 -0600 Subject: [PATCH 120/188] Update qp_convert_output_to_ezfio.py --- scripts/ezfio_interface/qp_convert_output_to_ezfio.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index aea1aef9..1c541a21 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -343,12 +343,12 @@ def write_ezfio(res, filename): try: pseudo_str = res_file.get_pseudo() + matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) - matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) - + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # From 278c961c0fa8f7f4c0ed068b95729ae0592d772d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 17 Nov 2016 23:28:37 +0100 Subject: [PATCH 121/188] Converge MRCC to 1.e-6 --- plugins/MP2/mp2.irp.f | 6 ++++++ plugins/MP2/mp2_wf.irp.f | 6 ++++++ plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- tests/bats/cassd.bats | 2 +- 4 files changed, 14 insertions(+), 2 deletions(-) diff --git a/plugins/MP2/mp2.irp.f b/plugins/MP2/mp2.irp.f index 3a049f7b..d4721c71 100644 --- a/plugins/MP2/mp2.irp.f +++ b/plugins/MP2/mp2.irp.f @@ -1,4 +1,10 @@ program mp2 + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none double precision, allocatable :: pt2(:), norm_pert(:) double precision :: H_pert_diag, E_old diff --git a/plugins/MP2/mp2_wf.irp.f b/plugins/MP2/mp2_wf.irp.f index 5efbb9cd..e7419319 100644 --- a/plugins/MP2/mp2_wf.irp.f +++ b/plugins/MP2/mp2_wf.irp.f @@ -1,4 +1,10 @@ program mp2_wf + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run implicit none BEGIN_DOC ! Save the MP2 wave function diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f28ccf25..b1c68ef7 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -761,7 +761,7 @@ END_PROVIDER print *, "res ", k, res end if - if(res < 1d-9) exit + if(res < 1d-6) exit end do norm = 0.d0 diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index a1f1a736..f43ffaaa 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.2311177912495 2.E-5 + eq $energy -76.23109 2.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True From 5e3201cea9c59406c6add955e40c0e30e5465f36 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 15:06:33 +0100 Subject: [PATCH 122/188] Removed spin contaminants of Davidson --- plugins/MRCC_Utils/davidson.irp.f | 72 +++++++++++++++++--------- src/Davidson/diagonalization_hs2.irp.f | 11 ++++ 2 files changed, 59 insertions(+), 24 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 0470960a..d1b82dfc 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -781,27 +781,40 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo - if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 1.d0) - enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo + if (s2_eig) then + logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.5d0) + enddo + else + state_ok(k) = .True. endif + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + ! Randomize components with bad + if (.not. state_ok(k)) then + do i=1,shift2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + y(i,k) = r1*dcos(r2) + lambda(k) = 1.d0 + enddo + endif + enddo ! ! Compute overlap with U_in ! ! ------------------------- @@ -852,11 +865,22 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo +! else +! ! Randomize components with bad +! do i=1,sze +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! enddo +! endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index c70a086c..97f93526 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -587,6 +587,17 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo endif enddo + ! Randomize components with bad + if (.not. state_ok(k)) then + do i=1,shift2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + y(i,k) = r1*dcos(r2) + lambda(k) = 1.d0 + enddo + endif endif From 38c6fc7bb8c28426f0b8550d63ccf58263a59e07 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 19:17:34 +0100 Subject: [PATCH 123/188] Implemented dressed S2 matrix --- plugins/MRCC_Utils/davidson.irp.f | 95 ++++++++++++++++++++-------- plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- plugins/mrcepa0/dressing.irp.f | 81 +++++++++++++++++------- plugins/mrcepa0/dressing_slave.irp.f | 87 ++++++++++++++++--------- plugins/mrcepa0/mrcc.irp.f | 2 +- 5 files changed, 186 insertions(+), 81 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index d1b82dfc..608b427b 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -715,6 +715,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz double precision :: r1, r2 do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 do i=1,sze call random_number(r1) call random_number(r2) @@ -762,6 +763,44 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 1.d0, U, size(U,1), S, size(S,1), & 0.d0, s_, size(s_,1)) + ! Diagonalize S^2 + ! --------------- + call lapack_diag(s2,y,s_,size(s_,1),shift2) + +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- call lapack_diag(lambda,y,h,size(h,1),shift2) @@ -784,7 +823,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.5d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) enddo else state_ok(k) = .True. @@ -803,22 +842,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif enddo endif - ! Randomize components with bad - if (.not. state_ok(k)) then - do i=1,shift2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - y(i,k) = r1*dcos(r2) - lambda(k) = 1.d0 - enddo - endif enddo -! ! Compute overlap with U_in -! ! ------------------------- -! + ! Compute overlap with U_in + ! ------------------------- + ! integer :: coord(2), order(N_st_diag) ! overlap = -1.d0 ! do k=1,shift2 @@ -865,21 +893,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag + if (state_ok(k)) then do i=1,sze U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & )/max(H_jj(i) - lambda (k),1.d-2) enddo -! else -! ! Randomize components with bad -! do i=1,sze -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! enddo -! endif + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) @@ -914,8 +951,8 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz energies(k) = lambda(k) enddo - call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, 1.d0, & - U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) + call dgemm('N','N', sze, N_st_diag, shift2, & + 1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo @@ -995,7 +1032,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, & - !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij,istate_in) + !$OMP N_det_ref, idx_ref, N_det_non_ref, idx_non_ref, delta_ij, delta_ij_s2,istate_in) allocate(vt(N_st_8,n),st(N_st_8,n)) Vt = 0.d0 St = 0.d0 @@ -1080,6 +1117,8 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i do istate=1,N_st vt (istate,i) = vt (istate,i) + delta_ij(istate_in,jj,ii)*ut(istate,j) vt (istate,j) = vt (istate,j) + delta_ij(istate_in,jj,ii)*ut(istate,i) + st (istate,i) = st (istate,i) + delta_ij_s2(istate_in,jj,ii)*ut(istate,j) + st (istate,j) = st (istate,j) + delta_ij_s2(istate_in,jj,ii)*ut(istate,i) enddo enddo enddo diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index b1c68ef7..f28ccf25 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -761,7 +761,7 @@ END_PROVIDER print *, "res ", k, res end if - if(res < 1d-6) exit + if(res < 1d-9) exit end do norm = 0.d0 diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 9f041cd3..46c56d9d 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -4,6 +4,8 @@ use bitmasks BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] use bitmasks implicit none integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc @@ -14,11 +16,13 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 + delta_ij_s2_mrcc = 0d0 + delta_ii_s2_mrcc = 0d0 print *, "Dij", dij(1,1,1) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) @@ -37,7 +41,9 @@ use bitmasks end do n = n - 1 - if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + if(n /= 0) then + call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) + endif end do deallocate(buf) @@ -52,13 +58,15 @@ END_PROVIDER ! end subroutine -subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) +subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l,m @@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),allocatable :: tq(:,:,:) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) integer :: exc(0:2,2,2) @@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:) + double precision, allocatable :: hij_cache(:), sij_cache(:) integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) @@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) !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) @@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe deallocate(microlist, idx_microlist) - allocate (dIa_hla(N_states,N_det_non_ref)) + allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) ! |I> @@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo ! |I> do i_I=1,N_det_ref @@ -282,9 +291,11 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) + sla = sij_cache(k_sd) ! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla + dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo call omp_set_lock( psi_ref_lock(i_I) ) @@ -294,19 +305,22 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) enddo else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla,hij_cache) + deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) deallocate(miniList, idx_miniList) end @@ -315,6 +329,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] use bitmasks implicit none integer :: i, j, i_state @@ -325,10 +341,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) enddo end do end do @@ -343,10 +361,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) enddo end do end do @@ -354,10 +374,12 @@ end do i = 1, N_det_ref do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) + delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) enddo do j = 1, N_det_non_ref do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) + delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) enddo end do end do @@ -547,28 +569,32 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k - double precision :: Hjk, Hki, Hij + double precision :: Sjk,Hjk, Hki, Hij !double precision, external :: get_dij integer i_state, degree provide lambda_mrcc dIj do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) do i=1,N_det_ref do j=1,i call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) delta_cas(i,j,i_state) = 0d0 + delta_cas_s2(i,j,i_state) = 0d0 do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) end do delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -649,6 +675,8 @@ end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] &BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] use bitmasks implicit none @@ -656,7 +684,7 @@ end function integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, HIIi, HJk, wall + double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) integer(bit_kind),allocatable :: sortRef(:,:,:) @@ -681,14 +709,16 @@ end function ! To provide everything contrib = dij(1, 1, 1) - do i_state = 1, N_states - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii_s2(:,:) = 0d0 + delta_mrcepa0_ij_s2(:,:,:) = 0d0 - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 @@ -731,16 +761,21 @@ end function ! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC delta_mrcepa0_ii(J,i_state) -= contrib2 + delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 else contrib = contrib * 0.5d0 + contrib_s2 = contrib_s2 * 0.5d0 end if !$OMP ATOMIC delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 end do kloop end do @@ -751,7 +786,7 @@ end function deallocate(idx_sorted_bit) call wall_time(wall) print *, "cepa0", wall, notf - !stop + END_PROVIDER @@ -870,12 +905,14 @@ subroutine set_det_bit(det, p, s) end subroutine -BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] +&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] implicit none integer :: i,j do i=1,N_det_ref do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) + call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) end do end do END_PROVIDER diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index f1d6f029..ae76597c 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) @@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, wall, iwall - double precision, allocatable :: dleat(:,:,:) + double precision :: contrib, contrib_s2, wall, iwall + double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp @@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) allocate(komon(0:N_det_non_ref)) do @@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do !delta = 0.d0 + !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 delta(:,:nlink(i_I),2) = 0d0 + delta_s2(:,0,:) = 0d0 + delta_s2(:,:nlink(J),1) = 0d0 + delta_s2(:,:nlink(i_I),2) = 0d0 komon(0) = 0 komoned = .false. @@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) end if i = det_cepa0_idx(linked(m, i_I)) - if(h_(J,i) == 0.d0) cycle - if(h_(i_I,i) == 0.d0) cycle + if(h_cache(J,i) == 0.d0) cycle + if(h_cache(i_I,i) == 0.d0) cycle !ok = .false. !do i_state=1, N_states @@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc) ! if(I_i == J) phase_Ii = phase_Ji do i_state = 1,N_states - dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) - !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dkI = h_cache(J,i) * dij(i_I, i, i_state) dleat(i_state, kn, 1) = dkI dleat(i_state, kn, 2) = dkI + + dkI = s2_cache(J,i) * dij(i_I, i, i_state) + dleat_s2(i_state, kn, 1) = dkI + dleat_s2(i_state, kn, 2) = dkI end do end do @@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc) !if(lambda_mrcc(i_state, i) == 0d0) cycle - !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib + delta_s2(i_state,ll,1) += contrib_s2 if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) endif if(I_i == J) cycle - !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib + delta_s2(i_state,kk,2) += contrib_s2 if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) end if enddo !i_state end do ! while end do ! kk - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) ! end if @@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) end -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) integer, intent(in) :: i_I, J integer(ZMQ_PTR), intent(in) :: zmq_socket_push double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) @@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' stop 'error' endif + + rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then @@ -305,7 +326,7 @@ end -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) integer(ZMQ_PTR), intent(in) :: zmq_socket_pull integer, intent(out) :: i_I, J, n(2) double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(out) :: task_id integer :: rc , i, kk integer,intent(inout) :: idx(N_det_non_ref,2) @@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) stop 'error' endif + rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' stop 'error' endif end if @@ -372,7 +400,7 @@ end -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) use f77_zmq implicit none BEGIN_DOC @@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) ! integer :: j,l integer :: rc - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -401,49 +431,46 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) delta_ii_(:,:) = 0d0 delta_ij_(:,:,:) = 0d0 + delta_ii_s2_(:,:) = 0d0 + delta_ij_s2_(:,:,:) = 0d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - allocate ( delta(N_states,0:N_det_non_ref,2) ) + allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) allocate(idx(N_det_non_ref,2)) more = 1 do while (more == 1) - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) do l=1, n(1) do i_state=1,N_states delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) end do end do do l=1, n(2) do i_state=1,N_states - delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do -! -! do l=1,nlink(J) -! do i_state=1,N_states -! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) -! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) -! end do -! end do -! if(n(1) /= 0) then do i_state=1,N_states delta_ii_(i_state,i_I) += delta(i_state,0,1) + delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) end do end if if(n(2) /= 0) then do i_state=1,N_states delta_ii_(i_state,J) += delta(i_state,0,2) + delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) end do end if @@ -454,7 +481,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) enddo - deallocate( delta ) + deallocate( delta, delta_s2 ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -466,6 +493,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] implicit none integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 @@ -574,10 +603,10 @@ end ! rc = pthread_create(collector_thread, mrsc2_dressing_collector) print *, nzer, ntot, float(nzer) / float(ntot) provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) i = omp_get_thread_num() if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) else call mrsc2_dressing_slave_inproc(i) endif diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index a28d4be3..a5614942 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -16,7 +16,7 @@ program mrsc2sub psi_coef(i,j) = CI_eigenvectors(i,j) enddo enddo - TOUCH psi_coef + SOFT_TOUCH psi_coef endif call run(N_states,energy) if(do_pt2_end)then From 8c93d3b1a818a00ac2e7e8bc2a5396ba5d6b7dfd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 21:30:48 +0100 Subject: [PATCH 124/188] State following seems to work --- plugins/MRCC_Utils/davidson.irp.f | 62 +++++++++++++++---------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 608b427b..a7c91725 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -666,7 +666,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -847,36 +847,36 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute overlap with U_in ! ------------------------- -! integer :: coord(2), order(N_st_diag) -! overlap = -1.d0 -! do k=1,shift2 -! do i=1,shift2 -! overlap(k,i) = dabs(y(k,i)) -! enddo -! enddo -! do k=1,N_st -! coord = maxloc(overlap) -! order( coord(2) ) = coord(1) -! overlap(coord(1),coord(2)) = -1.d0 -! enddo -! overlap = y -! do k=1,N_st -! l = order(k) -! if (k /= l) then -! y(1:shift2,k) = overlap(1:shift2,l) -! endif -! enddo -! do k=1,N_st -! overlap(k,1) = lambda(k) -! overlap(k,2) = s2(k) -! enddo -! do k=1,N_st -! l = order(k) -! if (k /= l) then -! lambda(k) = overlap(l,1) -! s2(k) = overlap(l,2) -! endif -! enddo + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 + do k=1,shift2 + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo + enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo ! Express eigenvectors of h in the determinant basis From 1446bf9ace130529ce41edb8a731fa6ce389ff9d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 22:08:08 +0100 Subject: [PATCH 125/188] Cleaned Davidson --- plugins/MRCC_Utils/davidson.irp.f | 99 +++--- src/Davidson/EZFIO.cfg | 13 + src/Davidson/diagonalization_hs2.irp.f | 439 ++++++++++++++++++------- 3 files changed, 380 insertions(+), 171 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index a7c91725..642b229c 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -640,8 +640,10 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda - if (N_st_diag > sze) then - stop 'error in Davidson : N_st_diag > sze' + if (N_st_diag*3 > sze) then + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif PROVIDE nuclear_repulsion @@ -763,10 +765,11 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 1.d0, U, size(U,1), S, size(S,1), & 0.d0, s_, size(s_,1)) - ! Diagonalize S^2 - ! --------------- - call lapack_diag(s2,y,s_,size(s_,1),shift2) - +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! ! ! Rotate H in the basis of eigenfunctions of s2 ! ! --------------------------------------------- ! @@ -823,7 +826,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (s2_eig) then logical :: state_ok(N_st_diag*davidson_sze_max) do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.3d0) + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo else state_ok(k) = .True. @@ -844,39 +847,43 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz endif enddo - ! Compute overlap with U_in - ! ------------------------- - - integer :: coord(2), order(N_st_diag) - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) + if (state_following) then + + ! Compute overlap with U_in + ! ------------------------- + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 + do k=1,shift2 + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - enddo - do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) + endif + enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + + endif ! Express eigenvectors of h in the determinant basis @@ -940,22 +947,18 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo - if (.not.converged) then - iter = itermax-1 - endif - ! Re-contract to u_in ! ----------- - do k=1,N_st_diag - energies(k) = lambda(k) - enddo - call dgemm('N','N', sze, N_st_diag, shift2, & 1.d0, U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) enddo + do k=1,N_st_diag + energies(k) = lambda(k) + enddo + write_buffer = '===== ' do i=1,N_st write_buffer = trim(write_buffer)//' ================ =========== ===========' @@ -966,7 +969,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index b7c67465..7724400f 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -15,3 +15,16 @@ type: Strictly_positive_int doc: Number of micro-iterations before re-contracting default: 10 interface: ezfio,provider,ocaml + +[state_following] +type: logical +doc: If true, the states are re-ordered to match the input states +default: False +interface: ezfio,provider,ocaml + +[disk_based_davidson] +type: logical +doc: If true, disk space is used to store the vectors +default: False +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 97f93526..0eeda5a2 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -45,8 +45,11 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP END DO !$OMP END PARALLEL - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) -! call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + if (disk_based_davidson) then + call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + else + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + endif do i=1,N_st_diag s2_out(i) = S2_jj(i) enddo @@ -84,8 +87,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -99,7 +102,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: k_pairs, kl integer :: iter2 - double precision, allocatable :: W(:,:), U(:,:), S(:,:) + double precision, allocatable :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -108,17 +111,19 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s double precision :: to_print(3,N_st) double precision :: cpu, wall integer :: shift, shift2, itermax + double precision :: r1, r2 + logical :: state_ok(N_st_diag*davidson_sze_max) include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - + PROVIDE nuclear_repulsion expected_s2 - + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -137,7 +142,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -145,31 +150,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double + + integer, external :: align_double sze_8 = align_double(sze) - + itermax = min(davidson_sze_max, sze/N_st_diag) allocate( & - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + W(sze_8,N_st_diag*itermax), & + U(sze_8,N_st_diag*itermax), & + S(sze_8,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 + h = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 + s_ = 0.d0 + s_tmp = 0.d0 ASSERT (N_st > 0) @@ -183,21 +189,21 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s converged = .False. - double precision :: r1, r2 do k=N_st+1,N_st_diag - do i=1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo + u_in(k,k) = 10.d0 + do i=1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + u_in(i,k) = r1*dcos(r2) + enddo enddo do k=1,N_st_diag call normalize(u_in(1,k),sze) enddo - - + + do while (.not.converged) do k=1,N_st_diag @@ -205,12 +211,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s U(i,k) = u_in(i,k) enddo enddo - + do iter=1,itermax-1 shift = N_st_diag*(iter-1) shift2 = N_st_diag*iter - + call ortho_qr(U,size(U,1),sze,shift2) ! Compute |W_k> = \sum_i |i> @@ -233,8 +239,49 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s 0.d0, s_, size(s_,1)) +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + + ! Diagonalize h ! ------------- + call lapack_diag(lambda,y,h,size(h,1),shift2) ! Compute S2 for each eigenvector @@ -255,24 +302,61 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -290,11 +374,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -339,7 +443,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s deallocate ( & W, residual_norm, & - U, & + U, overlap, & c, S, & h, & y, s_, s_tmp, & @@ -378,8 +482,8 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit + double precision, intent(inout) :: S2_jj(sze) + integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -393,7 +497,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz integer :: k_pairs, kl integer :: iter2 - double precision, pointer :: W(:,:), U(:,:), S(:,:) + double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) double precision :: diag_h_mat_elem @@ -401,18 +505,19 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall + logical :: state_ok(N_st_diag*davidson_sze_max) integer :: shift, shift2, itermax include 'constants.include.F' !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 + print *, 'error in Davidson :' + print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 + stop -1 endif - + PROVIDE nuclear_repulsion expected_s2 - + call write_time(iunit) call wall_time(wall) call cpu_time(cpu) @@ -431,7 +536,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual' + write_buffer = trim(write_buffer)//' Energy S^2 Residual ' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -439,51 +544,52 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz write_buffer = trim(write_buffer)//' ================ =========== ===========' enddo write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double - integer :: fd(3) - type(c_ptr) :: c_pointer(3) + + integer, external :: align_double + integer :: fd(3) + type(c_ptr) :: c_pointer(3) sze_8 = align_double(sze) - + itermax = min(davidson_sze_max, sze/N_st_diag) - call mmap( & - trim(ezfio_work_dir)//'U', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'U', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(1), .False., c_pointer(1)) call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) - call mmap( & - trim(ezfio_work_dir)//'W', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'W', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(2), .False., c_pointer(2)) call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) - call mmap( & - trim(ezfio_work_dir)//'S', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & + call mmap( & + trim(ezfio_work_dir)//'S', & + (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & 8, fd(3), .False., c_pointer(3)) call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) allocate( & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + h(N_st_diag*itermax,N_st_diag*itermax), & + y(N_st_diag*itermax,N_st_diag*itermax), & + s_(N_st_diag*itermax,N_st_diag*itermax), & + s_tmp(N_st_diag*itermax,N_st_diag*itermax), & + overlap(N_st_diag*itermax, N_st_diag*itermax), & residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & + c(N_st_diag*itermax), & + s2(N_st_diag*itermax), & lambda(N_st_diag*itermax)) - h = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 + h = 0.d0 U = 0.d0 W = 0.d0 S = 0.d0 y = 0.d0 - - + s_ = 0.d0 + s_tmp = 0.d0 + + ASSERT (N_st > 0) ASSERT (N_st_diag >= N_st) ASSERT (sze > 0) @@ -497,6 +603,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz double precision :: r1, r2 do k=N_st+1,N_st_diag + u_in(k,k) = 10.d0 do i=1,sze call random_number(r1) r1 = dsqrt(-2.d0*dlog(r1)) @@ -546,6 +653,45 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz 0.d0, s_(shift+1,1), size(s_,1)) enddo +! ! Diagonalize S^2 +! ! --------------- +! +! call lapack_diag(s2,y,s_,size(s_,1),shift2) +! +! +! ! Rotate H in the basis of eigenfunctions of s2 +! ! --------------------------------------------- +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('T','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) +! +! ! Damp interaction between different spin states +! ! ------------------------------------------------ +! +! do k=1,shift2 +! do l=1,shift2 +! if (dabs(s2(k) - s2(l)) > 1.d0) then +! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) +! endif +! enddo +! enddo +! +! ! Rotate back H +! ! ------------- +! +! call dgemm('N','T',shift2,shift2,shift2, & +! 1.d0, h, size(h,1), y, size(y,1), & +! 0.d0, s_tmp, size(s_tmp,1)) +! +! call dgemm('N','N',shift2,shift2,shift2, & +! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & +! 0.d0, h, size(h,1)) + ! Diagonalize h ! ------------- @@ -568,36 +714,63 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz s2(k) = s_(k,k) + S_z2_Sz enddo + if (s2_eig) then - logical :: state_ok(N_st_diag*davidson_sze_max) + do k=1,shift2 + state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + enddo + else + state_ok(k) = .True. + endif + + do k=1,shift2 + if (.not. state_ok(k)) then + do l=k+1,shift2 + if (state_ok(l)) then + call dswap(shift2, y(1,k), 1, y(1,l), 1) + call dswap(1, s2(k), 1, s2(l), 1) + call dswap(1, lambda(k), 1, lambda(l), 1) + state_ok(k) = .True. + state_ok(l) = .False. + exit + endif + enddo + endif + enddo + + if (state_following) then + + integer :: coord(2), order(N_st_diag) + overlap = -1.d0 do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) + do i=1,shift2 + overlap(k,i) = dabs(y(k,i)) + enddo enddo - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo + do k=1,N_st + coord = maxloc(overlap) + order( coord(2) ) = coord(1) + overlap(:,coord(2)) = -1.d0 + enddo + overlap = y + do k=1,N_st + l = order(k) + if (k /= l) then + y(1:shift2,k) = overlap(1:shift2,l) endif enddo - ! Randomize components with bad - if (.not. state_ok(k)) then - do i=1,shift2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - y(i,k) = r1*dcos(r2) - lambda(k) = 1.d0 - enddo - endif + do k=1,N_st + overlap(k,1) = lambda(k) + overlap(k,2) = s2(k) + enddo + do k=1,N_st + l = order(k) + if (k /= l) then + lambda(k) = overlap(l,1) + s2(k) = overlap(l,2) + endif + enddo + endif @@ -615,11 +788,31 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------------------------- do k=1,N_st_diag - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo + if (state_ok(k)) then + do i=1,sze + U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo + else + ! Randomize components with bad + do i=1,sze-2,2 + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + U(i+1,shift2+k) = r1*dsin(r2) + enddo + do i=sze-2+1,sze + call random_number(r1) + call random_number(r2) + r1 = dsqrt(-2.d0*dlog(r1)) + r2 = dtwo_pi*r2 + U(i,shift2+k) = r1*dcos(r2) + enddo + endif + if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion @@ -676,7 +869,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz deallocate ( & residual_norm, & - c, & + c, overlap, & h, & y, s_, s_tmp, & lambda & From 9a06b970de32c4d35845849324ec2314e698dc53 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 18 Nov 2016 22:22:46 +0100 Subject: [PATCH 126/188] State following OK --- plugins/MRCC_Utils/davidson.irp.f | 4 +++- src/Davidson/diagonalization_hs2.irp.f | 23 +++++++++++++++++------ 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 642b229c..199feb3f 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -862,7 +862,9 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo enddo overlap = y do k=1,N_st diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 0eeda5a2..b79972af 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -328,21 +328,30 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer :: coord(2), order(N_st_diag) overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 + do i=1,shift2 + do k=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo + enddo + print *, order(1:N_st) + do i=1,shift2 + do k=1,shift2 + overlap(k,i) = y(k,i) + enddo enddo - overlap = y do k=1,N_st l = order(k) if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) + do i=1,shift2 + y(i,k) = overlap(i,l) + enddo endif enddo do k=1,N_st @@ -750,7 +759,9 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz do k=1,N_st coord = maxloc(overlap) order( coord(2) ) = coord(1) - overlap(:,coord(2)) = -1.d0 + do i=1,shift2 + overlap(coord(1),i) = -1.d0 + enddo enddo overlap = y do k=1,N_st From fe11f2baceb153832ec7083ca764d02f85b2abaa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 19 Nov 2016 00:39:02 +0100 Subject: [PATCH 127/188] Improved state following --- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/davidson.irp.f | 14 ++++++++++---- src/Davidson/diagonalization_hs2.irp.f | 17 +++++++++++++---- 3 files changed, 24 insertions(+), 9 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 82736b8f..e725ef3d 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -89,7 +89,7 @@ END_PROVIDER !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) - !$OMP DO schedule(static,10) + !$OMP DO dynamic do ppp=1,n_exc_active active_excitation_to_determinants_val(:,:,ppp) = 0d0 active_excitation_to_determinants_idx(:,ppp) = 0 diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 199feb3f..f03f8bab 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -852,7 +852,8 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Compute overlap with U_in ! ------------------------- - integer :: coord(2), order(N_st_diag) + integer :: order(N_st_diag) + double precision :: cmax overlap = -1.d0 do k=1,shift2 do i=1,shift2 @@ -860,10 +861,15 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) + cmax = -1.d0 do i=1,shift2 - overlap(coord(1),i) = -1.d0 + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,shift2 + overlap(order(k),i) = -1.d0 enddo enddo overlap = y diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index b79972af..2e05df48 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -749,7 +749,11 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz if (state_following) then - integer :: coord(2), order(N_st_diag) + ! Compute overlap with U_in + ! ------------------------- + + integer :: order(N_st_diag) + double precision :: cmax overlap = -1.d0 do k=1,shift2 do i=1,shift2 @@ -757,10 +761,15 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) + cmax = -1.d0 do i=1,shift2 - overlap(coord(1),i) = -1.d0 + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,shift2 + overlap(order(k),i) = -1.d0 enddo enddo overlap = y From 92c954143cf069e595ca2556cf0117d8066f09ab Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:14:06 +0100 Subject: [PATCH 128/188] Bug in MRSC2 --- plugins/mrcepa0/dressing_slave.irp.f | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index ae76597c..9e9fa65a 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -455,6 +455,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2 do l=1, n(2) do i_state=1,N_states + delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do From 7f9d19346efaaaae291401c88bd1a03c6f2a9181 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:46:10 +0100 Subject: [PATCH 129/188] Fixed compilation --- plugins/MRCC_Utils/amplitudes.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index e725ef3d..72d3ea67 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -89,7 +89,7 @@ END_PROVIDER !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) - !$OMP DO dynamic + !$OMP DO schedule(dynamic) do ppp=1,n_exc_active active_excitation_to_determinants_val(:,:,ppp) = 0d0 active_excitation_to_determinants_idx(:,ppp) = 0 diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f28ccf25..ea13f8cc 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -718,7 +718,7 @@ END_PROVIDER factor = 1.d0 resold = huge(1.d0) - do k=0,100000 + do k=0,hh_nex !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO From f2fdcb379d648bd85203ca6f03cd5a32770a0888 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 20 Nov 2016 22:55:10 +0100 Subject: [PATCH 130/188] Single state diagonalization in MRCC --- plugins/MRCC_Utils/mrcc_utils.irp.f | 12 +++++------- plugins/mrcepa0/mrcepa0_general.irp.f | 12 ++++++++---- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index ea13f8cc..b3b2f427 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -150,17 +150,15 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) do mrcc_state=1,N_states - do j=1,min(N_states,N_det) - do i=1,N_det - eigenvectors(i,j) = psi_coef(i,j) - enddo + do i=1,N_det + eigenvectors(i,1) = psi_coef(i,mrcc_state) enddo call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& size(eigenvectors,1), & - eigenvalues,N_det,N_states,N_states_diag,N_int, & + eigenvalues,N_det,1,N_states_diag,N_int, & output_determinants,mrcc_state) - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,1) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(1) if (mrcc_state == 1) then do k=N_states+1,N_states_diag CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 09c35e52..1e89cc2c 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -41,11 +41,15 @@ subroutine run(N_st,energy) print *, 'MRCEPA0 Iteration', iteration print *, '===========================' print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") + E_old = sum(ci_energy_dressed(1:N_states)) + do i=1,N_st + call write_double(6,ci_energy_dressed(i),"MRCEPA0 energy") + enddo call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) + E_new = sum(ci_energy_dressed(1:N_states)) + delta_E = (E_new - E_old)/dble(N_states) + call write_double(6,delta_E,"delta_E") + delta_E = dabs(delta_E) call save_wavefunction call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) if (iteration >= n_it_mrcc_max) then From ae7e9361b9957a0ab9c962c18bfc5efd84797cdc Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 21:25:38 +0100 Subject: [PATCH 131/188] Improved convergence of multi-state --- plugins/MRCC_Utils/mrcc_utils.irp.f | 41 +++++++++++++++----------- plugins/mrcepa0/mrcepa0_general.irp.f | 8 +++-- src/Davidson/diagonalization_hs2.irp.f | 32 ++++++++++---------- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index b3b2f427..3b05aaeb 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -149,26 +149,31 @@ END_PROVIDER allocate (eigenvectors(size(CI_eigenvectors_dressed,1),size(CI_eigenvectors_dressed,2)), & eigenvalues(size(CI_electronic_energy_dressed,1))) + do j=1,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo do mrcc_state=1,N_states - do i=1,N_det - eigenvectors(i,1) = psi_coef(i,mrcc_state) + do j=mrcc_state,min(N_states,N_det) + do i=1,N_det + eigenvectors(i,j) = psi_coef(i,j) + enddo enddo call davidson_diag_mrcc_HS2(psi_det,eigenvectors,& size(eigenvectors,1), & - eigenvalues,N_det,1,N_states_diag,N_int, & + eigenvalues,N_det,N_states,N_states_diag,N_int, & output_determinants,mrcc_state) - CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,1) - CI_electronic_energy_dressed(mrcc_state) = eigenvalues(1) - if (mrcc_state == 1) then - do k=N_states+1,N_states_diag - CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) - CI_electronic_energy_dressed(k) = eigenvalues(k) - enddo - endif - enddo - call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& + CI_eigenvectors_dressed(1:N_det,mrcc_state) = eigenvectors(1:N_det,mrcc_state) + CI_electronic_energy_dressed(mrcc_state) = eigenvalues(mrcc_state) + enddo + do k=N_states+1,N_states_diag + CI_eigenvectors_dressed(1:N_det,k) = eigenvectors(1:N_det,k) + CI_electronic_energy_dressed(k) = eigenvalues(k) + enddo + call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) - deallocate (eigenvectors,eigenvalues) + deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -716,7 +721,7 @@ END_PROVIDER factor = 1.d0 resold = huge(1.d0) - do k=0,hh_nex + do k=0,hh_nex*hh_nex !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO @@ -751,15 +756,15 @@ END_PROVIDER X(a_col) = X_new(a_col) end do if (res > resold) then - factor = -factor * 0.5d0 + factor = factor * 0.5d0 endif resold = res - if(mod(k, 100) == 0) then + if(iand(k, 4095) == 0) then print *, "res ", k, res end if - if(res < 1d-9) exit + if(res < 1d-12) exit end do norm = 0.d0 diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 1e89cc2c..d9607e6a 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -37,9 +37,9 @@ subroutine run(N_st,energy) lambda = 1.d0 do while (delta_E > thresh_mrcc) iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' + print *, '===============================================' + print *, 'MRCEPA0 Iteration', iteration, '/', n_it_mrcc_max + print *, '===============================================' print *, '' E_old = sum(ci_energy_dressed(1:N_states)) do i=1,N_st @@ -48,6 +48,8 @@ subroutine run(N_st,energy) call diagonalize_ci_dressed(lambda) E_new = sum(ci_energy_dressed(1:N_states)) delta_E = (E_new - E_old)/dble(N_states) + print *, '' + call write_double(6,thresh_mrcc,"thresh_mrcc") call write_double(6,delta_E,"delta_E") delta_E = dabs(delta_E) call save_wavefunction diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 2e05df48..8dc6e00d 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -326,32 +326,32 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s if (state_following) then - integer :: coord(2), order(N_st_diag) + integer :: order(N_st_diag) + double precision :: cmax + overlap = -1.d0 - do i=1,shift2 - do k=1,shift2 + do k=1,shift2 + do i=1,shift2 overlap(k,i) = dabs(y(k,i)) enddo enddo do k=1,N_st - coord = maxloc(overlap) - order( coord(2) ) = coord(1) - do i=1,shift2 - overlap(coord(1),i) = -1.d0 + cmax = -1.d0 + do i=1,N_st_diag + if (overlap(i,k) > cmax) then + cmax = overlap(i,k) + order(k) = i + endif + enddo + do i=1,N_st_diag + overlap(order(k),i) = -1.d0 enddo enddo - print *, order(1:N_st) - do i=1,shift2 - do k=1,shift2 - overlap(k,i) = y(k,i) - enddo - enddo + overlap = y do k=1,N_st l = order(k) if (k /= l) then - do i=1,shift2 - y(i,k) = overlap(i,l) - enddo + y(1:shift2,k) = overlap(1:shift2,l) endif enddo do k=1,N_st From c11dfed16b950aba58ffa9d5f90f104baa60da46 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 21:42:28 +0100 Subject: [PATCH 132/188] Improved convergence of multi-state --- plugins/MRCC_Utils/davidson.irp.f | 2 +- src/Davidson/diagonalization_hs2.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index f03f8bab..e667d255 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -862,7 +862,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz enddo do k=1,N_st cmax = -1.d0 - do i=1,shift2 + do i=1,N_st if (overlap(i,k) > cmax) then cmax = overlap(i,k) order(k) = i diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 8dc6e00d..7cba0f60 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -337,7 +337,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo do k=1,N_st cmax = -1.d0 - do i=1,N_st_diag + do i=1,N_st if (overlap(i,k) > cmax) then cmax = overlap(i,k) order(k) = i From 94d7aed238179877cbfd2f8a430ffe04fbfebe13 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 23:17:43 +0100 Subject: [PATCH 133/188] Changed symmetrization of H_mrcc --- plugins/MRCC_Utils/mrcc_utils.irp.f | 5 +--- plugins/mrcepa0/dressing.irp.f | 44 +++++++++++++++++++++-------- 2 files changed, 34 insertions(+), 15 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 3b05aaeb..0540eed9 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -953,17 +953,14 @@ BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ] integer :: s,i,j double precision, external :: get_dij_index print *, "computing amplitudes..." - !$OMP PARALLEL DEFAULT(shared) PRIVATE(s,i,j) do s=1, N_states - !$OMP DO do i=1, N_det_non_ref do j=1, N_det_ref + !DIR$ FORCEINLINE dij(j, i, s) = get_dij_index(j, i, s, N_int) end do end do - !$OMP END DO end do - !$OMP END PARALLEL print *, "done computing amplitudes" END_PROVIDER diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 46c56d9d..cba4629b 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -18,7 +18,8 @@ use bitmasks delta_ii_mrcc = 0d0 delta_ij_s2_mrcc = 0d0 delta_ii_s2_mrcc = 0d0 - print *, "Dij", dij(1,1,1) + PROVIDE dij + print *, "Dij", dij(1,1,1:N_states) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & @@ -300,22 +301,22 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen enddo call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else +! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then +! do l_sd=1,idx_alpha(0) +! k_sd = idx_alpha(l_sd) +! delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) +! delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) +! delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) +! enddo +! else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo - endif +! endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo @@ -350,6 +351,27 @@ end enddo end do end do + + ! =-=-= BEGIN STATE AVERAGE +! do i = 1, N_det_ref +! delta_ii(:,i)= delta_ii_mrcc(1,i) +! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) +! do i_state = 2, N_states +! delta_ii(:,i) += delta_ii_mrcc(i_state,i) +! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) +! enddo +! do j = 1, N_det_non_ref +! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) +! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) +! do i_state = 2, N_states +! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) +! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) +! enddo +! end do +! end do +! delta_ij = delta_ij * (1.d0/dble(N_states)) +! delta_ii = delta_ii * (1.d0/dble(N_states)) + ! =-=-= END STATE AVERAGE ! ! do i = 1, N_det_ref ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) From f326801e565001c720f8dc8b25986f2d9307e2ab Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 21 Nov 2016 23:31:28 +0100 Subject: [PATCH 134/188] Fixed mrcepa0_general.irp.f --- plugins/mrcepa0/dressing.irp.f | 1 - plugins/mrcepa0/mrcepa0_general.irp.f | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index cba4629b..0c67ab99 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -19,7 +19,6 @@ use bitmasks delta_ij_s2_mrcc = 0d0 delta_ii_s2_mrcc = 0d0 PROVIDE dij - print *, "Dij", dij(1,1,1:N_states) provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index d9607e6a..1b2e2fcb 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -21,7 +21,7 @@ subroutine run(N_st,energy) n_it_mrcc_max = n_it_max_dressed_ci if(n_it_mrcc_max == 1) then - do j=1,N_states_diag + do j=1,N_states do i=1,N_det psi_coef(i,j) = CI_eigenvectors_dressed(i,j) enddo From c2a7d25615ffef71ea2e7649c8388541f7989540 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 22 Nov 2016 12:55:42 +0100 Subject: [PATCH 135/188] FCI stops exactly at the required number of determinants --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 7 +++++-- src/Utils/map_module.f90 | 12 ++++++------ 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index c80b7410..b3ffbe03 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -5,6 +5,7 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree + integer :: n_det_before, to_select allocate (pt2(N_states)) @@ -33,13 +34,15 @@ program fci_zmq double precision :: E_CI_before(N_states) - integer :: n_det_before print*,'Beginning the selection ...' E_CI_before(1:N_states) = CI_energy(1:N_states) + n_det_before = 0 do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) n_det_before = N_det - call ZMQ_selection(max(1024-N_det, N_det), pt2) + to_select = max(1024-N_det, N_det) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) PROVIDE psi_coef PROVIDE psi_det diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 4a83582f..80260233 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -622,7 +622,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep ! TODO : Cache misses if (cache_key < X(idx)) then @@ -660,8 +660,8 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) endif enddo idx = ibegin - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 end do @@ -730,7 +730,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in istep = ishft(iend-ibegin,-1) idx = ibegin + istep - do while (istep > 16) + do while (istep > 64) idx = ibegin + istep if (cache_key < X(idx)) then iend = idx @@ -771,8 +771,8 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in enddo idx = ibegin value = Y(idx) - if (min(iend_in,sze) > ibegin+16) then - iend = ibegin+16 + if (min(iend_in,sze) > ibegin+64) then + iend = ibegin+64 do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) From 520bb45be8620da839f7a931d714991703fa561d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 22 Nov 2016 13:00:02 +0100 Subject: [PATCH 136/188] Accelerated selection --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index b3ffbe03..382e8652 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -6,11 +6,15 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree integer :: n_det_before, to_select + double precision :: threshold_davidson_in allocate (pt2(N_states)) pt2 = 1.d0 diag_algorithm = "Lapack" + threshold_davidson_in = threshold_davidson + SOFT_TOUCH threshold_davidson + threshold_davidson = 1.d-4 if (N_det > N_det_max) then call diagonalize_CI @@ -40,7 +44,8 @@ program fci_zmq do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) n_det_before = N_det - to_select = max(1024-N_det, N_det) + to_select = 3*N_det + to_select = max(1024-to_select, to_select) to_select = min(to_select, N_det_max-n_det_before) call ZMQ_selection(to_select, pt2) @@ -48,6 +53,10 @@ program fci_zmq PROVIDE psi_det PROVIDE psi_det_sorted + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + SOFT_TOUCH threshold_davidson + endif call diagonalize_CI call save_wavefunction From 3aa10822b5cfbd876b00faddfba296153c4774dc Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 23 Nov 2016 22:27:10 +0100 Subject: [PATCH 137/188] protect itermax --- src/Davidson/diagonalization_hs2.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 7cba0f60..2402f973 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -154,7 +154,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, external :: align_double sze_8 = align_double(sze) - itermax = min(davidson_sze_max, sze/N_st_diag) + itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) allocate( & W(sze_8,N_st_diag*itermax), & U(sze_8,N_st_diag*itermax), & From 2dcb4eba0d9d272cdf258ead7e213a651df230be Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 29 Nov 2016 16:43:36 +0100 Subject: [PATCH 138/188] Fixed Pseudo and dummy atoms --- ocaml/Pseudo.ml | 244 +++++++++++++++--------------- plugins/QmcChem/e_curve_qmc.irp.f | 16 +- 2 files changed, 135 insertions(+), 125 deletions(-) diff --git a/ocaml/Pseudo.ml b/ocaml/Pseudo.ml index 3fb4736e..7f813937 100644 --- a/ocaml/Pseudo.ml +++ b/ocaml/Pseudo.ml @@ -124,23 +124,27 @@ let to_string t = let find in_channel element = In_channel.seek in_channel 0L; - let element_read, old_pos = - ref Element.X, + let loop, element_read, old_pos = + ref true, + ref None, ref (In_channel.pos in_channel) in - while !element_read <> element + + while !loop do - let buffer = - old_pos := In_channel.pos in_channel; - match In_channel.input_line in_channel with - | Some line -> String.split ~on:' ' line - |> List.hd_exn - | None -> "" - in try - element_read := Element.of_string buffer + let buffer = + old_pos := In_channel.pos in_channel; + match In_channel.input_line in_channel with + | Some line -> String.split ~on:' ' line + |> List.hd_exn + | None -> raise End_of_file + in + element_read := Some (Element.of_string buffer); + loop := !element_read <> (Some element) with | Element.ElementError _ -> () + | End_of_file -> loop := false done ; In_channel.seek in_channel !old_pos; !element_read @@ -148,124 +152,126 @@ let find in_channel element = (** Read the Pseudopotential in GAMESS format *) let read_element in_channel element = - ignore (find in_channel element); - - let rec read result = - match In_channel.input_line in_channel with - | None -> result - | Some line -> - if (String.strip line = "") then - result - else - read (line::result) - in - - let data = - read [] - |> List.rev - in - - let debug_data = - String.concat ~sep:"\n" data - in - - let decode_first_line = function - | first_line :: rest -> + match find in_channel element with + | Some e when e = element -> begin - let first_line_split = - String.split first_line ~on:' ' - |> List.filter ~f:(fun x -> (String.strip x) <> "") + let rec read result = + match In_channel.input_line in_channel with + | None -> result + | Some line -> + if (String.strip line = "") then + result + else + read (line::result) in - match first_line_split with - | e :: "GEN" :: n :: p -> - { element = Element.of_string e ; - n_elec = Int.of_string n |> Positive_int.of_int ; - local = [] ; - non_local = [] - }, rest - | _ -> failwith ( - Printf.sprintf "Unable to read Pseudopotential : \n%s\n" - debug_data ) - end - | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - in - let rec loop create_primitive accu = function - | (0,rest) -> List.rev accu, rest - | (n,line::rest) -> - begin - match - String.split line ~on:' ' - |> List.filter ~f:(fun x -> String.strip x <> "") - with - | c :: i :: e :: [] -> - let i = - Int.of_string i - in - let elem = - ( create_primitive - (Float.of_string e |> AO_expo.of_float) - (i-2 |> R_power.of_int), - Float.of_string c |> AO_coef.of_float - ) - in - loop create_primitive (elem::accu) (n-1, rest) + let data = + read [] + |> List.rev + in + + let debug_data = + String.concat ~sep:"\n" data + in + + let decode_first_line = function + | first_line :: rest -> + begin + let first_line_split = + String.split first_line ~on:' ' + |> List.filter ~f:(fun x -> (String.strip x) <> "") + in + match first_line_split with + | e :: "GEN" :: n :: p -> + { element = Element.of_string e ; + n_elec = Int.of_string n |> Positive_int.of_int ; + local = [] ; + non_local = [] + }, rest + | _ -> failwith ( + Printf.sprintf "Unable to read Pseudopotential : \n%s\n" + debug_data ) + end | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - end - | _ -> failwith ("Error reading pseudopotential\n"^debug_data) - in + in - let decode_local (pseudo,data) = - let decode_local_n n rest = - let result, rest = - loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) + let rec loop create_primitive accu = function + | (0,rest) -> List.rev accu, rest + | (n,line::rest) -> + begin + match + String.split line ~on:' ' + |> List.filter ~f:(fun x -> String.strip x <> "") + with + | c :: i :: e :: [] -> + let i = + Int.of_string i + in + let elem = + ( create_primitive + (Float.of_string e |> AO_expo.of_float) + (i-2 |> R_power.of_int), + Float.of_string c |> AO_coef.of_float + ) + in + loop create_primitive (elem::accu) (n-1, rest) + | _ -> failwith ("Error reading pseudopotential\n"^debug_data) + end + | _ -> failwith ("Error reading pseudopotential\n"^debug_data) in - { pseudo with local = result }, rest - in - match data with - | n :: rest -> - let n = - String.strip n - |> Int.of_string - |> Positive_int.of_int + + let decode_local (pseudo,data) = + let decode_local_n n rest = + let result, rest = + loop Primitive_local.of_expo_r_power [] (Positive_int.to_int n,rest) + in + { pseudo with local = result }, rest in - decode_local_n n rest - | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data) - in - - let decode_non_local (pseudo,data) = - let decode_non_local_n proj n (pseudo,data) = - let result, rest = - loop (Primitive_non_local.of_proj_expo_r_power proj) - [] (Positive_int.to_int n, data) + match data with + | n :: rest -> + let n = + String.strip n + |> Int.of_string + |> Positive_int.of_int + in + decode_local_n n rest + | _ -> failwith ("Unable to read (non-)local pseudopotential\n"^debug_data) in - { pseudo with non_local = pseudo.non_local @ result }, rest - in - let rec new_proj (pseudo,data) proj = - match data with - | n :: rest -> - let n = - String.strip n - |> Int.of_string - |> Positive_int.of_int - in - let result = - decode_non_local_n proj n (pseudo,rest) - and proj_next = - (Positive_int.to_int proj)+1 - |> Positive_int.of_int - in - new_proj result proj_next - | _ -> pseudo - in - new_proj (pseudo,data) (Positive_int.of_int 0) - in - decode_first_line data - |> decode_local - |> decode_non_local + let decode_non_local (pseudo,data) = + let decode_non_local_n proj n (pseudo,data) = + let result, rest = + loop (Primitive_non_local.of_proj_expo_r_power proj) + [] (Positive_int.to_int n, data) + in + { pseudo with non_local = pseudo.non_local @ result }, rest + in + let rec new_proj (pseudo,data) proj = + match data with + | n :: rest -> + let n = + String.strip n + |> Int.of_string + |> Positive_int.of_int + in + let result = + decode_non_local_n proj n (pseudo,rest) + and proj_next = + (Positive_int.to_int proj)+1 + |> Positive_int.of_int + in + new_proj result proj_next + | _ -> pseudo + in + new_proj (pseudo,data) (Positive_int.of_int 0) + in + + decode_first_line data + |> decode_local + |> decode_non_local + end + | _ -> empty element - include To_md5 diff --git a/plugins/QmcChem/e_curve_qmc.irp.f b/plugins/QmcChem/e_curve_qmc.irp.f index 4beed3fa..d45624a0 100644 --- a/plugins/QmcChem/e_curve_qmc.irp.f +++ b/plugins/QmcChem/e_curve_qmc.irp.f @@ -1,7 +1,7 @@ program e_curve use bitmasks implicit none - integer :: i,j,k, nab, m, l + integer :: i,j,k, kk, nab, m, l double precision :: norm, E, hij, num, ci, cj integer, allocatable :: iorder(:) double precision , allocatable :: norm_sort(:) @@ -60,7 +60,7 @@ program e_curve num = 0.d0 norm = 0.d0 m = 0 - !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num) + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,kk,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num) allocate( det_i(N_int,2), det_j(N_int,2)) !$OMP DO SCHEDULE(guided) do k=1,n_det @@ -68,15 +68,19 @@ program e_curve cycle endif ci = psi_bilinear_matrix_values(k,1) - det_i(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(k)) - det_i(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(k)) + do kk=1,N_int + det_i(kk,1) = psi_det_alpha_unique(kk,psi_bilinear_matrix_rows(k)) + det_i(kk,2) = psi_det_beta_unique(kk,psi_bilinear_matrix_columns(k)) + enddo do l=1,n_det if (psi_bilinear_matrix_values(l,1) == 0.d0) then cycle endif cj = psi_bilinear_matrix_values(l,1) - det_j(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(l)) - det_j(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(l)) + do kk=1,N_int + det_j(kk,1) = psi_det_alpha_unique(kk,psi_bilinear_matrix_rows(l)) + det_j(kk,2) = psi_det_beta_unique(kk,psi_bilinear_matrix_columns(l)) + enddo call i_h_j(det_i, det_j, N_int, hij) num = num + ci*cj*hij enddo From 45183fdd8d8606c72128d99d1c245782525be797 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 29 Nov 2016 17:54:10 +0100 Subject: [PATCH 139/188] Fixed mrcc_selected --- plugins/Psiref_threshold/psi_ref.irp.f | 13 +- plugins/mrcc_selected/dressing.irp.f | 1008 +++++++++++++++++++ plugins/mrcc_selected/dressing_slave.irp.f | 593 +++++++++++ plugins/mrcc_selected/ezfio_interface.irp.f | 61 ++ plugins/mrcc_selected/mrcc_selected.irp.f | 19 + plugins/mrcc_selected/mrcepa0_general.irp.f | 245 +++++ src/Determinants/determinants.irp.f | 8 +- 7 files changed, 1940 insertions(+), 7 deletions(-) create mode 100644 plugins/mrcc_selected/dressing.irp.f create mode 100644 plugins/mrcc_selected/dressing_slave.irp.f create mode 100644 plugins/mrcc_selected/ezfio_interface.irp.f create mode 100644 plugins/mrcc_selected/mrcc_selected.irp.f create mode 100644 plugins/mrcc_selected/mrcepa0_general.irp.f diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f index 5e722822..ee69ef5c 100644 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ b/plugins/Psiref_threshold/psi_ref.irp.f @@ -6,19 +6,22 @@ use bitmasks &BEGIN_PROVIDER [ integer, N_det_ref ] implicit none BEGIN_DOC - ! Reference wave function, defined as determinants with coefficients > 0.05 + ! Reference wave function, defined as determinants with amplitudes > 0.05 ! idx_ref gives the indice of the ref determinant in psi_det. END_DOC integer :: i, k, l logical :: good - double precision, parameter :: threshold=0.05d0 + double precision, parameter :: threshold=0.05d0 + double precision :: t(N_states) N_det_ref = 0 - t = threshold * abs_psi_coef_max + do l = 1, N_states + t(l) = threshold * abs_psi_coef_max(l) + enddo do i=1,N_det good = .False. - do l = 1, N_states + do l=1, N_states psi_ref_coef(i,l) = 0.d0 - good = good.or.(dabs(psi_coef(i,l)) > t) + good = good.or.(dabs(psi_coef(i,l)) > t(l)) enddo if (good) then N_det_ref = N_det_ref+1 diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f new file mode 100644 index 00000000..3646b0b2 --- /dev/null +++ b/plugins/mrcc_selected/dressing.irp.f @@ -0,0 +1,1008 @@ +use bitmasks + + + + BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] + use bitmasks + implicit none + integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc + integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) + integer(bit_kind),allocatable :: buf(:,:,:) + logical :: ok + logical, external :: detEq + + delta_ij_mrcc = 0d0 + delta_ii_mrcc = 0d0 + print *, "Dij", dij(1,1,1) + provide hh_shortcut psi_det_size! lambda_mrcc + !$OMP PARALLEL DO default(none) schedule(dynamic) & + !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP private(h, n, mask, omask, buf, ok, iproc) + do gen= 1, N_det_generators + allocate(buf(N_int, 2, N_det_non_ref)) + iproc = omp_get_thread_num() + 1 + if(mod(gen, 1000) == 0) print *, "mrcc ", gen, "/", N_det_generators + do h=1, hh_shortcut(0) + call apply_hole_local(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) + if(.not. ok) cycle + omask = 0_bit_kind + if(hh_exists(1, h) /= 0) omask = mask + n = 1 + do p=hh_shortcut(h), hh_shortcut(h+1)-1 + call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) + if(ok) n = n + 1 + if(n > N_det_non_ref) stop "MRCC..." + end do + n = n - 1 + + if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + + end do + deallocate(buf) + end do + !$OMP END PARALLEL DO +END_PROVIDER + + +! subroutine blit(b1, b2) +! double precision :: b1(N_states,N_det_non_ref,N_det_ref), b2(N_states,N_det_non_ref,N_det_ref) +! b1 = b1 + b2 +! end subroutine + + +subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) + use bitmasks + implicit none + + integer, intent(in) :: i_generator,n_selected, Nint + double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + + integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) + integer :: i,j,k,l,m + integer,allocatable :: idx_alpha(:), degree_alpha(:) + logical :: good, fullMatch + + integer(bit_kind),allocatable :: tq(:,:,:) + integer :: N_tq, c_ref ,degree + + double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:) + double precision :: haj, phase, phase2 + double precision :: f(N_states), ci_inv(N_states) + integer :: exc(0:2,2,2) + integer :: h1,h2,p1,p2,s1,s2 + integer(bit_kind) :: tmp_det(Nint,2) + integer :: iint, ipos + integer :: i_state, k_sd, l_sd, i_I, i_alpha + + integer(bit_kind),allocatable :: miniList(:,:,:) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + integer,allocatable :: idx_miniList(:) + integer :: N_miniList, ni, leng + double precision, allocatable :: hij_cache(:) + + integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) + integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) + integer :: mobiles(2), smallerlist + logical, external :: detEq, is_generable + !double precision, external :: get_dij, get_dij_index + + + leng = max(N_det_generators, N_det_non_ref) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) + !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 + + allocate(ptr_microlist(0:mo_tot_num*2+1), & + N_microlist(0:mo_tot_num*2) ) + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + + if(key_mask(1,1) /= 0) then + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + call filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + else + call filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + end if + + + + deallocate(microlist, idx_microlist) + + allocate (dIa_hla(N_states,N_det_non_ref)) + + ! |I> + + ! |alpha> + + if(N_tq > 0) then + call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) + if(N_minilist == 0) return + + + if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! + allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) + + allocate( microlist(Nint,2,N_minilist*4), & + idx_microlist(N_minilist*4)) + call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) + + + do i=0,mo_tot_num*2 + do k=ptr_microlist(i),ptr_microlist(i+1)-1 + idx_microlist(k) = idx_minilist(idx_microlist(k)) + end do + end do + + do l=1,N_microlist(0) + do k=1,Nint + microlist_zero(k,1,l) = microlist(k,1,l) + microlist_zero(k,2,l) = microlist(k,2,l) + enddo + idx_microlist_zero(l) = idx_microlist(l) + enddo + end if + end if + + + do i_alpha=1,N_tq + if(key_mask(1,1) /= 0) then + call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) + + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + + do l=0,N_microlist(smallerlist)-1 + microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) + idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) + end do + + call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) + do j=1,idx_alpha(0) + idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) + end do + + else + 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)) + end do + end if + + + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + enddo + ! |I> + do i_I=1,N_det_ref + ! Find triples and quadruple grand parents + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) + if (degree > 4) then + cycle + endif + + do i_state=1,N_states + dIa(i_state) = 0.d0 + enddo + + ! |alpha> + do k_sd=1,idx_alpha(0) + ! Loop if lambda == 0 + logical :: loop +! loop = .True. +! do i_state=1,N_states +! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then +! loop = .False. +! exit +! endif +! enddo +! if (loop) then +! cycle +! endif + + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) + if (degree > 2) then + cycle + endif + + ! + ! + !hIk = hij_mrcc(idx_alpha(k_sd),i_I) + ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) + + do i_state=1,N_states + dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) + !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) + !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) + enddo + + + ! |l> = Exc(k -> alpha) |I> + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do k=1,N_int + tmp_det(k,1) = psi_ref(k,1,i_I) + tmp_det(k,2) = psi_ref(k,2,i_I) + enddo + logical :: ok + call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) + if(.not. ok) cycle + + ! + do i_state=1,N_states + dka(i_state) = 0.d0 + enddo + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then + +! loop = .True. +! do i_state=1,N_states +! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then +! loop = .False. +! exit +! endif +! enddo + loop = .false. + if (.not.loop) then + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) + hIl = hij_mrcc(idx_alpha(l_sd),i_I) +! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) + do i_state=1,N_states + dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 + !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 + !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 + enddo + endif + + exit + endif + enddo + do i_state=1,N_states + dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) + enddo + enddo + + do i_state=1,N_states + ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) + enddo + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + hla = hij_cache(k_sd) +! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) + do i_state=1,N_states + dIa_hla(i_state,k_sd) = dIa(i_state) * hla + enddo + enddo + call omp_set_lock( psi_ref_lock(i_I) ) + do i_state=1,N_states + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + enddo + else + delta_ii_(i_state,i_I) = 0.d0 + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + enddo + endif + enddo + call omp_unset_lock( psi_ref_lock(i_I) ) + enddo + enddo + deallocate (dIa_hla,hij_cache) + deallocate(miniList, idx_miniList) +end + + + + + BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] + use bitmasks + implicit none + integer :: i, j, i_state + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + + do i_state = 1, N_states + if(mrmode == 3) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + end do + end do +! +! do i = 1, N_det_ref +! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) +! do j = 1, N_det_non_ref +! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) +! end do +! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_ii_old(i_state,i) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) + end do + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) + do j = 1, N_det_non_ref + delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) + end do + end do + else + stop "invalid mrmode" + end if + end do +END_PROVIDER + + +BEGIN_PROVIDER [ integer, HP, (2,N_det_non_ref) ] + integer :: i + do i=1,N_det_non_ref + call getHP(psi_non_ref(1,1,i), HP(1,i), HP(2,i), N_int) + end do +END_PROVIDER + + BEGIN_PROVIDER [ integer, cepa0_shortcut, (0:N_det_non_ref+1) ] +&BEGIN_PROVIDER [ integer, det_cepa0_idx, (N_det_non_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0_active, (N_int,2,N_det_non_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_ref_active, (N_int,2,N_det_ref) ] +&BEGIN_PROVIDER [ integer(bit_kind), active_sorb, (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0, (N_int,2,N_det_non_ref) ] +&BEGIN_PROVIDER [ integer, nlink, (N_det_ref) ] +&BEGIN_PROVIDER [ integer, linked, (N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ integer, blokMwen, (N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, searchance, (N_det_ref) ] +&BEGIN_PROVIDER [ integer, child_num, (N_det_non_ref,N_det_ref) ] + + use bitmasks + implicit none + + integer(bit_kind),allocatable :: det_noactive(:,:,:) + integer, allocatable :: shortcut(:), idx(:) + integer(bit_kind) :: nonactive_sorb(N_int,2), det(N_int, 2) + integer i, II, j, k, n, ni, blok, degree + logical, external :: detEq + + allocate(det_noactive(N_int, 2, N_det_non_ref)) + allocate(idx(N_det_non_ref), shortcut(0:N_det_non_ref+1)) + print *, "pre start" + active_sorb(:,:) = 0_8 + nonactive_sorb(:,:) = not(0_8) + + if(N_det_ref > 1) then + do i=1, N_det_ref + do k=1, N_int + active_sorb(k,1) = ior(psi_ref(k,1,i), active_sorb(k,1)) + active_sorb(k,2) = ior(psi_ref(k,2,i), active_sorb(k,2)) + nonactive_sorb(k,1) = iand(psi_ref(k,1,i), nonactive_sorb(k,1)) + nonactive_sorb(k,2) = iand(psi_ref(k,2,i), nonactive_sorb(k,2)) + end do + end do + do k=1, N_int + active_sorb(k,1) = iand(active_sorb(k,1), not(nonactive_sorb(k,1))) + active_sorb(k,2) = iand(active_sorb(k,2), not(nonactive_sorb(k,2))) + end do + end if + + + do i=1, N_det_non_ref + do k=1, N_int + det_noactive(k,1,i) = iand(psi_non_ref(k,1,i), not(active_sorb(k,1))) + det_noactive(k,2,i) = iand(psi_non_ref(k,2,i), not(active_sorb(k,2))) + end do + end do + + call sort_dets_ab(det_noactive, det_cepa0_idx, cepa0_shortcut, N_det_non_ref, N_int) + + do i=1,N_det_non_ref + det_cepa0(:,:,i) = psi_non_ref(:,:,det_cepa0_idx(i)) + end do + + cepa0_shortcut(0) = 1 + cepa0_shortcut(1) = 1 + do i=2,N_det_non_ref + if(.not. detEq(det_noactive(1,1,i), det_noactive(1,1,i-1), N_int)) then + cepa0_shortcut(0) += 1 + cepa0_shortcut(cepa0_shortcut(0)) = i + end if + end do + cepa0_shortcut(cepa0_shortcut(0)+1) = N_det_non_ref+1 + + if(.true.) then + do i=1,cepa0_shortcut(0) + n = cepa0_shortcut(i+1) - cepa0_shortcut(i) + call sort_dets_ab(det_cepa0(1,1,cepa0_shortcut(i)), idx, shortcut, n, N_int) + do k=1,n + idx(k) = det_cepa0_idx(cepa0_shortcut(i)-1+idx(k)) + end do + det_cepa0_idx(cepa0_shortcut(i):cepa0_shortcut(i)+n-1) = idx(:n) + end do + end if + + + do i=1,N_det_ref + do k=1, N_int + det_ref_active(k,1,i) = iand(psi_ref(k,1,i), active_sorb(k,1)) + det_ref_active(k,2,i) = iand(psi_ref(k,2,i), active_sorb(k,2)) + end do + end do + + do i=1,N_det_non_ref + do k=1, N_int + det_cepa0_active(k,1,i) = iand(psi_non_ref(k,1,det_cepa0_idx(i)), active_sorb(k,1)) + det_cepa0_active(k,2,i) = iand(psi_non_ref(k,2,det_cepa0_idx(i)), active_sorb(k,2)) + end do + end do + + do i=1,N_det_non_ref + if(.not. detEq(psi_non_ref(1,1,det_cepa0_idx(i)), det_cepa0(1,1,i),N_int)) stop "STOOOP" + end do + + searchance = 0d0 + child_num = 0 + do J = 1, N_det_ref + nlink(J) = 0 + do blok=1,cepa0_shortcut(0) + do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 + call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) + if(degree <= 2) then + nlink(J) += 1 + linked(nlink(J),J) = k + child_num(k, J) = nlink(J) + blokMwen(nlink(J),J) = blok + searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) + end if + end do + end do + end do + print *, "pre done" +END_PROVIDER + + +! BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +! use bitmasks +! implicit none +! integer :: i,j,k +! double precision :: Hjk, Hki, Hij, pre(N_det_ref), wall +! integer :: i_state, degree, npre, ipre(N_det_ref), npres(N_det_ref) +! +! ! provide lambda_mrcc +! npres = 0 +! delta_cas = 0d0 +! call wall_time(wall) +! print *, "dcas ", wall +! do i_state = 1, N_states +! !!$OMP PARALLEL DO default(none) schedule(dynamic) private(pre,npre,ipre,j,k,Hjk,Hki,degree) shared(npres,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) +! do k=1,N_det_non_ref +! if(lambda_mrcc(i_state, k) == 0d0) cycle +! npre = 0 +! do i=1,N_det_ref +! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) +! if(Hki /= 0d0) then +! !!$OMP ATOMIC +! npres(i) += 1 +! npre += 1 +! ipre(npre) = i +! pre(npre) = Hki +! end if +! end do +! +! +! do i=1,npre +! do j=1,i +! !!$OMP ATOMIC +! delta_cas(ipre(i),ipre(j),i_state) += pre(i) * pre(j) * lambda_mrcc(i_state, k) +! end do +! end do +! end do +! !!$OMP END PARALLEL DO +! npre=0 +! do i=1,N_det_ref +! npre += npres(i) +! end do +! !stop +! do i=1,N_det_ref +! do j=1,i +! delta_cas(j,i,i_state) = delta_cas(i,j,i_state) +! end do +! end do +! end do +! +! call wall_time(wall) +! print *, "dcas", wall +! ! stop +! END_PROVIDER + + + BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] + use bitmasks + implicit none + integer :: i,j,k + double precision :: Hjk, Hki, Hij + !double precision, external :: get_dij + integer i_state, degree + + provide lambda_mrcc dIj + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + do i=1,N_det_ref + do j=1,i + call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) + delta_cas(i,j,i_state) = 0d0 + do k=1,N_det_non_ref + + call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + + delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) + !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + end do + delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + end do + end do + !$OMP END PARALLEL DO + end do + END_PROVIDER + + + + +logical function isInCassd(a,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2) + integer(bit_kind) :: inac, virt + integer :: ni, i, deg + + + isInCassd = .false. + + deg = 0 + do i=1,2 + do ni=1,Nint + virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) + deg += popcnt(iand(virt, a(ni,i))) + if(deg > 2) return + end do + end do + + deg = 0 + do i=1,2 + do ni=1,Nint + inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) + deg += popcnt(xor(iand(inac,a(ni,i)), inac)) + if(deg > 2) return + end do + end do + isInCassd = .true. +end function + + +subroutine getHP(a,h,p,Nint) + use bitmasks + implicit none + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: a(Nint,2) + integer, intent(out) :: h, p + integer(bit_kind) :: inac, virt + integer :: ni, i, deg + + + !isInCassd = .false. + h = 0 + p = 0 + + deg = 0 + lp : do i=1,2 + do ni=1,Nint + virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) + deg += popcnt(iand(virt, a(ni,i))) + if(deg > 2) exit lp + end do + end do lp + p = deg + + deg = 0 + lh : do i=1,2 + do ni=1,Nint + inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) + deg += popcnt(xor(iand(inac,a(ni,i)), inac)) + if(deg > 2) exit lh + end do + end do lh + h = deg + !isInCassd = .true. +end function + + + BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] + use bitmasks + implicit none + + integer :: i_state, i, i_I, J, k, degree, degree2, m, l, deg, ni + integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) + double precision :: contrib, contrib2, HIIi, HJk, wall + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) + integer(bit_kind),allocatable :: sortRef(:,:,:) + integer, allocatable :: idx_sorted_bit(:) + integer, external :: get_index_in_psi_det_sorted_bit, searchDet + logical, external :: is_in_wavefunction, detEq + !double precision, external :: get_dij + integer :: II, blok + integer*8, save :: notf = 0 + + call wall_time(wall) + allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) + + sortRef(:,:,:) = det_ref_active(:,:,:) + call sort_det(sortRef, sortRefIdx, N_det_ref, N_int) + + idx_sorted_bit(:) = -1 + do i=1,N_det_non_ref + idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i + enddo + + ! To provide everything + contrib = dij(1, 1, 1) + + do i_state = 1, N_states + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) + do blok=1,cepa0_shortcut(0) + do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 + do II=1,N_det_ref + call get_excitation_degree(psi_ref(1,1,II),psi_non_ref(1,1,det_cepa0_idx(i)),degree,N_int) + if (degree > 2 ) cycle + + do ni=1,N_int + made_hole(ni,1) = iand(det_ref_active(ni,1,II), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) + made_hole(ni,2) = iand(det_ref_active(ni,2,II), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) + + made_particle(ni,1) = iand(det_cepa0_active(ni,1,i), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) + made_particle(ni,2) = iand(det_cepa0_active(ni,2,i), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) + end do + + + kloop: do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 !i + !if(lambda_mrcc(i_state, det_cepa0_idx(k)) == 0d0) cycle + + do ni=1,N_int + if(iand(made_hole(ni,1), det_cepa0_active(ni,1,k)) /= 0) cycle kloop + if(iand(made_particle(ni,1), det_cepa0_active(ni,1,k)) /= made_particle(ni,1)) cycle kloop + if(iand(made_hole(ni,2), det_cepa0_active(ni,2,k)) /= 0) cycle kloop + if(iand(made_particle(ni,2), det_cepa0_active(ni,2,k)) /= made_particle(ni,2)) cycle kloop + end do + do ni=1,N_int + myActive(ni,1) = xor(det_cepa0_active(ni,1,k), made_hole(ni,1)) + myActive(ni,1) = xor(myActive(ni,1), made_particle(ni,1)) + myActive(ni,2) = xor(det_cepa0_active(ni,2,k), made_hole(ni,2)) + myActive(ni,2) = xor(myActive(ni,2), made_particle(ni,2)) + end do + + j = searchDet(sortRef, myActive, N_det_ref, N_int) + if(j == -1) then + cycle + end if + j = sortRefIdx(j) + !$OMP ATOMIC + notf = notf+1 + +! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) + contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + + if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + !$OMP ATOMIC + delta_mrcepa0_ii(J,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 + end if + !$OMP ATOMIC + delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + + end do kloop + end do + end do + end do + !$OMP END PARALLEL DO + end do + deallocate(idx_sorted_bit) + call wall_time(wall) + print *, "cepa0", wall, notf + !stop +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, delta_sub_ij, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_sub_ii, (N_det_ref, N_states) ] + use bitmasks + implicit none + + integer :: i_state, i, i_I, J, k, degree, degree2, l, deg, ni + integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ + logical :: ok + double precision :: phase_Ji, phase_Ik, phase_Ii + double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl + integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) + integer, allocatable :: idx_sorted_bit(:) + integer, external :: get_index_in_psi_det_sorted_bit + + integer :: II, blok + + provide delta_cas lambda_mrcc + allocate(idx_sorted_bit(N_det)) + idx_sorted_bit(:) = -1 + do i=1,N_det_non_ref + idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i + enddo + + do i_state = 1, N_states + delta_sub_ij(:,:,:) = 0d0 + delta_sub_ii(:,:) = 0d0 + + provide mo_bielec_integrals_in_map + + + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & + !$OMP private(i, J, k, degree, degree2, l, deg, ni) & + !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & + !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & + !$OMP private(det_tmp, det_tmp2, II, blok) & + !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & + !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) + do i=1,N_det_non_ref + if(mod(i,1000) == 0) print *, i, "/", N_det_non_ref + do J=1,N_det_ref + call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_Ji,degree,phase_Ji,N_int) + if(degree == -1) cycle + + + do II=1,N_det_ref + call apply_excitation(psi_ref(1,1,II),exc_Ji,det_tmp,ok,N_int) + + if(.not. ok) cycle + l = get_index_in_psi_det_sorted_bit(det_tmp, N_int) + if(l == 0) cycle + l = idx_sorted_bit(l) + + call i_h_j(psi_ref(1,1,II), det_tmp, N_int, HIl) + + do k=1,N_det_non_ref + if(lambda_mrcc(i_state, k) == 0d0) cycle + call get_excitation(psi_ref(1,1,II),psi_non_ref(1,1,k),exc_Ik,degree2,phase_Ik,N_int) + + det_tmp(:,:) = 0_bit_kind + det_tmp2(:,:) = 0_bit_kind + + ok = .true. + do ni=1,N_int + det_tmp(ni,1) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,k)), not(active_sorb(ni,1))) + det_tmp(ni,2) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,i)), not(active_sorb(ni,1))) + ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) + + det_tmp(ni,1) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,k)), not(active_sorb(ni,2))) + det_tmp(ni,2) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,i)), not(active_sorb(ni,2))) + ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) + end do + + if(ok) cycle + + + call i_h_j(psi_ref(1,1,J), psi_non_ref(1,1,k), N_int, HJk) + call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,k), N_int, HIk) + if(HJk == 0) cycle + !assert HIk == 0 + delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) + call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) + if(ok) cycle + contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) + if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then + contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) + !$OMP ATOMIC + delta_sub_ii(II,i_state) -= contrib2 + else + contrib = contrib * 0.5d0 + endif + !$OMP ATOMIC + delta_sub_ij(II, i, i_state) += contrib + end do + end do + end do + end do + !$OMP END PARALLEL DO + end do + deallocate(idx_sorted_bit) +END_PROVIDER + + +subroutine set_det_bit(det, p, s) + implicit none + integer(bit_kind),intent(inout) :: det(N_int, 2) + integer, intent(in) :: p, s + integer :: ni, pos + + ni = (p-1)/bit_kind_size + 1 + pos = mod(p-1, bit_kind_size) + det(ni,s) = ibset(det(ni,s), pos) +end subroutine + + +BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + implicit none + integer :: i,j + do i=1,N_det_ref + do j=1,N_det_non_ref + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + end do + end do +END_PROVIDER + + + +subroutine filter_tq(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,allocatable :: degree(:) + integer,allocatable :: idx(:) + logical :: good + + integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) + integer, intent(out) :: N_tq + + integer :: nt,ni + logical, external :: is_connected_to, is_generable + + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer,intent(in) :: N_miniList + + allocate(degree(psi_det_size)) + allocate(idx(0:psi_det_size)) + N_tq = 0 + + i_loop : do i=1,N_selected + do k=1, N_minilist + if(is_generable(miniList(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + + ! Select determinants that are triple or quadruple excitations + ! from the ref + good = .True. + call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) + !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector + do k=1,idx(0) + if (degree(k) < 3) then + good = .False. + exit + endif + enddo + if (good) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) 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 + endif + enddo i_loop +end + + +subroutine filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) + + 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,allocatable :: degree(:) + integer,allocatable :: idx(:) + logical :: good + + integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) + integer, intent(out) :: N_tq + + integer :: nt,ni + logical, external :: is_connected_to, is_generable + + integer(bit_kind),intent(in) :: microlist(Nint,2,*) + integer,intent(in) :: ptr_microlist(0:*) + integer,intent(in) :: N_microlist(0:*) + integer(bit_kind),intent(in) :: key_mask(Nint, 2) + + integer :: mobiles(2), smallerlist + + + allocate(degree(psi_det_size)) + allocate(idx(0:psi_det_size)) + N_tq = 0 + + i_loop : do i=1,N_selected + call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) + if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then + smallerlist = mobiles(1) + else + smallerlist = mobiles(2) + end if + + if(N_microlist(smallerlist) > 0) then + do k=ptr_microlist(smallerlist), ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 + if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + end if + + if(N_microlist(0) > 0) then + do k=1, N_microlist(0) + if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop + end do + end if + + ! Select determinants that are triple or quadruple excitations + ! from the ref + good = .True. + call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) + !good=(idx(0) == 0) tant que degree > 2 pas retourné par get_excitation_degree_vector + do k=1,idx(0) + if (degree(k) < 3) then + good = .False. + exit + endif + enddo + if (good) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) 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 + endif + enddo i_loop +end + + + + diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f new file mode 100644 index 00000000..f1d6f029 --- /dev/null +++ b/plugins/mrcc_selected/dressing_slave.irp.f @@ -0,0 +1,593 @@ +subroutine mrsc2_dressing_slave_tcp(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + call mrsc2_dressing_slave(0,i) +end + + +subroutine mrsc2_dressing_slave_inproc(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + call mrsc2_dressing_slave(1,i) +end + +subroutine mrsc2_dressing_slave(thread,iproc) + use f77_zmq + + implicit none + BEGIN_DOC +! Task for parallel MR-SC2 + END_DOC + integer, intent(in) :: thread, iproc +! integer :: j,l + integer :: rc + + integer :: worker_id, task_id + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + double precision, allocatable :: delta(:,:,:) + + + + integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, degree, degree2, m, l, deg, ni, m2 + integer :: n(2) + integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al + double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) + double precision :: contrib, wall, iwall + double precision, allocatable :: dleat(:,:,:) + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt + integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp + logical, external :: is_in_wavefunction, isInCassd, detEq + integer,allocatable :: komon(:) + logical :: komoned + !double precision, external :: get_dij + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate(komon(0:N_det_non_ref)) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if (task_id == 0) exit + read (task,*) i_I, J, k1, k2 + do i_state=1, N_states + ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) + cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) + end do + !delta = 0.d0 + n = 0 + delta(:,0,:) = 0d0 + delta(:,:nlink(J),1) = 0d0 + delta(:,:nlink(i_I),2) = 0d0 + komon(0) = 0 + komoned = .false. + + + + + do kk = k1, k2 + k = det_cepa0_idx(linked(kk, i_I)) + blok = blokMwen(kk, i_I) + + call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,k),exc_Ik,degree,phase_Ik,N_int) + + if(J /= i_I) then + call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int) + if(.not. ok) cycle + + l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2, cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int) + if(l == -1) cycle + ll = cepa0_shortcut(blok)-1+l + l = det_cepa0_idx(ll) + ll = child_num(ll, J) + else + l = k + ll = kk + end if + + + if(.not. komoned) then + m = 0 + m2 = 0 + + do while(m < nlink(i_I) .and. m2 < nlink(J)) + m += 1 + m2 += 1 + if(linked(m, i_I) < linked(m2, J)) then + m2 -= 1 + cycle + else if(linked(m, i_I) > linked(m2, J)) then + m -= 1 + cycle + end if + i = det_cepa0_idx(linked(m, i_I)) + + if(h_(J,i) == 0.d0) cycle + if(h_(i_I,i) == 0.d0) cycle + + !ok = .false. + !do i_state=1, N_states + ! if(lambda_mrcc(i_state, i) /= 0d0) then + ! ok = .true. + ! exit + ! end if + !end do + !if(.not. ok) cycle +! + + komon(0) += 1 + kn = komon(0) + komon(kn) = i + + +! call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ji,N_int) +! if(I_i /= J) call get_excitation(psi_ref(1,1,I_i),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ii,N_int) +! if(I_i == J) phase_Ii = phase_Ji + + do i_state = 1,N_states + dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) + !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dleat(i_state, kn, 1) = dkI + dleat(i_state, kn, 2) = dkI + end do + + end do + + komoned = .true. + end if + + + do m = 1, komon(0) + + i = komon(m) + + call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) + if(.not. ok) cycle + if(HP(1,i) + HP(1,k) <= 2 .and. HP(2,i) + HP(2,k) <= 2) then +! if(is_in_wavefunction(det_tmp, N_int)) cycle + cycle + end if + + !if(isInCassd(det_tmp, N_int)) cycle + + do i_state = 1, N_states + !if(lambda_mrcc(i_state, i) == 0d0) cycle + + + !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + delta(i_state,ll,1) += contrib + if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then + delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + endif + + if(I_i == J) cycle + !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + delta(i_state,kk,2) += contrib + if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + end if + enddo !i_state + end do ! while + end do ! kk + + + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) + +! end if + + enddo + + deallocate(delta) + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + +end + + +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + + integer, intent(in) :: i_I, J + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + integer, intent(in) :: task_id + integer :: rc , i_state, i, kk, li + integer,allocatable :: idx(:,:) + integer :: n(2) + logical :: ok + + allocate(idx(N_det_non_ref,2)) + rc = f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + + do kk=1,2 + n(kk)=0 + if(kk == 1) li = nlink(j) + if(kk == 2) li = nlink(i_I) + do i=1, li + ok = .false. + do i_state=1,N_states + if(delta(i_state, i, kk) /= 0d0) then + ok = .true. + exit + end if + end do + + if(ok) then + n(kk) += 1 +! idx(n,kk) = i + if(kk == 1) then + idx(n(1),1) = det_cepa0_idx(linked(i, J)) + else + idx(n(2),2) = det_cepa0_idx(linked(i, i_I)) + end if + + do i_state=1, N_states + delta(i_state, n(kk), kk) = delta(i_state, i, kk) + end do + end if + end do + + rc = f77_zmq_send( zmq_socket_push, n(kk), 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, n, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + if(n(kk) /= 0) then + rc = f77_zmq_send( zmq_socket_push, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta(1,0,1) = delta_I delta(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) + if (rc /= n(kk)*4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)' + stop 'error' + endif + end if + end do + + + rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' + stop 'error' + endif + +! ! Activate is zmq_socket_push is a REQ +! integer :: idummy +! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' +! stop 'error' +! endif +end + + + +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + use f77_zmq + implicit none + BEGIN_DOC +! Push integrals in the push socket + END_DOC + + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + integer, intent(out) :: i_I, J, n(2) + double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + integer, intent(out) :: task_id + integer :: rc , i, kk + integer,intent(inout) :: idx(N_det_non_ref,2) + logical :: ok + + rc = f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + do kk = 1, 2 + rc = f77_zmq_recv( zmq_socket_pull, n(kk), 4, ZMQ_SNDMORE) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, ZMQ_SNDMORE)' + stop 'error' + endif + + if(n(kk) /= 0) then + rc = f77_zmq_recv( zmq_socket_pull, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) + if (rc /= n(kk)*4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + stop 'error' + endif + end if + end do + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' + stop 'error' + endif + + +! ! Activate is zmq_socket_pull is a REP +! integer :: idummy +! rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) +! if (rc /= 4) then +! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' +! stop 'error' +! endif +end + + + +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the AO integral calculation + END_DOC + + double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + +! integer :: j,l + integer :: rc + + double precision, allocatable :: delta(:,:,:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer*8 :: control, accu + integer :: task_id, more + + integer :: I_i, J, l, i_state, n(2), kk + integer,allocatable :: idx(:,:) + + delta_ii_(:,:) = 0d0 + delta_ij_(:,:,:) = 0d0 + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + + allocate ( delta(N_states,0:N_det_non_ref,2) ) + + allocate(idx(N_det_non_ref,2)) + more = 1 + do while (more == 1) + + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + + + do l=1, n(1) + do i_state=1,N_states + delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + end do + end do + + do l=1, n(2) + do i_state=1,N_states + delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + end do + end do + + +! +! do l=1,nlink(J) +! do i_state=1,N_states +! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) +! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) +! end do +! end do +! + if(n(1) /= 0) then + do i_state=1,N_states + delta_ii_(i_state,i_I) += delta(i_state,0,1) + end do + end if + + if(n(2) /= 0) then + do i_state=1,N_states + delta_ii_(i_state,J) += delta(i_state,0,2) + end do + end if + + + if (task_id /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif + + + enddo + deallocate( delta ) + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + +end + + + + + BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] + implicit none + + integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 + integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, nex, nzer, ntot +! integer, allocatable :: linked(:,:), blokMwen(:, :), nlink(:) + logical :: ok + double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al, diI, hIi, hJi, delta_JI, dkI(N_states), HkI, ci_inv(N_states), dia_hla(N_states) + double precision :: contrib, wall, iwall ! , searchance(N_det_ref) + integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ + integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt + integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp + logical, external :: is_in_wavefunction, isInCassd, detEq + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer :: KKsize = 1000000 + + + call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') + + + call wall_time(iwall) +! allocate(linked(N_det_non_ref, N_det_ref), blokMwen(N_det_non_ref, N_det_ref), nlink(N_det_ref)) + + +! searchance = 0d0 +! do J = 1, N_det_ref +! nlink(J) = 0 +! do blok=1,cepa0_shortcut(0) +! do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 +! call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) +! if(degree <= 2) then +! nlink(J) += 1 +! linked(nlink(J),J) = k +! blokMwen(nlink(J),J) = blok +! searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) +! end if +! end do +! end do +! end do + + + +! stop + nzer = 0 + ntot = 0 + do nex = 3, 0, -1 + print *, "los ",nex + do I_s = N_det_ref, 1, -1 +! if(mod(I_s,1) == 0) then +! call wall_time(wall) +! wall = wall-iwall +! print *, I_s, "/", N_det_ref, wall * (dfloat(N_det_ref) / dfloat(I_s)), wall, wall * (dfloat(N_det_ref) / dfloat(I_s))-wall +! end if + + + do J_s = 1, I_s + + call get_excitation_degree(psi_ref(1,1,J_s), psi_ref(1,1,I_s), degree, N_int) + if(degree /= nex) cycle + if(nex == 3) nzer = nzer + 1 + ntot += 1 +! if(degree > 3) then +! deg += 1 +! cycle +! else if(degree == -10) then +! KKsize = 100000 +! else +! KKsize = 1000000 +! end if + + + + if(searchance(I_s) < searchance(J_s)) then + i_I = I_s + J = J_s + else + i_I = J_s + J = I_s + end if + + KKsize = nlink(1) + if(nex == 0) KKsize = int(float(nlink(1)) / float(nlink(i_I)) * (float(nlink(1)) / 64d0)) + + !if(KKsize == 0) stop "ZZEO" + + do kk = 1 , nlink(i_I), KKsize + write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I))) + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + ! do kk = 1 , nlink(i_I) + ! k = linked(kk,i_I) + ! blok = blokMwen(kk,i_I) + ! write(task,*) I_i, J, k, blok + ! call add_task_to_taskserver(zmq_to_qp_run_socket,task) + ! + ! enddo !kk + enddo !J + + enddo !I + end do ! nex + print *, "tasked" +! integer(ZMQ_PTR) ∷ collector_thread +! external ∷ ao_bielec_integrals_in_map_collector +! rc = pthread_create(collector_thread, mrsc2_dressing_collector) + print *, nzer, ntot, float(nzer) / float(ntot) + provide nproc + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + else + call mrsc2_dressing_slave_inproc(i) + endif + !$OMP END PARALLEL + +! rc = pthread_join(collector_thread) + call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2') + + +END_PROVIDER + + + diff --git a/plugins/mrcc_selected/ezfio_interface.irp.f b/plugins/mrcc_selected/ezfio_interface.irp.f new file mode 100644 index 00000000..062af449 --- /dev/null +++ b/plugins/mrcc_selected/ezfio_interface.irp.f @@ -0,0 +1,61 @@ +! DO NOT MODIFY BY HAND +! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py +! from file /home/scemama/quantum_package/src/mrcc_selected/EZFIO.cfg + + +BEGIN_PROVIDER [ double precision, thresh_dressed_ci ] + implicit none + BEGIN_DOC +! Threshold on the convergence of the dressed CI energy + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrcc_selected_thresh_dressed_ci(has) + if (has) then + call ezfio_get_mrcc_selected_thresh_dressed_ci(thresh_dressed_ci) + else + print *, 'mrcc_selected/thresh_dressed_ci not found in EZFIO file' + stop 1 + endif + +END_PROVIDER + +BEGIN_PROVIDER [ integer, n_it_max_dressed_ci ] + implicit none + BEGIN_DOC +! Maximum number of dressed CI iterations + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrcc_selected_n_it_max_dressed_ci(has) + if (has) then + call ezfio_get_mrcc_selected_n_it_max_dressed_ci(n_it_max_dressed_ci) + else + print *, 'mrcc_selected/n_it_max_dressed_ci not found in EZFIO file' + stop 1 + endif + +END_PROVIDER + +BEGIN_PROVIDER [ integer, lambda_type ] + implicit none + BEGIN_DOC +! lambda type + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrcc_selected_lambda_type(has) + if (has) then + call ezfio_get_mrcc_selected_lambda_type(lambda_type) + else + print *, 'mrcc_selected/lambda_type not found in EZFIO file' + stop 1 + endif + +END_PROVIDER diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f new file mode 100644 index 00000000..91592e62 --- /dev/null +++ b/plugins/mrcc_selected/mrcc_selected.irp.f @@ -0,0 +1,19 @@ +program mrsc2sub + implicit none + double precision, allocatable :: energy(:) + allocate (energy(N_states)) + + !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc + mrmode = 3 + + read_wf = .True. + SOFT_TOUCH read_wf + call print_cas_coefs + call set_generators_bitmasks_as_holes_and_particles + call run(N_states,energy) + if(do_pt2_end)then + call run_pt2(N_states,energy) + endif + deallocate(energy) +end + diff --git a/plugins/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f new file mode 100644 index 00000000..e3a2d1f5 --- /dev/null +++ b/plugins/mrcc_selected/mrcepa0_general.irp.f @@ -0,0 +1,245 @@ + + +subroutine run(N_st,energy) + implicit none + + integer, intent(in) :: N_st + double precision, intent(out) :: energy(N_st) + + integer :: i,j + + double precision :: E_new, E_old, delta_e + integer :: iteration + double precision :: E_past(4) + + integer :: n_it_mrcc_max + double precision :: thresh_mrcc + double precision, allocatable :: lambda(:) + allocate (lambda(N_states)) + + + thresh_mrcc = thresh_dressed_ci + n_it_mrcc_max = n_it_max_dressed_ci + + if(n_it_mrcc_max == 1) then + do j=1,N_states_diag + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors_dressed(i,j) + enddo + enddo + SOFT_TOUCH psi_coef ci_energy_dressed + call write_double(6,ci_energy_dressed(1),"Final MRCC energy") + call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) + call save_wavefunction + energy(:) = ci_energy_dressed(:) + else + E_new = 0.d0 + delta_E = 1.d0 + iteration = 0 + lambda = 1.d0 + do while (delta_E > thresh_mrcc) + iteration += 1 + print *, '===========================' + print *, 'MRCEPA0 Iteration', iteration + print *, '===========================' + print *, '' + E_old = sum(ci_energy_dressed) + call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") + call diagonalize_ci_dressed(lambda) + E_new = sum(ci_energy_dressed) + delta_E = dabs(E_new - E_old) + call save_wavefunction + call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) + if (iteration >= n_it_mrcc_max) then + exit + endif + enddo + call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") + energy(:) = ci_energy_dressed(:) + endif +end + + +subroutine print_cas_coefs + implicit none + + integer :: i,j + print *, 'CAS' + print *, '===' + do i=1,N_det_cas + print *, (psi_cas_coef(i,j), j=1,N_states) + call debug_det(psi_cas(1,1,i),N_int) + enddo + call write_double(6,ci_energy(1),"Initial CI energy") + +end + + + + +subroutine run_pt2_old(N_st,energy) + implicit none + integer :: i,j,k + integer, intent(in) :: N_st + double precision, intent(in) :: energy(N_st) + double precision :: pt2_redundant(N_st), pt2(N_st) + double precision :: norm_pert(N_st),H_pert_diag(N_st) + + pt2_redundant = 0.d0 + pt2 = 0d0 + !if(lambda_mrcc_pt2(0) == 0) return + + print*,'Last iteration only to compute the PT2' + + print * ,'Computing the redundant PT2 contribution' + + if (mrmode == 1) then + + N_det_generators = lambda_mrcc_kept(0) + N_det_selectors = lambda_mrcc_kept(0) + + do i=1,N_det_generators + j = lambda_mrcc_kept(i) + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + else + + N_det_generators = N_det_non_ref + N_det_selectors = N_det_non_ref + + do i=1,N_det_generators + j = i + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + endif + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2_redundant, norm_pert, H_pert_diag, N_st) + + print * ,'Computing the remaining contribution' + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + + N_det_generators = N_det_non_ref + N_det_ref + N_det_selectors = N_det_non_ref + N_det_ref + + psi_det_generators(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) + psi_selectors(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) + psi_coef_generators(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) + psi_selectors_coef(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) + + do i=N_det_ref+1,N_det_generators + j = i-N_det_ref + do k=1,N_int + psi_det_generators(k,1,i) = psi_non_ref(k,1,j) + psi_det_generators(k,2,i) = psi_non_ref(k,2,j) + psi_selectors(k,1,i) = psi_non_ref(k,1,j) + psi_selectors(k,2,i) = psi_non_ref(k,2,j) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_non_ref_coef(j,k) + psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) + enddo + enddo + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) + + + print *, "Redundant PT2 :",pt2_redundant + print *, "Full PT2 :",pt2 + print *, lambda_mrcc_kept(0), N_det, N_det_ref, psi_coef(1,1), psi_ref_coef(1,1) + pt2 = pt2 - pt2_redundant + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', energy + print *, 'E+PT2 = ', energy+pt2 + print *, '-----' + + + call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) + +end + +subroutine run_pt2(N_st,energy) + implicit none + integer :: i,j,k + integer, intent(in) :: N_st + double precision, intent(in) :: energy(N_st) + double precision :: pt2(N_st) + double precision :: norm_pert(N_st),H_pert_diag(N_st) + + pt2 = 0d0 + !if(lambda_mrcc_pt2(0) == 0) return + + print*,'Last iteration only to compute the PT2' + + N_det_generators = N_det_cas + N_det_selectors = N_det_non_ref + + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_ref(k,1,i) + psi_det_generators(k,2,i) = psi_ref(k,2,i) + enddo + do k=1,N_st + psi_coef_generators(i,k) = psi_ref_coef(i,k) + enddo + enddo + do i=1,N_det + do k=1,N_int + psi_selectors(k,1,i) = psi_det_sorted(k,1,i) + psi_selectors(k,2,i) = psi_det_sorted(k,2,i) + enddo + do k=1,N_st + psi_selectors_coef(i,k) = psi_coef_sorted(i,k) + enddo + enddo + + SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed + SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized + + call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) + +! call ezfio_set_full_ci_energy_pt2(energy+pt2) + + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', pt2 + print *, 'E = ', energy + print *, 'E+PT2 = ', energy+pt2 + print *, '-----' + + call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) + +end + diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 39b0f58e..f690c790 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -438,8 +438,12 @@ end do i=1,N_states psi_coef_min(i) = minval(psi_coef(:,i)) psi_coef_max(i) = maxval(psi_coef(:,i)) - abs_psi_coef_min(i) = dabs(psi_coef_min(i)) - abs_psi_coef_max(i) = dabs(psi_coef_max(i)) + abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) ) + abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) ) + call write_double(6,psi_coef_max(i), 'Max coef') + call write_double(6,psi_coef_min(i), 'Min coef') + call write_double(6,abs_psi_coef_max(i), 'Max abs coef') + call write_double(6,abs_psi_coef_min(i), 'Min abs coef') enddo END_PROVIDER From 13c1b5d47cbfe8c49a5a454720e96bcaddf0fa04 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 11:32:40 +0100 Subject: [PATCH 140/188] Restored symmetrization --- plugins/MRCC_Utils/davidson.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 3 +-- plugins/mrcepa0/dressing.irp.f | 24 ++++++++++++------------ 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index e667d255..70e73ec2 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -807,7 +807,7 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! Diagonalize h ! ------------- call lapack_diag(lambda,y,h,size(h,1),shift2) - + ! Compute S2 for each eigenvector ! ------------------------------- diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 0540eed9..da00b824 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -764,7 +764,7 @@ END_PROVIDER print *, "res ", k, res end if - if(res < 1d-12) exit + if(res < 1d-10) exit end do norm = 0.d0 @@ -982,7 +982,6 @@ double precision function get_dij_index(II, i, s, Nint) else if(lambda_type == 2) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index end if end function diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 0c67ab99..c772e2aa 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -300,22 +300,22 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen enddo call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states -! if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then -! do l_sd=1,idx_alpha(0) -! k_sd = idx_alpha(l_sd) -! delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) -! delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) -! delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) -! delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) -! enddo -! else + if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then + do l_sd=1,idx_alpha(0) + k_sd = idx_alpha(l_sd) + delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + enddo + else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo -! endif + endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo @@ -784,7 +784,7 @@ end function contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC @@ -895,7 +895,7 @@ END_PROVIDER call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) if(ok) cycle contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) - if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then + if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) !$OMP ATOMIC delta_sub_ii(II,i_state) -= contrib2 From d00c312361962f50789a649925b531fa15ef53d5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 17:02:28 +0100 Subject: [PATCH 141/188] Moved MRPT_Utils --- {src => plugins}/MRPT_Utils/EZFIO.cfg | 0 {src => plugins}/MRPT_Utils/H_apply.irp.f | 0 .../MRPT_Utils/NEEDED_CHILDREN_MODULES | 0 {src => plugins}/MRPT_Utils/README.rst | 0 .../MRPT_Utils/energies_cas.irp.f | 0 .../MRPT_Utils/excitations_cas.irp.f | 0 plugins/MRPT_Utils/ezfio_interface.irp.f | 23 +++++++++++++++++++ .../MRPT_Utils/fock_like_operators.irp.f | 0 {src => plugins}/MRPT_Utils/give_2h2p.irp.f | 0 {src => plugins}/MRPT_Utils/mrpt_dress.irp.f | 0 {src => plugins}/MRPT_Utils/mrpt_utils.irp.f | 0 {src => plugins}/MRPT_Utils/new_way.irp.f | 0 .../new_way_second_order_coef.irp.f | 0 .../MRPT_Utils/psi_active_prov.irp.f | 0 .../MRPT_Utils/second_order_new.irp.f | 0 .../MRPT_Utils/second_order_new_2p.irp.f | 0 .../MRPT_Utils/utils_bitmask.irp.f | 0 17 files changed, 23 insertions(+) rename {src => plugins}/MRPT_Utils/EZFIO.cfg (100%) rename {src => plugins}/MRPT_Utils/H_apply.irp.f (100%) rename {src => plugins}/MRPT_Utils/NEEDED_CHILDREN_MODULES (100%) rename {src => plugins}/MRPT_Utils/README.rst (100%) rename {src => plugins}/MRPT_Utils/energies_cas.irp.f (100%) rename {src => plugins}/MRPT_Utils/excitations_cas.irp.f (100%) create mode 100644 plugins/MRPT_Utils/ezfio_interface.irp.f rename {src => plugins}/MRPT_Utils/fock_like_operators.irp.f (100%) rename {src => plugins}/MRPT_Utils/give_2h2p.irp.f (100%) rename {src => plugins}/MRPT_Utils/mrpt_dress.irp.f (100%) rename {src => plugins}/MRPT_Utils/mrpt_utils.irp.f (100%) rename {src => plugins}/MRPT_Utils/new_way.irp.f (100%) rename {src => plugins}/MRPT_Utils/new_way_second_order_coef.irp.f (100%) rename {src => plugins}/MRPT_Utils/psi_active_prov.irp.f (100%) rename {src => plugins}/MRPT_Utils/second_order_new.irp.f (100%) rename {src => plugins}/MRPT_Utils/second_order_new_2p.irp.f (100%) rename {src => plugins}/MRPT_Utils/utils_bitmask.irp.f (100%) diff --git a/src/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg similarity index 100% rename from src/MRPT_Utils/EZFIO.cfg rename to plugins/MRPT_Utils/EZFIO.cfg diff --git a/src/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f similarity index 100% rename from src/MRPT_Utils/H_apply.irp.f rename to plugins/MRPT_Utils/H_apply.irp.f diff --git a/src/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES similarity index 100% rename from src/MRPT_Utils/NEEDED_CHILDREN_MODULES rename to plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES diff --git a/src/MRPT_Utils/README.rst b/plugins/MRPT_Utils/README.rst similarity index 100% rename from src/MRPT_Utils/README.rst rename to plugins/MRPT_Utils/README.rst diff --git a/src/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f similarity index 100% rename from src/MRPT_Utils/energies_cas.irp.f rename to plugins/MRPT_Utils/energies_cas.irp.f diff --git a/src/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f similarity index 100% rename from src/MRPT_Utils/excitations_cas.irp.f rename to plugins/MRPT_Utils/excitations_cas.irp.f diff --git a/plugins/MRPT_Utils/ezfio_interface.irp.f b/plugins/MRPT_Utils/ezfio_interface.irp.f new file mode 100644 index 00000000..6bd8931d --- /dev/null +++ b/plugins/MRPT_Utils/ezfio_interface.irp.f @@ -0,0 +1,23 @@ +! DO NOT MODIFY BY HAND +! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py +! from file /home/scemama/quantum_package/src/MRPT_Utils/EZFIO.cfg + + +BEGIN_PROVIDER [ logical, do_third_order_1h1p ] + implicit none + BEGIN_DOC +! If true, compute the third order contribution for the 1h1p + END_DOC + + logical :: has + PROVIDE ezfio_filename + + call ezfio_has_mrpt_utils_do_third_order_1h1p(has) + if (has) then + call ezfio_get_mrpt_utils_do_third_order_1h1p(do_third_order_1h1p) + else + print *, 'mrpt_utils/do_third_order_1h1p not found in EZFIO file' + stop 1 + endif + +END_PROVIDER diff --git a/src/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f similarity index 100% rename from src/MRPT_Utils/fock_like_operators.irp.f rename to plugins/MRPT_Utils/fock_like_operators.irp.f diff --git a/src/MRPT_Utils/give_2h2p.irp.f b/plugins/MRPT_Utils/give_2h2p.irp.f similarity index 100% rename from src/MRPT_Utils/give_2h2p.irp.f rename to plugins/MRPT_Utils/give_2h2p.irp.f diff --git a/src/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f similarity index 100% rename from src/MRPT_Utils/mrpt_dress.irp.f rename to plugins/MRPT_Utils/mrpt_dress.irp.f diff --git a/src/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f similarity index 100% rename from src/MRPT_Utils/mrpt_utils.irp.f rename to plugins/MRPT_Utils/mrpt_utils.irp.f diff --git a/src/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f similarity index 100% rename from src/MRPT_Utils/new_way.irp.f rename to plugins/MRPT_Utils/new_way.irp.f diff --git a/src/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f similarity index 100% rename from src/MRPT_Utils/new_way_second_order_coef.irp.f rename to plugins/MRPT_Utils/new_way_second_order_coef.irp.f diff --git a/src/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f similarity index 100% rename from src/MRPT_Utils/psi_active_prov.irp.f rename to plugins/MRPT_Utils/psi_active_prov.irp.f diff --git a/src/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f similarity index 100% rename from src/MRPT_Utils/second_order_new.irp.f rename to plugins/MRPT_Utils/second_order_new.irp.f diff --git a/src/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f similarity index 100% rename from src/MRPT_Utils/second_order_new_2p.irp.f rename to plugins/MRPT_Utils/second_order_new_2p.irp.f diff --git a/src/MRPT_Utils/utils_bitmask.irp.f b/plugins/MRPT_Utils/utils_bitmask.irp.f similarity index 100% rename from src/MRPT_Utils/utils_bitmask.irp.f rename to plugins/MRPT_Utils/utils_bitmask.irp.f From bc1e564f17d08b95ec034a9f36309ba84fb47e80 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 17:33:34 +0100 Subject: [PATCH 142/188] Fixed Travis --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 47 ++++++++++++++++------- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 60 +++++++++++++++--------------- src/Davidson/diagonalize_CI.irp.f | 1 + tests/bats/cassd.bats | 2 +- tests/bats/mrcepa0.bats | 2 +- tests/bats/pseudo.bats | 2 +- 6 files changed, 69 insertions(+), 45 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 6844ed90..57b71fe8 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -5,11 +5,15 @@ program fci_zmq double precision, allocatable :: pt2(:) integer :: degree + double precision :: threshold_davidson_in allocate (pt2(N_states)) pt2 = 1.d0 - diag_algorithm = "Lapack" + threshold_davidson_in = threshold_davidson + threshold_davidson = 1.d-5 + SOFT_TOUCH threshold_davidson + if (N_det > N_det_max) then call diagonalize_CI @@ -33,20 +37,11 @@ program fci_zmq double precision :: E_CI_before(N_states) - integer :: n_det_before + integer :: n_det_before, to_select print*,'Beginning the selection ...' E_CI_before(1:N_states) = CI_energy(1:N_states) do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) - n_det_before = N_det - call ZMQ_selection(max(256-N_det, N_det), pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - call diagonalize_CI - call save_wavefunction print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -71,12 +66,38 @@ program fci_zmq endif E_CI_before(1:N_states) = CI_energy(1:N_states) call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = 3*N_det + to_select = max(256-to_select, to_select) + to_select = min(to_select,N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + TOUCH threshold_davidson + endif + call diagonalize_CI + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) enddo + + if (N_det < N_det_max) then + threshold_davidson = threshold_davidson_in + TOUCH threshold_davidson + call diagonalize_CI + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + endif integer :: exc_max, degree_min exc_max = 0 print *, 'CAS determinants : ', N_det_cas - do i=1,min(N_det_cas,10) + do i=1,min(N_det_cas,20) do k=i,N_det_cas call get_excitation_degree(psi_cas(1,1,k),psi_cas(1,1,i),degree,N_int) exc_max = max(exc_max,degree) @@ -108,7 +129,7 @@ program fci_zmq endif call save_wavefunction call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) - call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before+pt2) + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 382e8652..dc11b01d 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -11,10 +11,9 @@ program fci_zmq allocate (pt2(N_states)) pt2 = 1.d0 - diag_algorithm = "Lapack" threshold_davidson_in = threshold_davidson + threshold_davidson = 1.d-5 SOFT_TOUCH threshold_davidson - threshold_davidson = 1.d-4 if (N_det > N_det_max) then call diagonalize_CI @@ -43,31 +42,6 @@ program fci_zmq n_det_before = 0 do while ( (N_det < N_det_max) .and. (maxval(abs(pt2(1:N_states))) > pt2_max) ) - n_det_before = N_det - to_select = 3*N_det - to_select = max(1024-to_select, to_select) - to_select = min(to_select, N_det_max-n_det_before) - call ZMQ_selection(to_select, pt2) - - PROVIDE psi_coef - PROVIDE psi_det - PROVIDE psi_det_sorted - - if (N_det == N_det_max) then - threshold_davidson = threshold_davidson_in - SOFT_TOUCH threshold_davidson - endif - call diagonalize_CI - call save_wavefunction - -! if (N_det > N_det_max) then -! psi_det = psi_det_sorted -! psi_coef = psi_coef_sorted -! N_det = N_det_max -! soft_touch N_det psi_det psi_coef -! call diagonalize_CI -! call save_wavefunction -! endif print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -91,9 +65,35 @@ program fci_zmq enddo endif E_CI_before(1:N_states) = CI_energy(1:N_states) - call ezfio_set_full_ci_zmq_energy(CI_energy) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = 3*N_det + to_select = max(1024-to_select, to_select) + to_select = min(to_select, N_det_max-n_det_before) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + if (N_det == N_det_max) then + threshold_davidson = threshold_davidson_in + TOUCH threshold_davidson + endif + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) enddo + if (N_det < N_det_max) then + threshold_davidson = threshold_davidson_in + SOFT_TOUCH threshold_davidson + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + endif + if(do_pt2_end)then print*,'Last iteration only to compute the PT2' threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) @@ -111,9 +111,11 @@ program fci_zmq print *, 'E+PT2 = ', E_CI_before+pt2 print *, '-----' enddo - call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) endif call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f index 3b2c9ed0..e1b67438 100644 --- a/src/Davidson/diagonalize_CI.irp.f +++ b/src/Davidson/diagonalize_CI.irp.f @@ -40,6 +40,7 @@ END_PROVIDER double precision, allocatable :: e_array(:) integer, allocatable :: iorder(:) + PROVIDE threshold_davidson ! Guess values for the "N_states" states of the CI_eigenvectors do j=1,min(N_states,N_det) do i=1,N_det diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index f43ffaaa..258c7b51 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.23109 2.E-5 + eq $energy -76.231196 2.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index ed69681f..b06be4f2 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.238562120457431 1.e-4 + eq $energy -76.238562192068 1.e-4 } @test "MRCC H2O cc-pVDZ" { diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index a20b0842..4b374d76 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -48,6 +48,6 @@ function run_FCI_ZMQ() { @test "FCI H2O VDZ pseudo" { qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]" - run_FCI_ZMQ h2o_pseudo.ezfio 2000 -0.170399597228904E+02 -0.170400168816800E+02 + run_FCI_ZMQ h2o_pseudo.ezfio 2000 -17.0399584106077 -17.0400170044515 } From 222497d6ed31c5090bf1e14504556b825b1831a0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 18:53:13 +0100 Subject: [PATCH 143/188] Fixed Travis --- plugins/MRCC_Utils/amplitudes.irp.f | 3 +- plugins/MRCC_Utils/davidson.irp.f | 1 + plugins/mrcc_selected/dressing.irp.f | 168 +++++++++++++++------ plugins/mrcc_selected/dressing_slave.irp.f | 86 +++++++---- tests/bats/cassd.bats | 2 +- tests/bats/mrcepa0.bats | 8 +- 6 files changed, 183 insertions(+), 85 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 72d3ea67..b38402a2 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -170,7 +170,6 @@ END_PROVIDER do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) wk = 0 - if(mod(at_roww, 100) == 0) print *, "AtA", at_row, "/", hh_nex do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) @@ -224,7 +223,7 @@ END_PROVIDER deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t) !$OMP END PARALLEL - print *, "ATA SIZE", ata_size + print *, "At.A SIZE", ata_size END_PROVIDER diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 70e73ec2..2c9f5f03 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -1040,6 +1040,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + PROVIDE delta_ij_s2 !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8, & diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f index 3646b0b2..c772e2aa 100644 --- a/plugins/mrcc_selected/dressing.irp.f +++ b/plugins/mrcc_selected/dressing.irp.f @@ -4,6 +4,8 @@ use bitmasks BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] use bitmasks implicit none integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc @@ -14,11 +16,13 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 - print *, "Dij", dij(1,1,1) + delta_ij_s2_mrcc = 0d0 + delta_ii_s2_mrcc = 0d0 + PROVIDE dij provide hh_shortcut psi_det_size! lambda_mrcc !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & + !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) @@ -37,7 +41,9 @@ use bitmasks end do n = n - 1 - if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + if(n /= 0) then + call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) + endif end do deallocate(buf) @@ -52,13 +58,15 @@ END_PROVIDER ! end subroutine -subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffer,Nint,key_mask) +subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) use bitmasks implicit none integer, intent(in) :: i_generator,n_selected, Nint double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,l,m @@ -68,8 +76,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),allocatable :: tq(:,:,:) integer :: N_tq, c_ref ,degree - double precision :: hIk, hla, hIl, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) integer :: exc(0:2,2,2) @@ -82,7 +90,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe integer(bit_kind),intent(in) :: key_mask(Nint, 2) integer,allocatable :: idx_miniList(:) integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:) + double precision, allocatable :: hij_cache(:), sij_cache(:) integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) @@ -92,7 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) + allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) !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) @@ -117,7 +125,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe deallocate(microlist, idx_microlist) - allocate (dIa_hla(N_states,N_det_non_ref)) + allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) ! |I> @@ -185,6 +193,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) + call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo ! |I> do i_I=1,N_det_ref @@ -282,31 +291,36 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) + sla = sij_cache(k_sd) ! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla + dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then + if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) enddo else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo - deallocate (dIa_hla,hij_cache) + deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) deallocate(miniList, idx_miniList) end @@ -315,45 +329,84 @@ end BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] use bitmasks implicit none - integer :: i, j, i_state + integer :: i, j, i_state !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - do i_state = 1, N_states - if(mrmode == 3) then + if(mrmode == 3) then do i = 1, N_det_ref - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + do i_state = 1, N_states + delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) + delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) + enddo do j = 1, N_det_non_ref - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + do i_state = 1, N_states + delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) + delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) + enddo end do end do -! -! do i = 1, N_det_ref -! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) -! do j = 1, N_det_non_ref -! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) -! end do -! end do - else if(mrmode == 2) then - do i = 1, N_det_ref + + ! =-=-= BEGIN STATE AVERAGE +! do i = 1, N_det_ref +! delta_ii(:,i)= delta_ii_mrcc(1,i) +! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) +! do i_state = 2, N_states +! delta_ii(:,i) += delta_ii_mrcc(i_state,i) +! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) +! enddo +! do j = 1, N_det_non_ref +! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) +! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) +! do i_state = 2, N_states +! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) +! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) +! enddo +! end do +! end do +! delta_ij = delta_ij * (1.d0/dble(N_states)) +! delta_ii = delta_ii * (1.d0/dble(N_states)) + ! =-=-= END STATE AVERAGE + ! + ! do i = 1, N_det_ref + ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) + ! do j = 1, N_det_non_ref + ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) + ! end do + ! end do + else if(mrmode == 2) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_ii_old(i_state,i) - do j = 1, N_det_non_ref + delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - end do + delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) + enddo end do - else if(mrmode == 1) then - do i = 1, N_det_ref + end do + else if(mrmode == 1) then + do i = 1, N_det_ref + do i_state = 1, N_states delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - do j = 1, N_det_non_ref + delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) + enddo + do j = 1, N_det_non_ref + do i_state = 1, N_states delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - end do + delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) + enddo end do - else - stop "invalid mrmode" - end if - end do + end do + else + stop "invalid mrmode" + end if END_PROVIDER @@ -537,28 +590,32 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] +&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k - double precision :: Hjk, Hki, Hij + double precision :: Sjk,Hjk, Hki, Hij !double precision, external :: get_dij integer i_state, degree provide lambda_mrcc dIj do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij) + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) do i=1,N_det_ref do j=1,i call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) delta_cas(i,j,i_state) = 0d0 + delta_cas_s2(i,j,i_state) = 0d0 do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) + call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) + delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) end do delta_cas(j,i,i_state) = delta_cas(i,j,i_state) + delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -639,6 +696,8 @@ end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] &BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] +&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] use bitmasks implicit none @@ -646,7 +705,7 @@ end function integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, HIIi, HJk, wall + double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) integer(bit_kind),allocatable :: sortRef(:,:,:) @@ -671,14 +730,16 @@ end function ! To provide everything contrib = dij(1, 1, 1) - do i_state = 1, N_states - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii(:,:) = 0d0 + delta_mrcepa0_ij(:,:,:) = 0d0 + delta_mrcepa0_ii_s2(:,:) = 0d0 + delta_mrcepa0_ij_s2(:,:,:) = 0d0 - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2) & + do i_state = 1, N_states + !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & + !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 @@ -721,16 +782,21 @@ end function ! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then + if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) + contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) !$OMP ATOMIC delta_mrcepa0_ii(J,i_state) -= contrib2 + delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 else contrib = contrib * 0.5d0 + contrib_s2 = contrib_s2 * 0.5d0 end if !$OMP ATOMIC delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib + delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 end do kloop end do @@ -741,7 +807,7 @@ end function deallocate(idx_sorted_bit) call wall_time(wall) print *, "cepa0", wall, notf - !stop + END_PROVIDER @@ -829,7 +895,7 @@ END_PROVIDER call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) if(ok) cycle contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) - if(dabs(psi_ref_coef(II,i_state)).ge.5.d-5) then + if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) !$OMP ATOMIC delta_sub_ii(II,i_state) -= contrib2 @@ -860,12 +926,14 @@ subroutine set_det_bit(det, p, s) end subroutine -BEGIN_PROVIDER [ double precision, h_, (N_det_ref,N_det_non_ref) ] + BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] +&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] implicit none integer :: i,j do i=1,N_det_ref do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_(i,j)) + call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) + call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) end do end do END_PROVIDER diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f index f1d6f029..9e9fa65a 100644 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ b/plugins/mrcc_selected/dressing_slave.irp.f @@ -37,7 +37,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR) :: zmq_socket_push - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) @@ -47,8 +47,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) logical :: ok double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, wall, iwall - double precision, allocatable :: dleat(:,:,:) + double precision :: contrib, contrib_s2, wall, iwall + double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp @@ -63,6 +63,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) + allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) allocate(komon(0:N_det_non_ref)) do @@ -74,10 +75,14 @@ subroutine mrsc2_dressing_slave(thread,iproc) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do !delta = 0.d0 + !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 delta(:,:nlink(i_I),2) = 0d0 + delta_s2(:,0,:) = 0d0 + delta_s2(:,:nlink(J),1) = 0d0 + delta_s2(:,:nlink(i_I),2) = 0d0 komon(0) = 0 komoned = .false. @@ -121,8 +126,8 @@ subroutine mrsc2_dressing_slave(thread,iproc) end if i = det_cepa0_idx(linked(m, i_I)) - if(h_(J,i) == 0.d0) cycle - if(h_(i_I,i) == 0.d0) cycle + if(h_cache(J,i) == 0.d0) cycle + if(h_cache(i_I,i) == 0.d0) cycle !ok = .false. !do i_state=1, N_states @@ -144,10 +149,13 @@ subroutine mrsc2_dressing_slave(thread,iproc) ! if(I_i == J) phase_Ii = phase_Ji do i_state = 1,N_states - dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) - !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) + dkI = h_cache(J,i) * dij(i_I, i, i_state) dleat(i_state, kn, 1) = dkI dleat(i_state, kn, 2) = dkI + + dkI = s2_cache(J,i) * dij(i_I, i, i_state) + dleat_s2(i_state, kn, 1) = dkI + dleat_s2(i_state, kn, 2) = dkI end do end do @@ -173,26 +181,32 @@ subroutine mrsc2_dressing_slave(thread,iproc) !if(lambda_mrcc(i_state, i) == 0d0) cycle - !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al + !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) + contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib + delta_s2(i_state,ll,1) += contrib_s2 if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) + delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) endif if(I_i == J) cycle - !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al + !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al contrib = dij(J, l, i_state) * dleat(i_state, m, 1) + contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib + delta_s2(i_state,kk,2) += contrib_s2 if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) + delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) end if enddo !i_state end do ! while end do ! kk - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) + call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) ! end if @@ -208,7 +222,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) end -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) +subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -218,6 +232,7 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) integer, intent(in) :: i_I, J integer(ZMQ_PTR), intent(in) :: zmq_socket_push double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(in) :: task_id integer :: rc , i_state, i, kk, li integer,allocatable :: idx(:,:) @@ -278,6 +293,12 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, task_id) print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' stop 'error' endif + + rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then @@ -305,7 +326,7 @@ end -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) +subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) use f77_zmq implicit none BEGIN_DOC @@ -315,6 +336,7 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) integer(ZMQ_PTR), intent(in) :: zmq_socket_pull integer, intent(out) :: i_I, J, n(2) double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) + double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) integer, intent(out) :: task_id integer :: rc , i, kk integer,intent(inout) :: idx(N_det_non_ref,2) @@ -346,9 +368,15 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) stop 'error' endif + rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) + if (rc /= (n(kk)+1)*8*N_states) then + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' + stop 'error' + endif + rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, n(kk)*4, ZMQ_SNDMORE)' + print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' stop 'error' endif end if @@ -372,7 +400,7 @@ end -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) +subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) use f77_zmq implicit none BEGIN_DOC @@ -381,11 +409,13 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) + double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) + double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) ! integer :: j,l integer :: rc - double precision, allocatable :: delta(:,:,:) + double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -401,49 +431,47 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) delta_ii_(:,:) = 0d0 delta_ij_(:,:,:) = 0d0 + delta_ii_s2_(:,:) = 0d0 + delta_ij_s2_(:,:,:) = 0d0 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - allocate ( delta(N_states,0:N_det_non_ref,2) ) + allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) allocate(idx(N_det_non_ref,2)) more = 1 do while (more == 1) - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, task_id) + call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) do l=1, n(1) do i_state=1,N_states delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) + delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) end do end do do l=1, n(2) do i_state=1,N_states delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) + delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) end do end do -! -! do l=1,nlink(J) -! do i_state=1,N_states -! delta_ij_(i_state,det_cepa0_idx(linked(l,J)),i_I) += delta(i_state,l,1) -! delta_ij_(i_state,det_cepa0_idx(linked(l,i_I)),j) += delta(i_state,l,2) -! end do -! end do -! if(n(1) /= 0) then do i_state=1,N_states delta_ii_(i_state,i_I) += delta(i_state,0,1) + delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) end do end if if(n(2) /= 0) then do i_state=1,N_states delta_ii_(i_state,J) += delta(i_state,0,2) + delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) end do end if @@ -454,7 +482,7 @@ subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_) enddo - deallocate( delta ) + deallocate( delta, delta_s2 ) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_pull_socket(zmq_socket_pull) @@ -466,6 +494,8 @@ end BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] +&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] implicit none integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 @@ -574,10 +604,10 @@ end ! rc = pthread_create(collector_thread, mrsc2_dressing_collector) print *, nzer, ntot, float(nzer) / float(ntot) provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old) PRIVATE(i) NUM_THREADS(nproc+1) + !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) i = omp_get_thread_num() if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old) + call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) else call mrsc2_dressing_slave_inproc(i) endif diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 258c7b51..d4fb25c2 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.231196 2.E-5 + eq $energy -76.2311122169983 2.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index b06be4f2..12518a40 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.238562192068 1.e-4 + eq $energy -76.23857580469 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -33,7 +33,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.238527498388962 1.e-4 + eq $energy -76.238618303075 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -49,7 +49,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.235833732594187 1.e-4 + eq $energy -76.235866800716 1.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -65,6 +65,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2418799284763 1.e-4 + eq $energy -76.2419415001101 1.e-4 } From a4449670892f75621735ad47849068cc2e71fe95 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 19:23:14 +0100 Subject: [PATCH 144/188] Added -v to test --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 57991ba3..ec8703b9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,4 +29,4 @@ script: - source ./quantum_package.rc ; qp_module.py install Full_CI Full_CI_ZMQ Hartree_Fock CAS_SD_ZMQ mrcepa0 All_singles - source ./quantum_package.rc ; ninja - source ./quantum_package.rc ; cd ocaml ; make ; cd - - - source ./quantum_package.rc ; cd tests ; ./run_tests.sh #-v + - source ./quantum_package.rc ; cd tests ; ./run_tests.sh -v From f186827ee7b1a56097426a8b04935d0acabfd8ea Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 19:46:59 +0100 Subject: [PATCH 145/188] Tests can run for 10min --- tests/run_tests.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run_tests.sh b/tests/run_tests.sh index 9e560d38..367937f5 100755 --- a/tests/run_tests.sh +++ b/tests/run_tests.sh @@ -13,7 +13,7 @@ mrcepa0.bats " -export QP_PREFIX="timeout -s 9 300" +export QP_PREFIX="timeout -s 9 600" #export QP_TASK_DEBUG=1 rm -rf work output From e9b7135b83c43949f4d2acfbcb63634236db3777 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 20:09:50 +0100 Subject: [PATCH 146/188] Fixed: Bug in Davdison and Davidson_MRCC --- plugins/MRCC_Utils/amplitudes.irp.f | 21 +++++++++++++++------ plugins/MRCC_Utils/davidson.irp.f | 4 +++- src/Davidson/diagonalization_hs2.irp.f | 7 +++++-- 3 files changed, 23 insertions(+), 9 deletions(-) diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index b38402a2..0e6a4cf4 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -66,9 +66,18 @@ END_PROVIDER +BEGIN_PROVIDER [ integer, n_exc_active_sze ] + implicit none + BEGIN_DOC + ! Dimension of arrays to avoid zero-sized arrays + END_DOC + n_exc_active_sze = max(n_exc_active,1) +END_PROVIDER - BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active) ] -&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active) ] + + + BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active_sze) ] +&BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active_sze) ] implicit none BEGIN_DOC ! Sparse matrix A containing the matrix to transform the active excitations to @@ -136,10 +145,10 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active) ] -&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active) ] -&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active) ] -&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active) ] + BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active_sze) ] +&BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active_sze) ] +&BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active_sze) ] +&BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active_sze) ] implicit none BEGIN_DOC ! A is active_excitation_to_determinants in At.A diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 2c9f5f03..978c96cb 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -829,7 +829,9 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo else - state_ok(k) = .True. + do k=1,size(state_ok) + state_ok(k) = .True. + enddo endif do k=1,shift2 diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 2402f973..5b5edbbf 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -306,7 +306,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) enddo else - state_ok(k) = .True. + do k=1,size(state_ok) + state_ok(k) = .True. + enddo endif do k=1,shift2 @@ -385,7 +387,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag if (state_ok(k)) then do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + U(i,shift2+k) = & + (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & )/max(H_jj(i) - lambda (k),1.d-2) enddo From eb8f1757ab4c6ecfb6bbdd341ef57faf5f417d92 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 20:57:24 +0100 Subject: [PATCH 147/188] Accelerated MRSC2 --- plugins/MRCC_Utils/mrcc_utils.irp.f | 8 +-- src/Determinants/determinants.irp.f | 94 ++++++++++++++++++++++------- 2 files changed, 74 insertions(+), 28 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index da00b824..e76c3698 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -652,14 +652,12 @@ END_PROVIDER allocate(rho_mrcc_init(N_det_non_ref)) allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) - x = 0d0 - do s=1,N_states AtB(:) = 0.d0 !$OMP PARALLEL default(none) shared(k, psi_non_ref_coef, active_excitation_to_determinants_idx,& - !$OMP active_excitation_to_determinants_val, x, N_det_ref, hh_nex, N_det_non_ref) & + !$OMP active_excitation_to_determinants_val, N_det_ref, hh_nex, N_det_non_ref) & !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) @@ -721,14 +719,14 @@ END_PROVIDER factor = 1.d0 resold = huge(1.d0) - do k=0,hh_nex*hh_nex + do k=0,10*hh_nex !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) !$OMP DO do i=1,N_det_non_ref rho_mrcc(i,s) = rho_mrcc_init(i) enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP DO do a_coll = 1, n_exc_active diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index f690c790..98d7d5c9 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -764,37 +764,85 @@ subroutine apply_excitation(det, exc, res, ok, Nint) ok = .false. degree = exc(0,1,1) + exc(0,1,2) - if(.not. (degree > 0 .and. degree <= 2)) then - print *, degree - print *, "apply ex" - STOP - endif - - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) +! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) +! INLINE + select case(degree) + case(2) + if (exc(0,1,1) == 2) then + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + s1 = 1 + s2 = 1 + else if (exc(0,1,2) == 2) then + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + s1 = 2 + s2 = 2 + else + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + s1 = 1 + s2 = 2 + endif + case(1) + if (exc(0,1,1) == 1) then + h1 = exc(1,1,1) + h2 = 0 + p1 = exc(1,2,1) + p2 = 0 + s1 = 1 + s2 = 0 + else + h1 = exc(1,1,2) + h2 = 0 + p1 = exc(1,2,2) + p2 = 0 + s1 = 2 + s2 = 0 + endif + case(0) + h1 = 0 + p1 = 0 + h2 = 0 + p2 = 0 + s1 = 0 + s2 = 0 + case default + print *, degree + print *, "apply ex" + STOP + end select +! END INLINE + res = det - ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) ! mod 64 - if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return + ii = ishft(h1-1,-bit_kind_shift) + 1 + pos = h1-1-ishft(ii-1,bit_kind_shift) + if(iand(det(ii, s1), ibset(0_bit_kind, pos)) == 0_8) return res(ii, s1) = ibclr(res(ii, s1), pos) - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + ii = ishft(p1-1,-bit_kind_shift) + 1 + pos = p1-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s1) = ibset(res(ii, s1), pos) if(degree == 2) then - ii = (h2-1)/bit_kind_size + 1 - pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + ii = ishft(h2-1,-bit_kind_shift) + 1 + pos = h2-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s2) = ibclr(res(ii, s2), pos) - ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + ii = ishft(p2-1,-bit_kind_shift) + 1 + pos = p2-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s2) = ibset(res(ii, s2), pos) endif - ok = .true. end subroutine @@ -814,13 +862,13 @@ subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) if(p1 /= 0) then ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + pos = mod(p1-1, bit_kind_size)!iand(p1-1,bit_kind_size-1) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s1) = ibset(res(ii, s1), pos) end if ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, 64)!iand(p2-1,bit_kind_size-1) + pos = mod(p2-1, bit_kind_size)!iand(p2-1,bit_kind_size-1) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s2) = ibset(res(ii, s2), pos) @@ -843,13 +891,13 @@ subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) if(h1 /= 0) then ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + pos = mod(h1-1, bit_kind_size)!iand(h1-1,bit_kind_size-1) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s1) = ibclr(res(ii, s1), pos) end if ii = (h2-1)/bit_kind_size + 1 - pos = mod(h2-1, 64)!iand(h2-1,bit_kind_size-1) + pos = mod(h2-1, bit_kind_size)!iand(h2-1,bit_kind_size-1) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s2) = ibclr(res(ii, s2), pos) @@ -870,7 +918,7 @@ subroutine apply_particle(det, s1, p1, res, ok, Nint) res = det ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, 64)!iand(p1-1,bit_kind_size-1) + pos = mod(p1-1, bit_kind_size)!iand(p1-1,bit_kind_size-1) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s1) = ibset(res(ii, s1), pos) @@ -892,7 +940,7 @@ subroutine apply_hole(det, s1, h1, res, ok, Nint) res = det ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, 64)!iand(h1-1,bit_kind_size-1) + pos = mod(h1-1, bit_kind_size)!iand(h1-1,bit_kind_size-1) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s1) = ibclr(res(ii, s1), pos) From 3adf8cdcb72261b1f5515598f26ffe2cfad3f519 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 21:12:21 +0100 Subject: [PATCH 148/188] Accelerated MRSC2 --- plugins/mrcc_selected/dressing_slave.irp.f | 36 +++++----------------- src/Determinants/determinants.irp.f | 24 +++++++-------- 2 files changed, 19 insertions(+), 41 deletions(-) diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f index 9e9fa65a..c2e5dd55 100644 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ b/plugins/mrcc_selected/dressing_slave.irp.f @@ -74,8 +74,6 @@ subroutine mrsc2_dressing_slave(thread,iproc) ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) end do - !delta = 0.d0 - !delta_s2 = 0.d0 n = 0 delta(:,0,:) = 0d0 delta(:,:nlink(J),1) = 0d0 @@ -129,25 +127,10 @@ subroutine mrsc2_dressing_slave(thread,iproc) if(h_cache(J,i) == 0.d0) cycle if(h_cache(i_I,i) == 0.d0) cycle - !ok = .false. - !do i_state=1, N_states - ! if(lambda_mrcc(i_state, i) /= 0d0) then - ! ok = .true. - ! exit - ! end if - !end do - !if(.not. ok) cycle -! - komon(0) += 1 kn = komon(0) komon(kn) = i - -! call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ji,N_int) -! if(I_i /= J) call get_excitation(psi_ref(1,1,I_i),psi_non_ref(1,1,i),exc_IJ,degree2,phase_Ii,N_int) -! if(I_i == J) phase_Ii = phase_Ji - do i_state = 1,N_states dkI = h_cache(J,i) * dij(i_I, i, i_state) dleat(i_state, kn, 1) = dkI @@ -163,25 +146,21 @@ subroutine mrsc2_dressing_slave(thread,iproc) komoned = .true. end if - + integer :: hpmin(2) + hpmin(1) = 2 - HP(1,k) + hpmin(2) = 2 - HP(2,k) + do m = 1, komon(0) i = komon(m) - - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(.not. ok) cycle - if(HP(1,i) + HP(1,k) <= 2 .and. HP(2,i) + HP(2,k) <= 2) then -! if(is_in_wavefunction(det_tmp, N_int)) cycle + if(HP(1,i) <= hpmin(1) .and. HP(2,i) <= hpmin(2) ) then cycle end if - !if(isInCassd(det_tmp, N_int)) cycle + call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) + if(.not. ok) cycle do i_state = 1, N_states - !if(lambda_mrcc(i_state, i) == 0d0) cycle - - - !contrib = h_cache(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) delta(i_state,ll,1) += contrib @@ -192,7 +171,6 @@ subroutine mrsc2_dressing_slave(thread,iproc) endif if(I_i == J) cycle - !contrib = h_cache(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al contrib = dij(J, l, i_state) * dleat(i_state, m, 1) contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) delta(i_state,kk,2) += contrib diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 98d7d5c9..bed3327d 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -861,14 +861,14 @@ subroutine apply_particles(det, s1, p1, s2, p2, res, ok, Nint) res = det if(p1 /= 0) then - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, bit_kind_size)!iand(p1-1,bit_kind_size-1) + ii = ishft(p1-1,-bit_kind_shift) + 1 + pos = p1-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s1) = ibset(res(ii, s1), pos) end if - ii = (p2-1)/bit_kind_size + 1 - pos = mod(p2-1, bit_kind_size)!iand(p2-1,bit_kind_size-1) + ii = ishft(p2-1,-bit_kind_shift) + 1 + pos = p2-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s2) = ibset(res(ii, s2), pos) @@ -890,14 +890,14 @@ subroutine apply_holes(det, s1, h1, s2, h2, res, ok, Nint) res = det if(h1 /= 0) then - ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, bit_kind_size)!iand(h1-1,bit_kind_size-1) + ii = ishft(h1-1,-bit_kind_shift) + 1 + pos = h1-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s1) = ibclr(res(ii, s1), pos) end if - ii = (h2-1)/bit_kind_size + 1 - pos = mod(h2-1, bit_kind_size)!iand(h2-1,bit_kind_size-1) + ii = ishft(h2-1,-bit_kind_shift) + 1 + pos = h2-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s2), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s2) = ibclr(res(ii, s2), pos) @@ -917,8 +917,8 @@ subroutine apply_particle(det, s1, p1, res, ok, Nint) ok = .false. res = det - ii = (p1-1)/bit_kind_size + 1 - pos = mod(p1-1, bit_kind_size)!iand(p1-1,bit_kind_size-1) + ii = ishft(p1-1,-bit_kind_shift) + 1 + pos = p1-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) /= 0_8) return res(ii, s1) = ibset(res(ii, s1), pos) @@ -939,8 +939,8 @@ subroutine apply_hole(det, s1, h1, res, ok, Nint) ok = .false. res = det - ii = (h1-1)/bit_kind_size + 1 - pos = mod(h1-1, bit_kind_size)!iand(h1-1,bit_kind_size-1) + ii = ishft(h1-1,-bit_kind_shift) + 1 + pos = h1-1-ishft(ii-1,bit_kind_shift) if(iand(det(ii, s1), ishft(1_bit_kind, pos)) == 0_8) return res(ii, s1) = ibclr(res(ii, s1), pos) From f9fce87440a1336823910bec641083833ebd437e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 30 Nov 2016 22:49:03 +0100 Subject: [PATCH 149/188] Removed radomization --- plugins/MRCC_Utils/davidson.irp.f | 38 +++++++++++++------------- src/Davidson/diagonalization_hs2.irp.f | 38 +++++++++++++------------- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 978c96cb..6bdadb24 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -910,30 +910,30 @@ subroutine davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------- do k=1,N_st_diag - if (state_ok(k)) then +! if (state_ok(k)) then do i=1,sze U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & )/max(H_jj(i) - lambda (k),1.d-2) enddo - else - ! Randomize components with bad - do i=1,sze-2,2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - U(i+1,shift2+k) = r1*dsin(r2) - enddo - do i=sze-2+1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - enddo - endif +! else +! ! Randomize components with bad +! do i=1,sze-2,2 +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! U(i+1,shift2+k) = r1*dsin(r2) +! enddo +! do i=sze-2+1,sze +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! enddo +! endif if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 5b5edbbf..3ccb29df 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -385,31 +385,31 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- do k=1,N_st_diag - if (state_ok(k)) then +! if (state_ok(k)) then do i=1,sze U(i,shift2+k) = & (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & )/max(H_jj(i) - lambda (k),1.d-2) enddo - else - ! Randomize components with bad - do i=1,sze-2,2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - U(i+1,shift2+k) = r1*dsin(r2) - enddo - do i=sze-2+1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - enddo - endif +! else +! ! Randomize components with bad +! do i=1,sze-2,2 +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! U(i+1,shift2+k) = r1*dsin(r2) +! enddo +! do i=sze-2+1,sze +! call random_number(r1) +! call random_number(r2) +! r1 = dsqrt(-2.d0*dlog(r1)) +! r2 = dtwo_pi*r2 +! U(i,shift2+k) = r1*dcos(r2) +! enddo +! endif if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) From e6db22dfd71567859907d696072dd29db62ad36b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 1 Dec 2016 09:46:36 +0100 Subject: [PATCH 150/188] Fixed travis --- tests/bats/cassd.bats | 2 +- tests/bats/mrcepa0.bats | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index d4fb25c2..8cbc4899 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.2311122169983 2.E-5 + eq $energy -76.2311422169983 5.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index 12518a40..e4b45f65 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -28,12 +28,11 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set determinants threshold_generators 1. ezfio set determinants threshold_selectors 1. ezfio set determinants read_wf True - ezfio set determinants read_wf True ezfio set mrcepa0 lambda_type 0 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.238618303075 1.e-4 + eq $energy -76.238510023275 2.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -45,11 +44,11 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set determinants threshold_generators 1. ezfio set determinants threshold_selectors 1. ezfio set determinants read_wf True - ezfio set mrcepa0 lambda_type 0 + ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.235866800716 1.e-4 + eq $energy -76.2357889658142 2.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -61,10 +60,10 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set determinants threshold_generators 1. ezfio set determinants threshold_selectors 1. ezfio set determinants read_wf True - ezfio set mrcepa0 lambda_type 0 + ezfio set mrcepa0 lambda_type 1 ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2419415001101 1.e-4 + eq $energy -76.2417748223423 2.e-4 } From d45d53be71f40d754d3dffcecd1d9c695304201d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 1 Dec 2016 16:28:56 +0100 Subject: [PATCH 151/188] Trying Multi-state --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 4 ++-- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 35 +++++++++++++++++++++++++++++ 3 files changed, 38 insertions(+), 3 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 57b71fe8..8de61521 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -79,7 +79,7 @@ program fci_zmq if (N_det == N_det_max) then threshold_davidson = threshold_davidson_in - TOUCH threshold_davidson + SOFT_TOUCH threshold_davidson endif call diagonalize_CI call save_wavefunction @@ -88,7 +88,7 @@ program fci_zmq if (N_det < N_det_max) then threshold_davidson = threshold_davidson_in - TOUCH threshold_davidson + SOFT_TOUCH threshold_davidson call diagonalize_CI call save_wavefunction call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index dc11b01d..98af03bd 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -79,7 +79,7 @@ program fci_zmq if (N_det == N_det_max) then threshold_davidson = threshold_davidson_in - TOUCH threshold_davidson + SOFT_TOUCH threshold_davidson endif call diagonalize_CI call save_wavefunction diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index e76c3698..5cb3f945 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -173,6 +173,41 @@ END_PROVIDER enddo call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) + + double precision :: u_dot_u + double precision, allocatable :: h(:,:), s(:,:) + allocate (h(N_states,N_states), s(N_states,N_states)) + do i=1,N_states + do j=1,N_states + s(i,j) = u_dot_v(CI_eigenvectors_dressed(1,i),CI_eigenvectors_dressed(1,j),N_det) + print *, 'S(',i,',',j,')', s(i,j) + enddo + enddo + + do i=1,N_states + h(i,i) = CI_electronic_energy_dressed(i) + do j=i+1,N_states + h(j,i) = (CI_electronic_energy_dressed(j)-CI_electronic_energy_dressed(i)) * s(i,j) + h(i,j) = -h(j,i) + print *, 'h(',i,',',i,')', h(i,j) + enddo + print *, 'h(',i,',',i,')', h(i,i) + enddo + call lapack_diag(eigenvalues,eigenvectors, h,size(h,1),N_states) + do i=1,N_states + CI_electronic_energy_dressed(i) = eigenvalues(i) + do j=1,N_states + h(i,j) = eigenvectors(i,j) + enddo + enddo + do k=1,N_states + eigenvectors(1:N_det,k) = 0.d0 + do i=1,N_states + eigenvectors(1:N_det,k) += CI_eigenvectors_dressed(1:N_det,k) * h(k,i) + enddo + enddo + deallocate(h,s) + deallocate (eigenvectors,eigenvalues) From 1ea5e17339a075e9d61ee06fa0719ccb0a9c16b7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 11:09:20 +0100 Subject: [PATCH 152/188] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index eacecaf7..c9e1b12d 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ Demo * Python >= 2.6 * GNU make * Bash -* Blast/Lapack +* Blas/Lapack * unzip * g++ (For ninja) From d1e89b94a12be890557ca4ad283bbaf1f045b55b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 11:09:48 +0100 Subject: [PATCH 153/188] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index bb63b691..3caef9a0 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ Demo * Python >= 2.6 * GNU make * Bash -* Blast/Lapack +* Blas/Lapack * unzip * g++ (For ninja) From 07b48ef2f722b526323a101f2c38f258129ee53f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 11:53:56 +0100 Subject: [PATCH 154/188] Updated install scripts --- README.md | 2 +- configure | 13 ++++-- include/.empty | 0 install/scripts/build.sh | 6 ++- install/scripts/install_curl.sh | 8 +--- install/scripts/install_f77zmq.sh | 3 +- install/scripts/install_gmp.sh | 17 ++++++++ install/scripts/install_m4.sh | 3 +- install/scripts/install_patch.sh | 4 +- install/scripts/install_zeromq.sh | 13 +----- install/scripts/install_zlib.sh | 7 +-- plugins/MRCC_Utils/mrcc_utils.irp.f | 68 +++++++++++++++-------------- src/Davidson/u0Hu0.irp.f | 4 +- 13 files changed, 79 insertions(+), 69 deletions(-) create mode 100644 include/.empty create mode 100755 install/scripts/install_gmp.sh diff --git a/README.md b/README.md index bb63b691..3caef9a0 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ Demo * Python >= 2.6 * GNU make * Bash -* Blast/Lapack +* Blas/Lapack * unzip * g++ (For ninja) diff --git a/configure b/configure index 8cb02608..060ae9b9 100755 --- a/configure +++ b/configure @@ -70,9 +70,10 @@ d_dependency = { "resultsFile": ["python"], "emsl": ["python"], "gcc": [], + "gmp": [ "gcc", "make" ], "g++": [], - "zeromq" : [ "g++" ], - "f77zmq" : [ "zeromq", "python" ], + "zeromq" : [ "g++", "make" ], + "f77zmq" : [ "zeromq", "python", "make" ], "python": [], "ninja": ["g++", "python"], "make": [], @@ -131,6 +132,11 @@ ninja = Info( description=' ninja', default_path=join(QP_ROOT_BIN, "ninja")) +gmp = Info( + url='https://gmplib.org/download/gmp/gmp-6.1.1.tar.bz2', + description=' GMP library', + default_path=join(QP_ROOT_LIB, "libgmp.so")) + emsl = Info( url='{head}/LCPQ/EMSL_Basis_Set_Exchange_Local/{tail}'.format(**path_github), description=' EMSL basis set library', @@ -166,7 +172,7 @@ d_info = dict() for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt", "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz", - "zeromq", "f77zmq","bats" ]: + "zeromq", "f77zmq","bats", "gmp" ]: exec ("d_info['{0}']={0}".format(m)) @@ -495,6 +501,7 @@ def create_ninja_and_rc(l_installed): 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', 'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"', 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "", + 'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include', 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "", 'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true', '', diff --git a/include/.empty b/include/.empty new file mode 100644 index 00000000..e69de29b diff --git a/install/scripts/build.sh b/install/scripts/build.sh index 79a71065..5071b5aa 100755 --- a/install/scripts/build.sh +++ b/install/scripts/build.sh @@ -4,7 +4,11 @@ BUILD=_build/${TARGET} rm -rf -- ${BUILD} mkdir ${BUILD} || exit 1 -tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1 +if [[ -f Downloads/${TARGET}.tar.gz ]] ; then + tar -zxf Downloads/${TARGET}.tar.gz --strip-components=1 --directory=${BUILD} || exit 1 +elif [[ -f Downloads/${TARGET}.tar.bz2 ]] ; then + tar -jxf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1 +fi _install || exit 1 rm -rf -- ${BUILD} _build/${TARGET}.log exit 0 diff --git a/install/scripts/install_curl.sh b/install/scripts/install_curl.sh index c3a48024..6194a0e0 100755 --- a/install/scripts/install_curl.sh +++ b/install/scripts/install_curl.sh @@ -10,10 +10,4 @@ function _install() mv curl.ermine ${QP_ROOT}/bin/curl || return 1 } -BUILD=_build/${TARGET} -rm -rf -- ${BUILD} -mkdir ${BUILD} || exit 1 -tar -xvjf Downloads/${TARGET}.tar.bz2 --strip-components=1 --directory=${BUILD} || exit 1 -_install || exit 1 -rm -rf -- ${BUILD} _build/${TARGET}.log -exit 0 \ No newline at end of file +source scripts/build.sh diff --git a/install/scripts/install_f77zmq.sh b/install/scripts/install_f77zmq.sh index 8357857c..92388337 100755 --- a/install/scripts/install_f77zmq.sh +++ b/install/scripts/install_f77zmq.sh @@ -7,10 +7,9 @@ function _install() cd .. QP_ROOT=$PWD cd - - export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/lib set -e set -u - export ZMQ_H="${QP_ROOT}"/lib/zmq.h + export ZMQ_H="${QP_ROOT}"/include/zmq.h cd "${BUILD}" make -j 8 || exit 1 mv libf77zmq.a "${QP_ROOT}"/lib || exit 1 diff --git a/install/scripts/install_gmp.sh b/install/scripts/install_gmp.sh new file mode 100755 index 00000000..e1464567 --- /dev/null +++ b/install/scripts/install_gmp.sh @@ -0,0 +1,17 @@ +#!/bin/bash -x + +TARGET=gmp + +function _install() +{ + rm -rf -- ${TARGET} + mkdir ${TARGET} || exit 1 + cd .. + QP_ROOT=$PWD + cd - + cd ${BUILD} + ./configure --prefix=$QP_ROOT && make || exit 1 + make install || exit 1 +} + +source scripts/build.sh diff --git a/install/scripts/install_m4.sh b/install/scripts/install_m4.sh index ca62a025..5a52d757 100755 --- a/install/scripts/install_m4.sh +++ b/install/scripts/install_m4.sh @@ -8,8 +8,7 @@ function _install() QP_ROOT=$PWD cd - cd ${BUILD} - ./configure && make || exit 1 - ln -sf ${PWD}/src/m4 ${QP_ROOT}/bin || exit 1 + ./configure --prefix=$QP_ROOT && make || exit 1 } source scripts/build.sh diff --git a/install/scripts/install_patch.sh b/install/scripts/install_patch.sh index 10522401..224ac8f8 100755 --- a/install/scripts/install_patch.sh +++ b/install/scripts/install_patch.sh @@ -9,11 +9,11 @@ function _install() QP_ROOT=$PWD cd - cd ${BUILD} - ./configure --prefix=${QP_ROOT}/install/${TARGET} && make || exit 1 + ./configure --prefix=${QP_ROOT} && make || exit 1 make install || exit 1 cd - cp ${TARGET}/bin/${TARGET} ${QP_ROOT}/bin || exit 1 rm -R -- ${TARGET} || exit 1 } -source scripts/build.sh \ No newline at end of file +source scripts/build.sh diff --git a/install/scripts/install_zeromq.sh b/install/scripts/install_zeromq.sh index 3bf2a715..f6596f9c 100755 --- a/install/scripts/install_zeromq.sh +++ b/install/scripts/install_zeromq.sh @@ -7,22 +7,13 @@ function _install() cd .. QP_ROOT=$PWD cd - - export C_INCLUDE_PATH="${C_INCLUDE_PATH}":./ set -e set -u ORIG=$(pwd) cd "${BUILD}" - ./configure --without-libsodium || exit 1 + ./configure --prefix=$QP_ROOT --without-libsodium || exit 1 make -j 8 || exit 1 - rm -f -- "${QP_ROOT}"/lib/libzmq.a "${QP_ROOT}"/lib/libzmq.so "${QP_ROOT}"/lib/libzmq.so.? - cp .libs/libzmq.a "${QP_ROOT}"/lib - cp .libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.5 -# cp src/.libs/libzmq.a "${QP_ROOT}"/lib -# cp src/.libs/libzmq.so "${QP_ROOT}"/lib/libzmq.so.4 - cp include/{zmq.h,zmq_utils.h} "${QP_ROOT}"/lib - cd "${QP_ROOT}"/lib - ln -s libzmq.so.5 libzmq.so -# ln -s libzmq.so.4 libzmq.so + make install || exit 1 cd ${ORIG} return 0 } diff --git a/install/scripts/install_zlib.sh b/install/scripts/install_zlib.sh index 06ce67f3..ea268f2e 100755 --- a/install/scripts/install_zlib.sh +++ b/install/scripts/install_zlib.sh @@ -11,11 +11,8 @@ function _install() cd - cd ${BUILD} ./configure && make || exit 1 - make install prefix=$QP_ROOT/install/${TARGET} || exit 1 - ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.so $QP_ROOT/lib || exit 1 - ln -s -f $QP_ROOT/install/${TARGET}/lib/libz.a $QP_ROOT/lib || exit 1 - ln -s -f $QP_ROOT/install/${TARGET}/include/zlib.h $QP_ROOT/lib || exit 1 - ln -s -f $QP_ROOT/install/${TARGET}/include/zconf.h $QP_ROOT/lib || exit 1 + ./configure --prefix=$QP_ROOT && make || exit 1 + make install || exit 1 } source scripts/build.sh diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 5cb3f945..16fb6eff 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -174,42 +174,44 @@ END_PROVIDER call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) - double precision :: u_dot_u - double precision, allocatable :: h(:,:), s(:,:) - allocate (h(N_states,N_states), s(N_states,N_states)) - do i=1,N_states - do j=1,N_states - s(i,j) = u_dot_v(CI_eigenvectors_dressed(1,i),CI_eigenvectors_dressed(1,j),N_det) - print *, 'S(',i,',',j,')', s(i,j) - enddo - enddo +! double precision :: u_dot_u +! double precision, allocatable :: h(:,:,:), s(:,:) +! allocate (h(N_states,N_states,N_states), s(N_states,N_states)) +! do i=1,N_states +! do j=1,N_states +! s(i,j) = u_dot_v(CI_eigenvectors_dressed(1,i),CI_eigenvectors_dressed(1,j),N_det) +! print *, 'S(',i,',',j,')', s(i,j) +! enddo +! enddo +! +! do i=1,N_states +! h(i,i) = CI_electronic_energy_dressed(i) +! do j=i+1,N_states +! h(j,i) = (CI_electronic_energy_dressed(j)-CI_electronic_energy_dressed(i)) * s(i,j) +! h(i,j) = -h(j,i) +! print *, 'h(',i,',',i,')', h(i,j) +! enddo +! print *, 'h(',i,',',i,')', h(i,i) +! enddo +! call lapack_diag(eigenvalues,eigenvectors, h,size(h,1),N_states) +! do i=1,N_states +! CI_electronic_energy_dressed(i) = eigenvalues(i) +! do j=1,N_states +! h(i,j) = eigenvectors(i,j) +! enddo +! enddo +! do k=1,N_states +! eigenvectors(1:N_det,k) = 0.d0 +! do i=1,N_states +! eigenvectors(1:N_det,k) += CI_eigenvectors_dressed(1:N_det,k) * h(k,i) +! enddo +! enddo +! deallocate(h,s) +! - do i=1,N_states - h(i,i) = CI_electronic_energy_dressed(i) - do j=i+1,N_states - h(j,i) = (CI_electronic_energy_dressed(j)-CI_electronic_energy_dressed(i)) * s(i,j) - h(i,j) = -h(j,i) - print *, 'h(',i,',',i,')', h(i,j) - enddo - print *, 'h(',i,',',i,')', h(i,i) - enddo - call lapack_diag(eigenvalues,eigenvectors, h,size(h,1),N_states) - do i=1,N_states - CI_electronic_energy_dressed(i) = eigenvalues(i) - do j=1,N_states - h(i,j) = eigenvectors(i,j) - enddo - enddo - do k=1,N_states - eigenvectors(1:N_det,k) = 0.d0 - do i=1,N_states - eigenvectors(1:N_det,k) += CI_eigenvectors_dressed(1:N_det,k) * h(k,i) - enddo - enddo - deallocate(h,s) + call multi_state(CI_electronic_energy_dressed,CI_eigenvectors_dressed,size(CI_eigenvectors_dressed,1)) deallocate (eigenvectors,eigenvalues) - else if (diag_algorithm == "Lapack") then diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index dd5ab1ab..4c465e40 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -344,7 +344,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(static,1) + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -369,7 +369,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO NOWAIT do sh=1,shortcut(0,1) - !$OMP DO SCHEDULE(static,1) + !$OMP DO SCHEDULE(dynamic) do sh2=sh,shortcut(0,1) exa = 0 do ni=1,Nint From 366b0b66c2022760e7694362f61b5972fc8c5667 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 12:07:19 +0100 Subject: [PATCH 155/188] Updated travis script --- .travis.yml | 4 ++-- configure | 3 ++- install/scripts/install_gmp.sh | 2 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index ec8703b9..22cd358e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,12 +9,12 @@ sudo: false addons: apt: packages: - - zlib1g-dev - - libgmp3-dev - gfortran - gcc - liblapack-dev - graphviz +# - zlib1g-dev +# - libgmp3-dev cache: directories: diff --git a/configure b/configure index 060ae9b9..5af0769f 100755 --- a/configure +++ b/configure @@ -500,8 +500,9 @@ def create_ninja_and_rc(l_installed): 'export PYTHONPATH="${QP_EZFIO}/Python":"${QP_PYTHON}":"${PYTHONPATH}"', 'export PATH="${QP_PYTHON}":"${QP_ROOT}"/bin:"${QP_ROOT}"/ocaml:"${PATH}"', 'export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}"', - 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', "", + 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', 'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include', + '', 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "", 'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true', '', diff --git a/install/scripts/install_gmp.sh b/install/scripts/install_gmp.sh index e1464567..9aea2973 100755 --- a/install/scripts/install_gmp.sh +++ b/install/scripts/install_gmp.sh @@ -10,7 +10,7 @@ function _install() QP_ROOT=$PWD cd - cd ${BUILD} - ./configure --prefix=$QP_ROOT && make || exit 1 + ./configure --prefix=$QP_ROOT && make -j 8 || exit 1 make install || exit 1 } diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 16fb6eff..f5fb2ba6 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -209,7 +209,7 @@ END_PROVIDER ! deallocate(h,s) ! - call multi_state(CI_electronic_energy_dressed,CI_eigenvectors_dressed,size(CI_eigenvectors_dressed,1)) +! call multi_state(CI_electronic_energy_dressed,CI_eigenvectors_dressed,size(CI_eigenvectors_dressed,1)) deallocate (eigenvectors,eigenvalues) From 8ac3771c644e82badd71f5670197dc98ae745984 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 12:47:25 +0100 Subject: [PATCH 156/188] Fixed install_ocaml.sh --- install/scripts/install_ocaml.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index 913ae75d..ea5bb5e4 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -9,7 +9,7 @@ PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ" #ppx_sexp_conv # Needed for ZeroMQ -export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}" +export C_INCLUDE_PATH="${QP_ROOT}"/include:"${C_INCLUDE_PATH}" export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}" export LD_LIBRARY_PATH="${QP_ROOT}"/lib:"${LD_LIBRARY_PATH}" From cde801f2769bd6aa56575ba747756ca5c96e67ff Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 13:24:58 +0100 Subject: [PATCH 157/188] Added missing file --- plugins/MRCC_Utils/multi_state.irp.f | 101 +++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) create mode 100644 plugins/MRCC_Utils/multi_state.irp.f diff --git a/plugins/MRCC_Utils/multi_state.irp.f b/plugins/MRCC_Utils/multi_state.irp.f new file mode 100644 index 00000000..b4a2a3cb --- /dev/null +++ b/plugins/MRCC_Utils/multi_state.irp.f @@ -0,0 +1,101 @@ +subroutine multi_state(CI_electronic_energy_dressed_,CI_eigenvectors_dressed_,LDA) + implicit none + BEGIN_DOC + ! Multi-state mixing + END_DOC + integer, intent(in) :: LDA + double precision, intent(inout) :: CI_electronic_energy_dressed_(N_states) + double precision, intent(inout) :: CI_eigenvectors_dressed_(LDA,N_states) + double precision, allocatable :: h(:,:,:), s(:,:), Psi(:,:), H_Psi(:,:,:), H_jj(:) + + allocate( h(N_states,N_states,0:N_states), s(N_states,N_states) ) + allocate( Psi(LDA,N_states), H_Psi(LDA,N_states,0:N_states) ) + allocate (H_jj(LDA) ) + +! e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + + integer :: i,j,k,istate + double precision :: U(N_states,N_states), Vt(N_states,N_states), D(N_states) + double precision, external :: diag_H_mat_elem + do istate=1,N_states + do i=1,N_det + H_jj(i) = diag_H_mat_elem(psi_det(1,1,i),N_int) + enddo + + do i=1,N_det_ref + H_jj(idx_ref(i)) += delta_ii(istate,i) + enddo + + do k=1,N_states + do i=1,N_det + Psi(i,k) = CI_eigenvectors_dressed_(i,k) + enddo + enddo + call H_u_0_mrcc_nstates(H_Psi(1,1,istate),Psi,H_jj,N_det,psi_det,N_int,istate,N_states,LDA) + + do k=1,N_states + do i=1,N_states + double precision, external :: u_dot_v + h(i,k,istate) = u_dot_v(Psi(1,i), H_Psi(1,k,istate), N_det) + enddo + enddo + enddo + + do k=1,N_states + do i=1,N_states + s(i,k) = u_dot_v(Psi(1,i), Psi(1,k), N_det) + enddo + enddo + + print *, s(:,:) + print *, '' + + h(:,:,0) = h(:,:,1) + do istate=2,N_states + U(:,:) = h(:,:,0) + call dgemm('N','N',N_states,N_states,N_states,1.d0,& + U, size(U,1), h(1,1,istate), size(h,1), 0.d0, & + h(1,1,0), size(Vt,1)) + enddo + + call svd(h(1,1,0), size(h,1), U, size(U,1), D, Vt, size(Vt,1), N_states, N_states) + do k=1,N_states + D(k) = D(k)**(1./dble(N_states)) + if (D(k) > 0.d0) then + D(k) = -D(k) + endif + enddo + + do j=1,N_states + do i=1,N_states + h(i,j,0) = 0.d0 + do k=1,N_states + h(i,j,0) += U(i,k) * D(k) * Vt(k,j) + enddo + enddo + enddo + + print *, h(:,:,0) + print *,'' + + integer :: LWORK, INFO + double precision, allocatable :: WORK(:) + LWORK=3*N_states + allocate (WORK(LWORK)) + call dsygv(1, 'V', 'U', N_states, h(1,1,0), size(h,1), s, size(s,1), D, WORK, LWORK, INFO) + deallocate(WORK) + + do j=1,N_states + do i=1,N_det + CI_eigenvectors_dressed_(i,j) = 0.d0 + do k=1,N_states + CI_eigenvectors_dressed_(i,j) += Psi(i,k) * h(k,j,0) + enddo + enddo + CI_electronic_energy_dressed_(j) = D(j) + enddo + + + deallocate (h,s, H_jj) + deallocate( Psi, H_Psi ) +end From 33ee11506211882c095ff8498892e004f023a9d3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 2 Dec 2016 16:20:02 +0100 Subject: [PATCH 158/188] Removed gmp and zarith dependencies by forcing cryptokit 1.10 --- configure | 9 +-------- install/scripts/install_ocaml.sh | 2 +- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/configure b/configure index 5af0769f..128d7126 100755 --- a/configure +++ b/configure @@ -70,7 +70,6 @@ d_dependency = { "resultsFile": ["python"], "emsl": ["python"], "gcc": [], - "gmp": [ "gcc", "make" ], "g++": [], "zeromq" : [ "g++", "make" ], "f77zmq" : [ "zeromq", "python", "make" ], @@ -132,11 +131,6 @@ ninja = Info( description=' ninja', default_path=join(QP_ROOT_BIN, "ninja")) -gmp = Info( - url='https://gmplib.org/download/gmp/gmp-6.1.1.tar.bz2', - description=' GMP library', - default_path=join(QP_ROOT_LIB, "libgmp.so")) - emsl = Info( url='{head}/LCPQ/EMSL_Basis_Set_Exchange_Local/{tail}'.format(**path_github), description=' EMSL basis set library', @@ -156,7 +150,6 @@ f77zmq = Info( url='{head}/zeromq/f77_zmq/{tail}'.format(**path_github), description=' F77-ZeroMQ', default_path=join(QP_ROOT_LIB, "libf77zmq.a") ) -# join(QP_ROOT, "src", "ZMQ", "f77zmq.h") ) p_graphviz = Info( url='https://github.com/xflr6/graphviz/archive/master.tar.gz', @@ -172,7 +165,7 @@ d_info = dict() for m in ["ocaml", "m4", "curl", "zlib", "patch", "irpf90", "docopt", "resultsFile", "ninja", "emsl", "ezfio", "p_graphviz", - "zeromq", "f77zmq","bats", "gmp" ]: + "zeromq", "f77zmq","bats"]: exec ("d_info['{0}']={0}".format(m)) diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index ea5bb5e4..b82216d3 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -5,7 +5,7 @@ QP_ROOT=$PWD cd - # Normal installation -PACKAGES="core cryptokit zarith ocamlfind sexplib ZMQ" +PACKAGES="core cryptokit.1.10 ocamlfind sexplib ZMQ" #ppx_sexp_conv # Needed for ZeroMQ From cc66ed86db06c10543c47f13cf70f85d83144463 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 3 Dec 2016 18:58:07 +0100 Subject: [PATCH 159/188] Minor changes --- src/Davidson/diagonalization_hs2.irp.f | 31 +++++--------------------- src/Davidson/u0Hu0.irp.f | 4 +++- 2 files changed, 9 insertions(+), 26 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 3ccb29df..dccc8ee5 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -385,31 +385,12 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ----------------------------------------- do k=1,N_st_diag -! if (state_ok(k)) then - do i=1,sze - U(i,shift2+k) = & - (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo -! else -! ! Randomize components with bad -! do i=1,sze-2,2 -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! U(i+1,shift2+k) = r1*dsin(r2) -! enddo -! do i=sze-2+1,sze -! call random_number(r1) -! call random_number(r2) -! r1 = dsqrt(-2.d0*dlog(r1)) -! r2 = dtwo_pi*r2 -! U(i,shift2+k) = r1*dcos(r2) -! enddo -! endif + do i=1,sze + U(i,shift2+k) = & + (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & + * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & + )/max(H_jj(i) - lambda (k),1.d-2) + enddo if (k <= N_st) then residual_norm(k) = u_dot_u(U(1,shift2+k),sze) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 4c465e40..2589f0b3 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -313,7 +313,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) integer :: blockb, blockb2, istep double precision :: ave_workload, workload, target_workload_inv - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st N_st_8 = align_double(N_st) @@ -353,6 +353,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) ext = 0 do ni=1,Nint ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit end do if(ext == 4) then call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) @@ -394,6 +395,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) ext = exa do ni=1,Nint ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit end do if(ext <= 4) then org_j = sort_idx(j,1) From ca9d34864b9a7e31b9ebfea393a40945a8910f3b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 5 Dec 2016 09:28:04 +0100 Subject: [PATCH 160/188] threshold davidson = thres * 100 --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 2 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 8de61521..758527bc 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -11,7 +11,7 @@ program fci_zmq pt2 = 1.d0 threshold_davidson_in = threshold_davidson - threshold_davidson = 1.d-5 + threshold_davidson = threshold_davidson_in * 100.d0 SOFT_TOUCH threshold_davidson diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index 98af03bd..f629e7bc 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -12,7 +12,7 @@ program fci_zmq pt2 = 1.d0 threshold_davidson_in = threshold_davidson - threshold_davidson = 1.d-5 + threshold_davidson = threshold_davidson_in * 100.d0 SOFT_TOUCH threshold_davidson if (N_det > N_det_max) then From c07b0381b74f7b331c1d3fc7c7ffd265c105d7b8 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 6 Dec 2016 11:31:15 +0100 Subject: [PATCH 161/188] Acceleration of Davidson for Nint>1 --- src/Davidson/u0Hu0.irp.f | 64 +++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 27 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 2589f0b3..cf28cf12 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -89,8 +89,11 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) - exa = 0 - do ni=1,Nint + exa = popcnt(xor(version(1,sh,1), version(1,sh2,1))) + if(exa > 2) then + cycle + end if + do ni=2,Nint exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) end do if(exa > 2) then @@ -108,20 +111,24 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) sorted_i(ni) = sorted(ni,i,1) enddo - do j=shortcut(sh2,1),endi + jloop: do j=shortcut(sh2,1),endi org_j = sort_idx(j,1) - ext = exa - do ni=1,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - end do - if(ext <= 4) then - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) - enddo + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if(ext > 4) then + cycle jloop endif - enddo + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if(ext > 4) then + cycle jloop + endif + end do + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + do istate=1,N_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo + enddo jloop enddo enddo enddo @@ -133,17 +140,18 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) org_i = sort_idx(i,2) do j=shortcut(sh,2),i-1 org_j = sort_idx(j,2) - ext = 0 - do ni=1,Nint + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + do ni=2,Nint ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) end do - if(ext == 4) then - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) - enddo - end if + if(ext /= 4) then + cycle + endif + call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) + do istate=1,N_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) + vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + enddo end do end do enddo @@ -350,8 +358,9 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) org_i = sort_idx(i,2) do j=shortcut(sh,2),i-1 org_j = sort_idx(j,2) - ext = 0 - do ni=1,Nint + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle + do ni=2,Nint ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) if (ext > 4) exit end do @@ -392,8 +401,9 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo do j=shortcut(sh2,1),endi - ext = exa - do ni=1,Nint + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) if (ext > 4) exit end do From 5e4d5a62e4dc90e9a67187281498af283bcdba71 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 7 Dec 2016 20:51:58 +0100 Subject: [PATCH 162/188] Randomized multiplet guess --- ocaml/qp_create_guess.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ocaml/qp_create_guess.ml b/ocaml/qp_create_guess.ml index 62af57de..bebfdad3 100644 --- a/ocaml/qp_create_guess.ml +++ b/ocaml/qp_create_guess.ml @@ -88,8 +88,9 @@ let run ~multiplicity ezfio_file = ~alpha:(Elec_alpha_number.of_int alpha_new) ~beta:(Elec_beta_number.of_int beta_new) pair ) in + let c = - Array.create ~len:(List.length determinants) (Det_coef.of_float 1.) + Array.init (List.length determinants) (fun _ -> Det_coef.of_float ((Random.float 2.)-.1.)) in determinants From ee295063520f67c0ba163b7c9bd15b4b17c9ceb3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 8 Dec 2016 22:57:31 +0100 Subject: [PATCH 163/188] Accelerated amplitudes --- plugins/MRCC_Utils/mrcc_utils.irp.f | 187 ++++++++-------------------- 1 file changed, 49 insertions(+), 138 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f5fb2ba6..4658118b 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -750,6 +750,10 @@ END_PROVIDER end do deallocate(lref) + do i=1,N_det_non_ref + rho_mrcc(i,s) = rho_mrcc_init(i) + enddo + x_new = x double precision :: factor, resold @@ -757,14 +761,8 @@ END_PROVIDER resold = huge(1.d0) do k=0,10*hh_nex - !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) - - !$OMP DO - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i) - enddo - !$OMP END DO - + res = 0.d0 + !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res) !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) @@ -773,23 +771,12 @@ END_PROVIDER cx = cx + x(mrcc_AtA_ind(i)) * mrcc_AtA_val(s,i) end do x_new(a_col) = AtB(a_col) + cx * factor - end do - !$OMP END DO - - !$OMP END PARALLEL - - - res = 0.d0 - do a_coll=1,n_exc_active - a_col = active_pp_idx(a_coll) - do j=1,N_det_non_ref - i = active_excitation_to_determinants_idx(j,a_coll) - if (i==0) exit - rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X_new(a_col) - enddo res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) end do + !$OMP END DO + !$OMP END PARALLEL + if (res > resold) then factor = factor * 0.5d0 endif @@ -801,7 +788,43 @@ END_PROVIDER if(res < 1d-10) exit end do + dIj_unique(1:size(X), s) = X(1:size(X)) + +! double precision, external :: ddot +! if (ddot (size(X), dIj_unique, 1, X, 1) < 0.d0) then +! dIj_unique(1:size(X),s) = -X(1:size(X)) +! endif + enddo + + ! Adjust phase of dIj_unique + +! double precision :: snorm +! X = 0.d0 +! snorm = 0.d0 +! do s=1,N_states +! norm = 0.d0 +! do i=1,N_det_non_ref +! norm = norm + psi_non_ref_coef(i,s)*psi_non_ref_coef(i,s) +! enddo +! norm = dsqrt(norm) +! X(1:size(X)) = X(1:size(X)) + dIj_unique(1:size(X),s) * norm +! snorm += norm +! enddo +! X = X/snorm + + do s=1,N_states + + do a_coll=1,n_exc_active + a_col = active_pp_idx(a_coll) + do j=1,N_det_non_ref + i = active_excitation_to_determinants_idx(j,a_coll) + if (i==0) exit + rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s) +! rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X(a_col) + enddo + end do + norm = 0.d0 do i=1,N_det_non_ref norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) @@ -813,122 +836,11 @@ END_PROVIDER enddo ! Norm now contains the norm of Psi + A.X - print *, k, "res : ", res, "norm : ", sqrt(norm) - -!--------------- -! double precision :: e_0, overlap -! double precision, allocatable :: u_0(:) -! integer(bit_kind), allocatable :: keys_tmp(:,:,:) -! allocate (u_0(N_det), keys_tmp(N_int,2,N_det) ) -! k=0 -! overlap = 0.d0 -! do i=1,N_det_ref -! k = k+1 -! u_0(k) = psi_ref_coef(i,1) -! keys_tmp(:,:,k) = psi_ref(:,:,i) -! overlap += u_0(k)*psi_ref_coef(i,1) -! enddo -! norm = 0.d0 -! do i=1,N_det_non_ref -! k = k+1 -! u_0(k) = psi_non_ref_coef(i,1) -! keys_tmp(:,:,k) = psi_non_ref(:,:,i) -! overlap += u_0(k)*psi_non_ref_coef(i,1) -! enddo -! -! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) -! print *, 'Energy of |Psi_CASSD> : ', e_0 + nuclear_repulsion, overlap -! -! k=0 -! overlap = 0.d0 -! do i=1,N_det_ref -! k = k+1 -! u_0(k) = psi_ref_coef(i,1) -! keys_tmp(:,:,k) = psi_ref(:,:,i) -! overlap += u_0(k)*psi_ref_coef(i,1) -! enddo -! norm = 0.d0 -! do i=1,N_det_non_ref -! k = k+1 -! ! f is such that f.\tilde{c_i} = c_i -! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) -! -! ! Avoid numerical instabilities -! f = min(f,2.d0) -! f = max(f,-2.d0) -! -! f = 1.d0 -! -! u_0(k) = rho_mrcc(i,1)*f -! keys_tmp(:,:,k) = psi_non_ref(:,:,i) -! norm += u_0(k)**2 -! overlap += u_0(k)*psi_non_ref_coef(i,1) -! enddo -! -! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) -! print *, 'Energy of |(1+T)Psi_0> : ', e_0 + nuclear_repulsion, overlap -! -! f = 1.d0/norm -! norm = 1.d0 -! do i=1,N_det_ref -! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) -! enddo -! f = dsqrt(f*norm) -! overlap = norm -! do i=1,N_det_non_ref -! u_0(k) = rho_mrcc(i,1)*f -! overlap += u_0(k)*psi_non_ref_coef(i,1) -! enddo -! -! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) -! print *, 'Energy of |(1+T)Psi_0> (normalized) : ', e_0 + nuclear_repulsion, overlap -! -! k=0 -! overlap = 0.d0 -! do i=1,N_det_ref -! k = k+1 -! u_0(k) = psi_ref_coef(i,1) -! keys_tmp(:,:,k) = psi_ref(:,:,i) -! overlap += u_0(k)*psi_ref_coef(i,1) -! enddo -! norm = 0.d0 -! do i=1,N_det_non_ref -! k = k+1 -! ! f is such that f.\tilde{c_i} = c_i -! f = psi_non_ref_coef(i,1) / rho_mrcc(i,1) -! -! ! Avoid numerical instabilities -! f = min(f,2.d0) -! f = max(f,-2.d0) -! -! u_0(k) = rho_mrcc(i,1)*f -! keys_tmp(:,:,k) = psi_non_ref(:,:,i) -! norm += u_0(k)**2 -! overlap += u_0(k)*psi_non_ref_coef(i,1) -! enddo -! -! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) -! print *, 'Energy of |(1+T)Psi_0> (mu_i): ', e_0 + nuclear_repulsion, overlap -! -! f = 1.d0/norm -! norm = 1.d0 -! do i=1,N_det_ref -! norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) -! enddo -! overlap = norm -! f = dsqrt(f*norm) -! do i=1,N_det_non_ref -! u_0(k) = rho_mrcc(i,1)*f -! overlap += u_0(k)*psi_non_ref_coef(i,1) -! enddo -! -! call u_0_H_u_0(e_0,u_0,N_det,keys_tmp,N_int,1,N_det) -! print *, 'Energy of |(1+T)Psi_0> (normalized mu_i) : ', e_0 + nuclear_repulsion, overlap -! -! deallocate(u_0, keys_tmp) -! -!--------------- + print *, "norm : ", sqrt(norm) + enddo + + do s=1,N_states norm = 0.d0 double precision :: f do i=1,N_det_non_ref @@ -976,7 +888,6 @@ END_PROVIDER ! rho_mrcc now contains the product of the scaling factors and the ! normalization constant - dIj_unique(1:size(X), s) = X(1:size(X)) end do END_PROVIDER From b9255c1a5102e9cad10b33f1637c430e5dba1c74 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 9 Dec 2016 15:52:55 +0100 Subject: [PATCH 164/188] Minor changes --- plugins/MRCC_Utils/mrcc_utils.irp.f | 1 + plugins/QmcChem/e_curve_qmc.irp.f | 2 ++ 2 files changed, 3 insertions(+) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index f5fb2ba6..7f53657c 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -33,6 +33,7 @@ END_PROVIDER if (ihpsi_current(k) == 0.d0) then ihpsi_current(k) = 1.d-32 endif +! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) lambda_mrcc(k,i) = min(-1.d-32,psi_non_ref_coef(i,k)/ihpsi_current(k) ) lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) if (lambda_pert / lambda_mrcc(k,i) < 0.5d0) then diff --git a/plugins/QmcChem/e_curve_qmc.irp.f b/plugins/QmcChem/e_curve_qmc.irp.f index d45624a0..169db84e 100644 --- a/plugins/QmcChem/e_curve_qmc.irp.f +++ b/plugins/QmcChem/e_curve_qmc.irp.f @@ -5,6 +5,8 @@ program e_curve double precision :: norm, E, hij, num, ci, cj integer, allocatable :: iorder(:) double precision , allocatable :: norm_sort(:) + PROVIDE mo_bielec_integrals_in_map + nab = n_det_alpha_unique+n_det_beta_unique allocate ( norm_sort(0:nab), iorder(0:nab) ) From f2719e33f5b95d86deeec721900f16474c9dbed7 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 12 Dec 2016 12:16:56 +0100 Subject: [PATCH 165/188] Fixed mrcc=2 --- plugins/MRCC_Utils/mrcc_utils.irp.f | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 4658118b..5a5fb656 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -848,12 +848,16 @@ END_PROVIDER rho_mrcc(i,s) = 1.d-32 endif - ! f is such that f.\tilde{c_i} = c_i - f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) + if (lambda_type == 2) then + f = 1.d0 + else + ! f is such that f.\tilde{c_i} = c_i + f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) - ! Avoid numerical instabilities - f = min(f,2.d0) - f = max(f,-2.d0) + ! Avoid numerical instabilities + f = min(f,2.d0) + f = max(f,-2.d0) + endif norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) rho_mrcc(i,s) = f @@ -928,6 +932,7 @@ double precision function get_dij_index(II, i, s, Nint) else if(lambda_type == 2) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase + get_dij_index = get_dij_index * rho_mrcc(i,s) end if end function From 83488629757b5c7a0450748177ab7d7e16365daa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 12 Dec 2016 14:22:24 +0100 Subject: [PATCH 166/188] More applications of H in fci_zmq --- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 4 ++-- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 758527bc..881f74c3 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -68,8 +68,8 @@ program fci_zmq call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) n_det_before = N_det - to_select = 3*N_det - to_select = max(256-to_select, to_select) + to_select = 2*N_det + to_select = max(64-to_select, to_select) to_select = min(to_select,N_det_max-n_det_before) call ZMQ_selection(to_select, pt2) diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index f629e7bc..ae0d7989 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -68,8 +68,8 @@ program fci_zmq call ezfio_set_full_ci_zmq_energy(CI_energy(1)) n_det_before = N_det - to_select = 3*N_det - to_select = max(1024-to_select, to_select) + to_select = 2*N_det + to_select = max(64-to_select, to_select) to_select = min(to_select, N_det_max-n_det_before) call ZMQ_selection(to_select, pt2) From 348032f200c1463bca6843cc1f3b908ad3d42427 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 12 Dec 2016 21:26:01 +0100 Subject: [PATCH 167/188] Solved MRPT_Utils problem --- plugins/All_singles/.gitignore | 32 ------------------------- plugins/Full_CI_ZMQ/.gitignore | 34 -------------------------- plugins/mrcepa0/.gitignore | 36 ---------------------------- src/MRPT_Utils/MRPT_Utils_main.irp.f | 3 --- 4 files changed, 105 deletions(-) delete mode 100644 plugins/All_singles/.gitignore delete mode 100644 plugins/Full_CI_ZMQ/.gitignore delete mode 100644 plugins/mrcepa0/.gitignore delete mode 100644 src/MRPT_Utils/MRPT_Utils_main.irp.f diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore deleted file mode 100644 index cae0c971..00000000 --- a/plugins/All_singles/.gitignore +++ /dev/null @@ -1,32 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_restart -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_no_sorted -Utils -ZMQ -all_1h_1p -all_singles -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore deleted file mode 100644 index a996a508..00000000 --- a/plugins/Full_CI_ZMQ/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Full_CI -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -fci_zmq -irpf90.make -irpf90_entities -selection_davidson_slave -selection_slave -tags \ No newline at end of file diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore deleted file mode 100644 index 7d9ee55d..00000000 --- a/plugins/mrcepa0/.gitignore +++ /dev/null @@ -1,36 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -MRCC_Utils -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Psiref_CAS -Psiref_Utils -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc -mrcepa0 -mrsc2 -tags \ No newline at end of file diff --git a/src/MRPT_Utils/MRPT_Utils_main.irp.f b/src/MRPT_Utils/MRPT_Utils_main.irp.f deleted file mode 100644 index fb17f054..00000000 --- a/src/MRPT_Utils/MRPT_Utils_main.irp.f +++ /dev/null @@ -1,3 +0,0 @@ - program MRPT_Utils_main - print *, "I'm a core module, I need an main! (maybe a stupid rule)" - end program MRPT_Utils_main From fcf621e5e0d90abf1f72e5e4aa869d1b7f725e5f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 13 Dec 2016 09:41:41 +0100 Subject: [PATCH 168/188] Removed comments --- plugins/MRCC_Utils/mrcc_utils.irp.f | 72 ----------------------------- 1 file changed, 72 deletions(-) diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 3a5ccf24..d6b9cc79 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -78,19 +78,6 @@ BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] END_PROVIDER -! BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -!&BEGIN_PROVIDER [ double precision, delta_ii, (N_states,N_det_ref) ] -! implicit none -! BEGIN_DOC -! ! Dressing matrix in N_det basis -! END_DOC -! integer :: i,j,m -! delta_ij = 0.d0 -! delta_ii = 0.d0 -! call H_apply_mrcc(delta_ij,delta_ii,N_states,N_det_non_ref,N_det_ref) -! -!END_PROVIDER - BEGIN_PROVIDER [ double precision, h_matrix_dressed, (N_det,N_det,N_states) ] implicit none @@ -175,43 +162,6 @@ END_PROVIDER call u_0_S2_u_0(CI_eigenvectors_s2_dressed,CI_eigenvectors_dressed,N_det,psi_det,N_int,& N_states_diag,size(CI_eigenvectors_dressed,1)) -! double precision :: u_dot_u -! double precision, allocatable :: h(:,:,:), s(:,:) -! allocate (h(N_states,N_states,N_states), s(N_states,N_states)) -! do i=1,N_states -! do j=1,N_states -! s(i,j) = u_dot_v(CI_eigenvectors_dressed(1,i),CI_eigenvectors_dressed(1,j),N_det) -! print *, 'S(',i,',',j,')', s(i,j) -! enddo -! enddo -! -! do i=1,N_states -! h(i,i) = CI_electronic_energy_dressed(i) -! do j=i+1,N_states -! h(j,i) = (CI_electronic_energy_dressed(j)-CI_electronic_energy_dressed(i)) * s(i,j) -! h(i,j) = -h(j,i) -! print *, 'h(',i,',',i,')', h(i,j) -! enddo -! print *, 'h(',i,',',i,')', h(i,i) -! enddo -! call lapack_diag(eigenvalues,eigenvectors, h,size(h,1),N_states) -! do i=1,N_states -! CI_electronic_energy_dressed(i) = eigenvalues(i) -! do j=1,N_states -! h(i,j) = eigenvectors(i,j) -! enddo -! enddo -! do k=1,N_states -! eigenvectors(1:N_det,k) = 0.d0 -! do i=1,N_states -! eigenvectors(1:N_det,k) += CI_eigenvectors_dressed(1:N_det,k) * h(k,i) -! enddo -! enddo -! deallocate(h,s) -! - -! call multi_state(CI_electronic_energy_dressed,CI_eigenvectors_dressed,size(CI_eigenvectors_dressed,1)) - deallocate (eigenvectors,eigenvalues) else if (diag_algorithm == "Lapack") then @@ -791,29 +741,8 @@ END_PROVIDER end do dIj_unique(1:size(X), s) = X(1:size(X)) -! double precision, external :: ddot -! if (ddot (size(X), dIj_unique, 1, X, 1) < 0.d0) then -! dIj_unique(1:size(X),s) = -X(1:size(X)) -! endif - enddo - ! Adjust phase of dIj_unique - -! double precision :: snorm -! X = 0.d0 -! snorm = 0.d0 -! do s=1,N_states -! norm = 0.d0 -! do i=1,N_det_non_ref -! norm = norm + psi_non_ref_coef(i,s)*psi_non_ref_coef(i,s) -! enddo -! norm = dsqrt(norm) -! X(1:size(X)) = X(1:size(X)) + dIj_unique(1:size(X),s) * norm -! snorm += norm -! enddo -! X = X/snorm - do s=1,N_states do a_coll=1,n_exc_active @@ -822,7 +751,6 @@ END_PROVIDER i = active_excitation_to_determinants_idx(j,a_coll) if (i==0) exit rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s) -! rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * X(a_col) enddo end do From 683189855ab6b5709552d2a067c3b72326d7287c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 13 Dec 2016 12:29:48 +0100 Subject: [PATCH 169/188] De-symmetrized u0_H_u0 --- src/Davidson/u0Hu0.irp.f | 70 +++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 37 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index cf28cf12..c7592fad 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -88,7 +88,7 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) - do sh2=sh,shortcut(0,1) + do sh2=1,shortcut(0,1) exa = popcnt(xor(version(1,sh,1), version(1,sh2,1))) if(exa > 2) then cycle @@ -102,16 +102,11 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) do i=shortcut(sh,1),shortcut(sh+1,1)-1 org_i = sort_idx(i,1) - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1,1)-1 - end if do ni=1,Nint sorted_i(ni) = sorted(ni,i,1) enddo - jloop: do j=shortcut(sh2,1),endi + jloop: do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 org_j = sort_idx(j,1) ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) if(ext > 4) then @@ -126,7 +121,6 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) do istate=1,N_st vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) enddo enddo jloop enddo @@ -138,7 +132,7 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) - do j=shortcut(sh,2),i-1 + do j=shortcut(sh,2),shortcut(sh+1,2)-1 org_j = sort_idx(j,2) ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) do ni=2,Nint @@ -150,7 +144,6 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) do istate=1,N_st vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) enddo end do end do @@ -336,27 +329,29 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) v_0 = 0.d0 s_0 = 0.d0 - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(i,istate) - enddo - enddo - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) !$OMP PARALLEL DEFAULT(NONE) & !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,keys_tmp,ut,Nint,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) allocate(vt(N_st_8,n),st(N_st_8,n)) Vt = 0.d0 St = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) - do j=shortcut(sh,2),i-1 + do j=shortcut(sh,2),shortcut(sh+1,2)-1 org_j = sort_idx(j,2) ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) if (ext > 4) cycle @@ -368,19 +363,26 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) - st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) enddo end if end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) - !$OMP DO SCHEDULE(dynamic) - do sh2=sh,shortcut(0,1) + do sh2=1,shortcut(0,1) exa = 0 do ni=1,Nint exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) @@ -391,16 +393,12 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) do i=shortcut(sh,1),shortcut(sh+1,1)-1 org_i = sort_idx(i,1) - if(sh==sh2) then - endi = i-1 - else - endi = shortcut(sh2+1,1)-1 - end if do ni=1,Nint sorted_i(ni) = sorted(ni,i,1) enddo - do j=shortcut(sh2,1),endi + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + if (i==j) cycle ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) if (ext > 4) cycle do ni=2,Nint @@ -412,16 +410,14 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) if (hij /= 0.d0) then do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - vt (istate,org_j) = vt (istate,org_j) + hij*ut(istate,org_i) + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) enddo endif if (ext /= 2) then call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) if (s2 /= 0.d0) then do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,org_j) - st (istate,org_j) = st (istate,org_j) + s2*ut(istate,org_i) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) enddo endif endif @@ -429,8 +425,8 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo enddo enddo - !$OMP END DO NOWAIT enddo + !$OMP END DO !$OMP CRITICAL (u0Hu0) do istate=1,N_st From c911db7f8e57fa878c7d34ba6c58860d2b1260af Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 13 Dec 2016 12:40:12 +0100 Subject: [PATCH 170/188] Accelerated u0_h_u0 --- src/Davidson/u0Hu0.irp.f | 66 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 65 insertions(+), 1 deletion(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index c7592fad..117e704e 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -383,6 +383,8 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + exa = 0 do ni=1,Nint exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) @@ -398,7 +400,6 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - if (i==j) cycle ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) if (ext > 4) cycle do ni=2,Nint @@ -423,6 +424,69 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) endif endif enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + if (i==j) cycle + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif enddo enddo enddo From f85d467d79a987da59ad24a9e00bf4524c52904f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 13 Dec 2016 17:09:10 +0100 Subject: [PATCH 171/188] Corrected travis --- tests/bats/cassd.bats | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 8cbc4899..18ab72e2 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,7 +13,7 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.2311422169983 5.E-5 + eq $energy -76.231084536315 5.E-5 ezfio set determinants n_det_max 2048 ezfio set determinants read_wf True From 2f517fe52c5841ddbcbb7d2c9e06ae5624355533 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 13 Dec 2016 18:36:50 +0100 Subject: [PATCH 172/188] Fixed tests --- tests/bats/cassd.bats | 2 +- tests/bats/mrcepa0.bats | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 18ab72e2..2a8fabc2 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -21,6 +21,6 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_run cassd_zmq $INPUT ezfio set determinants read_wf False energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2300888408526 2.E-5 + eq $energy -76.2300887947446 2.E-5 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index e4b45f65..dc9e0bb4 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.23857580469 1.e-4 + eq $energy -76.23752746236 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,7 +32,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.238510023275 2.e-4 + eq $energy -76.237469267705 2.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,7 +48,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2357889658142 2.e-4 + eq $energy -76.2347764009137 2.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,6 +64,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2417748223423 2.e-4 + eq $energy -76.2406942855164 2.e-4 } From bbc6065f25a4647f136d8a5ed327d283696431e1 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 15 Dec 2016 12:10:43 +0100 Subject: [PATCH 173/188] Improved parallelism in davidson --- src/Davidson/u0Hu0.irp.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 117e704e..9c097c49 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -324,7 +324,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) PROVIDE ref_bitmask_energy allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate(ut(N_st_8,n)) + allocate( ut(N_st_8,n)) v_0 = 0.d0 s_0 = 0.d0 @@ -347,7 +347,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -380,7 +380,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(static,1) COLLAPSE(2) do sh=1,shortcut(0,1) do sh2=1,shortcut(0,1) if (sh==sh2) cycle From 3e37fcd12bd475a01aac1eb6057993d5a323ab7d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 19 Dec 2016 13:27:16 +0100 Subject: [PATCH 174/188] Wf analyzis --- ocaml/Basis.ml | 14 +++-- ocaml/Basis.mli | 2 +- plugins/analyze_wf/NEEDED_CHILDREN_MODULES | 1 + plugins/analyze_wf/README.rst | 12 ++++ plugins/analyze_wf/analyze_wf.irp.f | 70 ++++++++++++++++++++++ plugins/analyze_wf/occupation.irp.f | 23 +++++++ src/Determinants/density_matrix.irp.f | 1 - 7 files changed, 115 insertions(+), 8 deletions(-) create mode 100644 plugins/analyze_wf/NEEDED_CHILDREN_MODULES create mode 100644 plugins/analyze_wf/README.rst create mode 100644 plugins/analyze_wf/analyze_wf.irp.f create mode 100644 plugins/analyze_wf/occupation.irp.f diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml index 869fb132..797d53f2 100644 --- a/ocaml/Basis.ml +++ b/ocaml/Basis.ml @@ -36,9 +36,11 @@ let read_element in_channel at_number element = -let to_string_general ~fmt ~atom_sep b = +let to_string_general ~fmt ~atom_sep ?ele_array b = let new_nucleus n = - Printf.sprintf "Atom %d" n + match ele_array with + | None -> Printf.sprintf "Atom %d" n + | Some x -> Printf.sprintf "%s" (Element.to_string x.(n-1)) in let rec do_work accu current_nucleus = function | [] -> List.rev accu @@ -56,12 +58,12 @@ let to_string_general ~fmt ~atom_sep b = do_work [new_nucleus 1] 1 b |> String.concat ~sep:"\n" -let to_string_gamess = - to_string_general ~fmt:Gto.Gamess ~atom_sep:"" +let to_string_gamess ?ele_array = + to_string_general ?ele_array ~fmt:Gto.Gamess ~atom_sep:"" -let to_string_gaussian b = +let to_string_gaussian ?ele_array b = String.concat ~sep:"\n" - [ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] + [ to_string_general ?ele_array ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] let to_string ?(fmt=Gto.Gamess) = match fmt with diff --git a/ocaml/Basis.mli b/ocaml/Basis.mli index 249c14f9..41ddc184 100644 --- a/ocaml/Basis.mli +++ b/ocaml/Basis.mli @@ -14,7 +14,7 @@ val read_element : in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list (** Convert the basis to a string *) -val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string +val to_string : ?fmt:Gto.fmt -> ?ele_array:Element.t array -> (Gto.t * Nucl_number.t) list -> string (** Convert the basis to an MD5 hash *) val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t diff --git a/plugins/analyze_wf/NEEDED_CHILDREN_MODULES b/plugins/analyze_wf/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/plugins/analyze_wf/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/plugins/analyze_wf/README.rst b/plugins/analyze_wf/README.rst new file mode 100644 index 00000000..179e407d --- /dev/null +++ b/plugins/analyze_wf/README.rst @@ -0,0 +1,12 @@ +========== +analyze_wf +========== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/analyze_wf/analyze_wf.irp.f b/plugins/analyze_wf/analyze_wf.irp.f new file mode 100644 index 00000000..6d8bffcf --- /dev/null +++ b/plugins/analyze_wf/analyze_wf.irp.f @@ -0,0 +1,70 @@ +program analyze_wf + implicit none + BEGIN_DOC +! Wave function analyzis + END_DOC + read_wf = .True. + SOFT_TOUCH read_wf + call run() +end + +subroutine run + implicit none + integer :: istate, i + integer :: class(0:mo_tot_num,5) + double precision :: occupation(mo_tot_num) + + write(*,'(A)') 'MO Occupation' + write(*,'(A)') '=============' + write(*,'(A)') '' + do istate=1,N_states + call get_occupation_from_dets(occupation,1) + write(*,'(A)') '' + write(*,'(A,I3)'), 'State ', istate + write(*,'(A)') '---------------' + write(*,'(A)') '' + write (*,'(A)') '======== ================' + class = 0 + do i=1,mo_tot_num + write (*,'(I8,X,F16.10)') i, occupation(i) + if (occupation(i) > 1.999d0) then + class(0,1) += 1 + class( class(0,1), 1) = i + else if (occupation(i) > 1.95d0) then + class(0,2) += 1 + class( class(0,2), 2) = i + else if (occupation(i) < 0.001d0) then + class(0,5) += 1 + class( class(0,5), 5) = i + else if (occupation(i) < 0.01d0) then + class(0,4) += 1 + class( class(0,4), 4) = i + else + class(0,3) += 1 + class( class(0,3), 3) = i + endif + enddo + write (*,'(A)') '======== ================' + write (*,'(A)') '' + + write (*,'(A)') 'Suggested classes' + write (*,'(A)') '-----------------' + write (*,'(A)') '' + write (*,'(A)') 'Core :' + write (*,*) (class(i,1), ',', i=1,class(0,1)) + write (*,*) '' + write (*,'(A)') 'Inactive :' + write (*,*) (class(i,2), ',', i=1,class(0,2)) + write (*,'(A)') '' + write (*,'(A)') 'Active :' + write (*,*) (class(i,3), ',', i=1,class(0,3)) + write (*,'(A)') '' + write (*,'(A)') 'Virtual :' + write (*,*) (class(i,4), ',', i=1,class(0,4)) + write (*,'(A)') '' + write (*,'(A)') 'Deleted :' + write (*,*) (class(i,5), ',', i=1,class(0,5)) + write (*,'(A)') '' + enddo + +end diff --git a/plugins/analyze_wf/occupation.irp.f b/plugins/analyze_wf/occupation.irp.f new file mode 100644 index 00000000..d426dc14 --- /dev/null +++ b/plugins/analyze_wf/occupation.irp.f @@ -0,0 +1,23 @@ +subroutine get_occupation_from_dets(occupation, istate) + implicit none + double precision, intent(out) :: occupation(mo_tot_num) + integer, intent(in) :: istate + BEGIN_DOC + ! Returns the average occupation of the MOs + END_DOC + integer :: i,j, ispin + integer :: list(N_int*bit_kind_size,2) + integer :: n_elements(2) + double precision :: c + + occupation = 0.d0 + do i=1,N_det + c = psi_coef(i,istate)*psi_coef(i,istate) + call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int) + do ispin=1,2 + do j=1,n_elements(ispin) + occupation( list(j,ispin) ) += c + enddo + enddo + enddo +end diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 118bbdf7..ed2f49bd 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -194,7 +194,6 @@ subroutine set_natural_mos double precision, allocatable :: tmp(:,:) label = "Natural" -! call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,label,-1) call mo_as_svd_vectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,mo_tot_num,label) end From d5eb7a1963c61a57b28454028fc87f3a8ba4facf Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 19 Dec 2016 14:13:26 +0100 Subject: [PATCH 175/188] Corrected tests --- tests/bats/pseudo.bats | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 4b374d76..919d50ce 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -48,6 +48,6 @@ function run_FCI_ZMQ() { @test "FCI H2O VDZ pseudo" { qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]" - run_FCI_ZMQ h2o_pseudo.ezfio 2000 -17.0399584106077 -17.0400170044515 + run_FCI_ZMQ h2o_pseudo.ezfio 2000 -17.035547572687399 -17.035583407558221 } From 0653c435cd573994b192016d8b184329a0d6ae66 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 19 Dec 2016 14:24:43 +0100 Subject: [PATCH 176/188] Travis --- src/Davidson/u0Hu0.irp.f | 2 +- tests/bats/pseudo.bats | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 9c097c49..6e20f0d0 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -380,7 +380,7 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO - !$OMP DO SCHEDULE(static,1) COLLAPSE(2) + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,1) do sh2=1,shortcut(0,1) if (sh==sh2) cycle diff --git a/tests/bats/pseudo.bats b/tests/bats/pseudo.bats index 919d50ce..4b374d76 100644 --- a/tests/bats/pseudo.bats +++ b/tests/bats/pseudo.bats @@ -48,6 +48,6 @@ function run_FCI_ZMQ() { @test "FCI H2O VDZ pseudo" { qp_set_mo_class h2o_pseudo.ezfio -core "[1]" -act "[2-12]" -del "[13-23]" - run_FCI_ZMQ h2o_pseudo.ezfio 2000 -17.035547572687399 -17.035583407558221 + run_FCI_ZMQ h2o_pseudo.ezfio 2000 -17.0399584106077 -17.0400170044515 } From 8cbe460f177c4d991de4f315585028d97c0eb421 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 26 Dec 2016 17:11:44 +0100 Subject: [PATCH 177/188] Introduces PT2max ZMQ --- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 121 ----------------------- plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f | 95 ++++++++++++++++++ plugins/Full_CI_ZMQ/zmq_selection.irp.f | 117 ++++++++++++++++++++++ 3 files changed, 212 insertions(+), 121 deletions(-) create mode 100644 plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f create mode 100644 plugins/Full_CI_ZMQ/zmq_selection.irp.f diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index ae0d7989..ee86a8f7 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -117,124 +117,3 @@ program fci_zmq call ezfio_set_full_ci_zmq_energy(CI_energy(1)) call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end - - - - -subroutine ZMQ_selection(N_in, pt2) - use f77_zmq - use selection_types - - implicit none - - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, intent(in) :: N_in - type(selection_buffer) :: b - integer :: i, N - integer, external :: omp_get_thread_num - double precision, intent(out) :: pt2(N_states) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - integer :: i_generator, i_generator_start, i_generator_max, step -! step = int(max(1.,10*elec_num/mo_tot_num) - - step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) - step = max(1,step) - do i= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - write(task,*) i_generator_start, i_generator_max, 1, N - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif - !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') - if (N_in > 0) then - call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN - call copy_H_apply_buffer_to_wf() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -end - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) - done = 0 - more = 1 - pt2(:) = 0d0 - call CPU_TIME(time0) - do while (more == 1) - call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) - pt2 += pt2_mwen - do i=1, N - call add_to_selection_buffer(b, det(1,1,i), val(i)) - end do - - do i=1, ntask - if(task_id(i) == 0) then - print *, "Error in collector" - endif - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) - end do - done += ntask - call CPU_TIME(time) -! print *, "DONE" , done, time - time0 - end do - - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - call sort_selection_buffer(b) -end subroutine - diff --git a/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f new file mode 100644 index 00000000..52f825f1 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f @@ -0,0 +1,95 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref, pt2_ratio + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + pt2_ratio = (E_ref + pt2_max - HF_energy) / (E_ref - HF_energy) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = N_det/8 + do while (Nmax-Nmin > 1) + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + if (ratio < pt2_ratio) then + Nmin = N_det + to_select = (Nmax-Nmin)/2 + call ZMQ_selection(to_select, pt2) + else + Nmax = N_det + N_det = Nmin + (Nmax-Nmin)/2 + endif + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', pt2_ratio + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) +end + + + + diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f new file mode 100644 index 00000000..75992273 --- /dev/null +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -0,0 +1,117 @@ +subroutine ZMQ_selection(N_in, pt2) + use f77_zmq + use selection_types + + implicit none + + character*(512) :: task + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + integer, intent(in) :: N_in + type(selection_buffer) :: b + integer :: i, N + integer, external :: omp_get_thread_num + double precision, intent(out) :: pt2(N_states) + + + if (.True.) then + PROVIDE pt2_e0_denominator + N = max(N_in,1) + provide nproc + call new_parallel_job(zmq_to_qp_run_socket,"selection") + call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) + call zmq_set_running(zmq_to_qp_run_socket) + call create_selection_buffer(N, N*2, b) + endif + + integer :: i_generator, i_generator_start, i_generator_max, step +! step = int(max(1.,10*elec_num/mo_tot_num) + + step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) + step = max(1,step) + do i= 1, N_det_generators,step + i_generator_start = i + i_generator_max = min(i+step-1,N_det_generators) + write(task,*) i_generator_start, i_generator_max, 1, N + call add_task_to_taskserver(zmq_to_qp_run_socket,task) + end do + + !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call selection_collector(b, pt2) + else + call selection_slave_inproc(i) + endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'selection') + if (N_in > 0) then + call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN + call copy_H_apply_buffer_to_wf() + if (s2_eig) then + call make_s2_eigenfunction + endif + endif +end subroutine + + +subroutine selection_slave_inproc(i) + implicit none + integer, intent(in) :: i + + call run_selection_slave(1,i,pt2_e0_denominator) +end + +subroutine selection_collector(b, pt2) + use f77_zmq + use selection_types + use bitmasks + implicit none + + + type(selection_buffer), intent(inout) :: b + double precision, intent(out) :: pt2(N_states) + double precision :: pt2_mwen(N_states) + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer :: msg_size, rc, more + integer :: acc, i, j, robin, N, ntask + double precision, allocatable :: val(:) + integer(bit_kind), allocatable :: det(:,:,:) + integer, allocatable :: task_id(:) + integer :: done + real :: time, time0 + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) + done = 0 + more = 1 + pt2(:) = 0d0 + call CPU_TIME(time0) + do while (more == 1) + call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) + pt2 += pt2_mwen + do i=1, N + call add_to_selection_buffer(b, det(1,1,i), val(i)) + end do + + do i=1, ntask + if(task_id(i) == 0) then + print *, "Error in collector" + endif + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) + end do + done += ntask + call CPU_TIME(time) +! print *, "DONE" , done, time - time0 + end do + + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + call sort_selection_buffer(b) +end subroutine + From 956c1e46807c8452714ef3f25e7599aaba6e6808 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 26 Dec 2016 17:38:26 +0100 Subject: [PATCH 178/188] target_pt2_ratio_zmq --- .../Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f | 96 +++++++++++++++++++ 1 file changed, 96 insertions(+) create mode 100644 plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f diff --git a/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f new file mode 100644 index 00000000..10ef4777 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f @@ -0,0 +1,96 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + ! Stopping criterion is the PT2max + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = N_det/8 + do while (Nmax-Nmin > 1) + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + if (ratio < var_pt2_ratio) then + Nmin = N_det + to_select = (Nmax-Nmin)/2 + call ZMQ_selection(to_select, pt2) + else + Nmax = N_det + N_det = Nmin + (Nmax-Nmin)/2 + endif + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) +end + + + + From fb5432abe00634a17c0288641f55bcb7ff604725 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 26 Dec 2016 19:02:53 +0100 Subject: [PATCH 179/188] Better target_pt2_ratio_zmq --- .../Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f | 29 ++++++++++++------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f index 10ef4777..77bbab03 100644 --- a/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f @@ -7,6 +7,10 @@ program fci_zmq integer :: Nmin, Nmax integer :: n_det_before, to_select double precision :: threshold_davidson_in, ratio, E_ref + + double precision, allocatable :: psi_coef_ref(:,:) + integer(bit_kind), allocatable :: psi_det_ref(:,:,:) + allocate (pt2(N_states)) @@ -56,34 +60,39 @@ program fci_zmq print *, 'Est FCI = ', E_ref Nmax = N_det - Nmin = N_det/8 + Nmin = 2 + allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2))) + allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3))) + psi_coef_ref = psi_coef_sorted + psi_det_ref = psi_det_sorted + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det do while (Nmax-Nmin > 1) + psi_coef = psi_coef_ref + psi_det = psi_det_ref + TOUCH psi_det psi_coef call diagonalize_CI ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - TOUCH psi_coef psi_det if (ratio < var_pt2_ratio) then Nmin = N_det - to_select = (Nmax-Nmin)/2 - call ZMQ_selection(to_select, pt2) else Nmax = N_det - N_det = Nmin + (Nmax-Nmin)/2 endif + N_det = Nmin + (Nmax-Nmin)/2 print *, '-----' print *, 'Det min, Det max: ', Nmin, Nmax print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio - print *, 'HF_energy = ', HF_energy - print *, 'Est FCI = ', E_ref print *, 'N_det = ', N_det print *, 'E = ', CI_energy(1) - print *, 'PT2 = ', pt2(1) enddo call ZMQ_selection(0, pt2) print *, '------' + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref print *, 'E = ', CI_energy(1) print *, 'PT2 = ', pt2(1) + print *, 'E+PT2 = ', CI_energy(1)+pt2(1) E_CI_before(1:N_states) = CI_energy(1:N_states) call save_wavefunction From 82772b96c7675b263e1b0a0b13e3678d38f17ae9 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 29 Dec 2016 22:00:41 +0100 Subject: [PATCH 180/188] MRCC_selected --- plugins/Psiref_threshold/psi_ref.irp.f | 71 ++++-- plugins/mrcc_selected/dressing.irp.f | 80 ++----- plugins/mrcc_selected/mrcc_selected.irp.f | 1 - plugins/mrcc_selected/mrcepa0_general.irp.f | 15 +- src/Davidson/u0Hu0.irp.f | 234 ++++++++++++++------ src/Determinants/Fock_diag.irp.f | 9 + 6 files changed, 239 insertions(+), 171 deletions(-) diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f index ee69ef5c..62321140 100644 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ b/plugins/Psiref_threshold/psi_ref.irp.f @@ -1,5 +1,44 @@ use bitmasks +! BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] +!&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] +!&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] +!&BEGIN_PROVIDER [ integer, N_det_ref ] +! implicit none +! BEGIN_DOC +! ! Reference wave function, defined as determinants with amplitudes > 0.05 +! ! idx_ref gives the indice of the ref determinant in psi_det. +! END_DOC +! integer :: i, k, l +! logical :: good +! double precision, parameter :: threshold=0.01d0 +! double precision :: t(N_states) +! N_det_ref = 0 +! do l = 1, N_states +! t(l) = threshold * abs_psi_coef_max(l) +! enddo +! do i=1,N_det +! good = .False. +! do l=1, N_states +! psi_ref_coef(i,l) = 0.d0 +! good = good.or.(dabs(psi_coef(i,l)) > t(l)) +! enddo +! if (good) then +! N_det_ref = N_det_ref+1 +! do k=1,N_int +! psi_ref(k,1,N_det_ref) = psi_det(k,1,i) +! psi_ref(k,2,N_det_ref) = psi_det(k,2,i) +! enddo +! idx_ref(N_det_ref) = i +! do k=1,N_states +! psi_ref_coef(N_det_ref,k) = psi_coef(i,k) +! enddo +! endif +! enddo +! call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') +! +!END_PROVIDER + BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] &BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] &BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] @@ -10,30 +49,16 @@ use bitmasks ! idx_ref gives the indice of the ref determinant in psi_det. END_DOC integer :: i, k, l - logical :: good - double precision, parameter :: threshold=0.05d0 - double precision :: t(N_states) - N_det_ref = 0 - do l = 1, N_states - t(l) = threshold * abs_psi_coef_max(l) - enddo - do i=1,N_det - good = .False. - do l=1, N_states - psi_ref_coef(i,l) = 0.d0 - good = good.or.(dabs(psi_coef(i,l)) > t(l)) + double precision, parameter :: threshold=0.01d0 + + call find_reference(threshold, N_det_ref, idx_ref) + do l=1,N_states + do i=1,N_det_ref + psi_ref_coef(i,l) = psi_coef(idx_ref(i), l) enddo - if (good) then - N_det_ref = N_det_ref+1 - do k=1,N_int - psi_ref(k,1,N_det_ref) = psi_det(k,1,i) - psi_ref(k,2,N_det_ref) = psi_det(k,2,i) - enddo - idx_ref(N_det_ref) = i - do k=1,N_states - psi_ref_coef(N_det_ref,k) = psi_coef(i,k) - enddo - endif + enddo + do i=1,N_det_ref + psi_ref(:,:,i) = psi_det(:,:,idx_ref(i)) enddo call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f index c772e2aa..23fedcee 100644 --- a/plugins/mrcc_selected/dressing.irp.f +++ b/plugins/mrcc_selected/dressing.irp.f @@ -534,63 +534,9 @@ END_PROVIDER END_PROVIDER -! BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -! use bitmasks -! implicit none -! integer :: i,j,k -! double precision :: Hjk, Hki, Hij, pre(N_det_ref), wall -! integer :: i_state, degree, npre, ipre(N_det_ref), npres(N_det_ref) -! -! ! provide lambda_mrcc -! npres = 0 -! delta_cas = 0d0 -! call wall_time(wall) -! print *, "dcas ", wall -! do i_state = 1, N_states -! !!$OMP PARALLEL DO default(none) schedule(dynamic) private(pre,npre,ipre,j,k,Hjk,Hki,degree) shared(npres,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) -! do k=1,N_det_non_ref -! if(lambda_mrcc(i_state, k) == 0d0) cycle -! npre = 0 -! do i=1,N_det_ref -! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) -! if(Hki /= 0d0) then -! !!$OMP ATOMIC -! npres(i) += 1 -! npre += 1 -! ipre(npre) = i -! pre(npre) = Hki -! end if -! end do -! -! -! do i=1,npre -! do j=1,i -! !!$OMP ATOMIC -! delta_cas(ipre(i),ipre(j),i_state) += pre(i) * pre(j) * lambda_mrcc(i_state, k) -! end do -! end do -! end do -! !!$OMP END PARALLEL DO -! npre=0 -! do i=1,N_det_ref -! npre += npres(i) -! end do -! !stop -! do i=1,N_det_ref -! do j=1,i -! delta_cas(j,i,i_state) = delta_cas(i,j,i_state) -! end do -! end do -! end do -! -! call wall_time(wall) -! print *, "dcas", wall -! ! stop -! END_PROVIDER - - BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] + BEGIN_PROVIDER [ double precision, delta_ref, (N_det_ref, N_det_ref, N_states) ] +&BEGIN_PROVIDER [ double precision, delta_ref_s2, (N_det_ref, N_det_ref, N_states) ] use bitmasks implicit none integer :: i,j,k @@ -600,22 +546,22 @@ END_PROVIDER provide lambda_mrcc dIj do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) + !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_ref,delta_ref_s2,N_det_ref,dij) do i=1,N_det_ref do j=1,i call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) - delta_cas(i,j,i_state) = 0d0 - delta_cas_s2(i,j,i_state) = 0d0 + delta_ref(i,j,i_state) = 0d0 + delta_ref_s2(i,j,i_state) = 0d0 do k=1,N_det_non_ref call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) - delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) + delta_ref(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) + delta_ref_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) end do - delta_cas(j,i,i_state) = delta_cas(i,j,i_state) - delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) + delta_ref(j,i,i_state) = delta_ref(i,j,i_state) + delta_ref_s2(j,i,i_state) = delta_ref_s2(i,j,i_state) end do end do !$OMP END PARALLEL DO @@ -739,7 +685,7 @@ end function !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & + !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_ref, delta_ref_s2) & !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 @@ -781,8 +727,8 @@ end function notf = notf+1 ! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) - contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib = delta_ref(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) + contrib_s2 = delta_ref_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) @@ -828,7 +774,7 @@ END_PROVIDER integer :: II, blok - provide delta_cas lambda_mrcc + provide delta_ref lambda_mrcc allocate(idx_sorted_bit(N_det)) idx_sorted_bit(:) = -1 do i=1,N_det_non_ref diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f index 91592e62..b64f968d 100644 --- a/plugins/mrcc_selected/mrcc_selected.irp.f +++ b/plugins/mrcc_selected/mrcc_selected.irp.f @@ -8,7 +8,6 @@ program mrsc2sub read_wf = .True. SOFT_TOUCH read_wf - call print_cas_coefs call set_generators_bitmasks_as_holes_and_particles call run(N_states,energy) if(do_pt2_end)then diff --git a/plugins/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f index e3a2d1f5..812aeef0 100644 --- a/plugins/mrcc_selected/mrcepa0_general.irp.f +++ b/plugins/mrcc_selected/mrcepa0_general.irp.f @@ -60,16 +60,17 @@ subroutine run(N_st,energy) end -subroutine print_cas_coefs +subroutine print_ref_coefs implicit none integer :: i,j - print *, 'CAS' - print *, '===' - do i=1,N_det_cas - print *, (psi_cas_coef(i,j), j=1,N_states) - call debug_det(psi_cas(1,1,i),N_int) + print *, 'Reference' + print *, '=========' + do i=1,N_det_ref + print *, (psi_ref_coef(i,j), j=1,N_states) + call debug_det(psi_ref(1,1,i),N_int) enddo + print *, '' call write_double(6,ci_energy(1),"Initial CI energy") end @@ -202,7 +203,7 @@ subroutine run_pt2(N_st,energy) print*,'Last iteration only to compute the PT2' - N_det_generators = N_det_cas + N_det_generators = N_det_ref N_det_selectors = N_det_non_ref do i=1,N_det_generators diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 6e20f0d0..9e76bc92 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -32,20 +32,20 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) use bitmasks implicit none BEGIN_DOC - ! Computes v_0 = H|u_0> + ! Computes v_0 = H|u_0> ! ! n : number of determinants ! ! H_jj : array of + ! END_DOC integer, intent(in) :: N_st,n,Nint, sze_8 double precision, intent(out) :: v_0(sze_8,N_st) double precision, intent(in) :: u_0(sze_8,N_st) double precision, intent(in) :: H_jj(n) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij - double precision, allocatable :: vt(:,:) - double precision, allocatable :: ut(:,:) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) integer :: i,j,k,l, jj,ii integer :: i0, j0 @@ -57,77 +57,41 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) integer :: N_st_8 integer, external :: align_double - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut + integer :: blockb, blockb2, istep + double precision :: ave_workload, workload, target_workload_inv + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st N_st_8 = align_double(N_st) ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (n>0) - PROVIDE ref_bitmask_energy + PROVIDE ref_bitmask_energy allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate(ut(N_st_8,n)) + allocate( ut(N_st_8,n)) v_0 = 0.d0 - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(i,istate) - enddo - enddo - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) - + !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,H_jj,keys_tmp,ut,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n)) + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) Vt = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - exa = popcnt(xor(version(1,sh,1), version(1,sh2,1))) - if(exa > 2) then - cycle - end if - do ni=2,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - jloop: do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - org_j = sort_idx(j,1) - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if(ext > 4) then - cycle jloop - endif - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if(ext > 4) then - cycle jloop - endif - end do - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - enddo - enddo jloop - enddo + St = 0.d0 + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) enddo enddo - !$OMP END DO NOWAIT - + !$OMP END DO + !$OMP DO SCHEDULE(dynamic) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 @@ -135,40 +99,164 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) do j=shortcut(sh,2),shortcut(sh+1,2)-1 org_j = sort_idx(j,2) ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle do ni=2,Nint ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit end do - if(ext /= 4) then - cycle - endif - call i_H_j(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),Nint,hij) - do istate=1,N_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,org_j) - enddo + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + end if end do end do enddo - !$OMP END DO NOWAIT - - !$OMP CRITICAL + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(dynamic) + do sh=1,shortcut(0,1) + do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + if (i==j) cycle + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO + + !$OMP CRITICAL (u0Hu0) do istate=1,N_st - do i=n,1,-1 + do i=1,n v_0(i,istate) = v_0(i,istate) + vt(istate,i) enddo enddo - !$OMP END CRITICAL + !$OMP END CRITICAL (u0Hu0) - deallocate(vt) + deallocate(vt,st) !$OMP END PARALLEL - + do istate=1,N_st do i=1,n - v_0(i,istate) += H_jj(i) * u_0(i,istate) + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) enddo enddo deallocate (shortcut, sort_idx, sorted, version, ut) end + BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] implicit none BEGIN_DOC diff --git a/src/Determinants/Fock_diag.irp.f b/src/Determinants/Fock_diag.irp.f index a99bbcad..01393fe1 100644 --- a/src/Determinants/Fock_diag.irp.f +++ b/src/Determinants/Fock_diag.irp.f @@ -19,6 +19,15 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint) fock_diag_tmp = 0.d0 E0 = 0.d0 + if (Ne(1) /= elec_alpha_num) then + print *, 'Error in build_fock_tmp (alpha)', Ne(1), Ne(2) + stop -1 + endif + if (Ne(2) /= elec_beta_num) then + print *, 'Error in build_fock_tmp (beta)', Ne(1), Ne(2) + stop -1 + endif + ! Occupied MOs do ii=1,elec_alpha_num i = occ(ii,1) From bbe9024304f67653b81bac0cfa5ff13431c26566 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 29 Dec 2016 22:01:09 +0100 Subject: [PATCH 181/188] Forgot file --- src/Davidson/find_reference.irp.f | 41 +++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 src/Davidson/find_reference.irp.f diff --git a/src/Davidson/find_reference.irp.f b/src/Davidson/find_reference.irp.f new file mode 100644 index 00000000..0cafd739 --- /dev/null +++ b/src/Davidson/find_reference.irp.f @@ -0,0 +1,41 @@ +subroutine find_reference(thresh,n_ref,result) + implicit none + double precision, intent(in) :: thresh + integer, intent(out) :: result(N_det),n_ref + integer :: i,j,istate + double precision :: i_H_psi_array(1), E0, hii, norm + double precision :: de + integer(bit_kind), allocatable :: psi_ref_(:,:,:) + double precision, allocatable :: psi_ref_coef_(:,:) + + allocate(psi_ref_coef_(N_det,1), psi_ref_(N_int,2,N_det)) + n_ref = 1 + result(1) = 1 + istate = 1 + psi_ref_coef_(1,1) = psi_coef(1,istate) + psi_ref_(:,:,1) = psi_det(:,:,1) + norm = psi_ref_coef_(1,1) * psi_ref_coef_(1,1) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, '' + print *, 'Reference determinants' + print *, '======================' + print *, '' + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + do i=2,N_det + call i_h_psi(psi_det(1,1,i),psi_ref_(1,1,1),psi_ref_coef_(1,istate),N_int, & + n_ref,size(psi_ref_coef_,1),1,i_H_psi_array) + call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii) + de = i_H_psi_array(istate)**2 / (E0 - hii) + if (dabs(de) > thresh) then + n_ref += 1 + result(n_ref) = i + psi_ref_(:,:,n_ref) = psi_det(:,:,i) + psi_ref_coef_(n_ref,1) = psi_coef(i,istate) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + endif + enddo +end + From 0ef200d6b134d7beb41a35827e06b9f389973484 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 29 Dec 2016 22:11:11 +0100 Subject: [PATCH 182/188] Forgot files --- plugins/mrcc_selected/EZFIO.cfg | 33 +++++++++++++++++++ plugins/mrcc_selected/NEEDED_CHILDREN_MODULES | 1 + plugins/mrcc_selected/README.rst | 12 +++++++ 3 files changed, 46 insertions(+) create mode 100644 plugins/mrcc_selected/EZFIO.cfg create mode 100644 plugins/mrcc_selected/NEEDED_CHILDREN_MODULES create mode 100644 plugins/mrcc_selected/README.rst diff --git a/plugins/mrcc_selected/EZFIO.cfg b/plugins/mrcc_selected/EZFIO.cfg new file mode 100644 index 00000000..b64637e6 --- /dev/null +++ b/plugins/mrcc_selected/EZFIO.cfg @@ -0,0 +1,33 @@ +[lambda_type] +type: Positive_int +doc: lambda type +interface: ezfio,provider,ocaml +default: 0 + +[energy] +type: double precision +doc: Calculated energy +interface: ezfio + +[energy_pt2] +type: double precision +doc: Calculated energy with PT2 contribution +interface: ezfio + +[energy] +type: double precision +doc: Calculated energy +interface: ezfio + +[thresh_dressed_ci] +type: Threshold +doc: Threshold on the convergence of the dressed CI energy +interface: ezfio,provider,ocaml +default: 1.e-5 + +[n_it_max_dressed_ci] +type: Strictly_positive_int +doc: Maximum number of dressed CI iterations +interface: ezfio,provider,ocaml +default: 10 + diff --git a/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES b/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..ea28c761 --- /dev/null +++ b/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Perturbation Selectors_full Generators_full Psiref_threshold MRCC_Utils ZMQ diff --git a/plugins/mrcc_selected/README.rst b/plugins/mrcc_selected/README.rst new file mode 100644 index 00000000..997d005e --- /dev/null +++ b/plugins/mrcc_selected/README.rst @@ -0,0 +1,12 @@ +======= +mrcepa0 +======= + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. From 3af4913e2dbcdc71d61fd66bb2ed357a7a25ac68 Mon Sep 17 00:00:00 2001 From: Barry Moore Date: Tue, 3 Jan 2017 18:03:39 -0500 Subject: [PATCH 183/188] Minor fix to zlib download --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index 128d7126..85b2e146 100755 --- a/configure +++ b/configure @@ -102,7 +102,7 @@ curl = Info( default_path=join(QP_ROOT_BIN, "curl")) zlib = Info( - url='http://zlib.net/zlib-1.2.8.tar.gz', + url='http://www.zlib.net/zlib-1.2.10.tar.gz', description=' zlib', default_path=join(QP_ROOT_LIB, "libz.a")) From ddf798119f9b30792fb7410caf6d70fdce776d15 Mon Sep 17 00:00:00 2001 From: Barry Moore Date: Tue, 3 Jan 2017 18:47:21 -0500 Subject: [PATCH 184/188] Allow for non-default OPAMROOT locations --- configure | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/configure b/configure index 128d7126..4dc2b42d 100755 --- a/configure +++ b/configure @@ -496,15 +496,22 @@ def create_ninja_and_rc(l_installed): 'export LIBRARY_PATH="${QP_ROOT}"/lib:"${LIBRARY_PATH}"', 'export C_INCLUDE_PATH="${C_INCLUDE_PATH}":"${QP_ROOT}"/include', '', - 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', "", - 'source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true', + 'source ${QP_ROOT}/install/EZFIO/Bash/ezfio.sh', '', '# Choose the correct network interface', '# export QP_NIC=ib0', '# export QP_NIC=eth0', - "" + '' ] + if os.getenv('OPAMROOT'): + opam_root = os.getenv('OPAMROOT') + l_rc.append('export OPAMROOT={0}'.format(opam_root)) + l_rc.append('source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true') + else: + l_rc.append('source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true') + l_rc.append('') + path = join(QP_ROOT, "quantum_package.rc") with open(path, "w+") as f: f.write("\n".join(l_rc)) From 092992aa495727808a2e20004838048141365767 Mon Sep 17 00:00:00 2001 From: Barry Moore Date: Tue, 3 Jan 2017 19:39:31 -0500 Subject: [PATCH 185/188] Minimize code addition --- configure | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/configure b/configure index 4dc2b42d..fa7cc461 100755 --- a/configure +++ b/configure @@ -504,12 +504,11 @@ def create_ninja_and_rc(l_installed): '' ] - if os.getenv('OPAMROOT'): - opam_root = os.getenv('OPAMROOT') - l_rc.append('export OPAMROOT={0}'.format(opam_root)) - l_rc.append('source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true') - else: - l_rc.append('source ${HOME}/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true') + qp_opam_root = os.getenv('OPAMROOT') + if not qp_opam_root: + qp_opam_root = '${HOME}' + l_rc.append('export QP_OPAM={0}'.format(qp_opam_root)) + l_rc.append('source ${QP_OPAM}/opam-init/init.sh > /dev/null 2> /dev/null || true') l_rc.append('') path = join(QP_ROOT, "quantum_package.rc") From 66dea5e7b89acae171c713a63f7b89f14164c675 Mon Sep 17 00:00:00 2001 From: Thomas Applencourt Date: Tue, 3 Jan 2017 19:29:09 -0600 Subject: [PATCH 186/188] Corrected OPAM_PATH --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index fa7cc461..3d672ce7 100755 --- a/configure +++ b/configure @@ -506,7 +506,7 @@ def create_ninja_and_rc(l_installed): qp_opam_root = os.getenv('OPAMROOT') if not qp_opam_root: - qp_opam_root = '${HOME}' + qp_opam_root = '${HOME}/.opam' l_rc.append('export QP_OPAM={0}'.format(qp_opam_root)) l_rc.append('source ${QP_OPAM}/opam-init/init.sh > /dev/null 2> /dev/null || true') l_rc.append('') From 8832b28ac97bd588a2c8a760f9a03af45eb97bba Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 4 Jan 2017 12:21:29 +0100 Subject: [PATCH 187/188] Corrected tests --- tests/bats/mrcepa0.bats | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index dc9e0bb4..6bca8b7e 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.23752746236 1.e-4 + eq $energy -76.2385617521816 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,7 +32,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.237469267705 2.e-4 + eq $energy -76.2385052514433 2.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,7 +48,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2347764009137 2.e-4 + eq $energy -76.235786994991 2.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,6 +64,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2406942855164 2.e-4 + eq $energy -76.2417725924747 2.e-4 } From 3979677a82b1008a30938d3b61e09e9e06b22f21 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 11 Jan 2017 15:04:00 +0100 Subject: [PATCH 188/188] MRSC2 no amplitudes --- plugins/Psiref_CAS/psi_ref.irp.f | 33 +++++++ plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES | 1 + plugins/mrsc2_no_amp/README.rst | 12 +++ plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f | 78 ++++++++++++++++ plugins/mrsc2_no_amp/sc2_no_amp.irp.f | 9 ++ src/Determinants/filter_connected.irp.f | 98 ++++++++++++++++++++ 6 files changed, 231 insertions(+) create mode 100644 plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES create mode 100644 plugins/mrsc2_no_amp/README.rst create mode 100644 plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f create mode 100644 plugins/mrsc2_no_amp/sc2_no_amp.irp.f diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index d3b6c28f..ab9e6943 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,3 +67,36 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] +&BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] + implicit none + integer :: i,j + norm_psi_ref = 0.d0 + do j = 1, N_states + do i = 1, N_det_ref + norm_psi_ref(j) += psi_ref_coef(i,j) * psi_ref_coef(i,j) + enddo + inv_norm_psi_ref(j) = 1.d0/(dsqrt(norm_psi_Ref(j))) + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_ref_coef_interm_norm, (N_det_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_ref + psi_ref_coef_interm_norm(i,j) = inv_norm_psi_ref(j) * psi_ref_coef(i,j) + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_non_ref_coef_interm_norm, (N_det_non_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_non_ref + psi_non_ref_coef_interm_norm(i,j) = psi_non_ref_coef(i,j) * inv_norm_psi_ref(j) + enddo + enddo + END_PROVIDER diff --git a/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES b/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..f04fe3b0 --- /dev/null +++ b/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Psiref_CAS Determinants Davidson diff --git a/plugins/mrsc2_no_amp/README.rst b/plugins/mrsc2_no_amp/README.rst new file mode 100644 index 00000000..b24848f7 --- /dev/null +++ b/plugins/mrsc2_no_amp/README.rst @@ -0,0 +1,12 @@ +============ +mrsc2_no_amp +============ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f b/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f new file mode 100644 index 00000000..b8b021e8 --- /dev/null +++ b/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f @@ -0,0 +1,78 @@ + BEGIN_PROVIDER [double precision, CI_eigenvectors_sc2_no_amp, (N_det,N_states_diag)] +&BEGIN_PROVIDER [double precision, CI_eigenvectors_s2_sc2_no_amp, (N_states_diag)] +&BEGIN_PROVIDER [double precision, CI_electronic_energy_sc2_no_amp, (N_states_diag)] + implicit none + integer :: i,j,k,l + integer, allocatable :: idx(:) + double precision, allocatable :: e_corr(:,:) + double precision, allocatable :: accu(:) + double precision, allocatable :: ihpsi_current(:) + double precision, allocatable :: H_jj(:),H_jj_total(:),S2_jj(:) + allocate(e_corr(N_det_non_ref,N_states),ihpsi_current(N_states),accu(N_states),H_jj(N_det_non_ref),idx(0:N_det_non_ref)) + allocate(H_jj_total(N_det),S2_jj(N_det)) + accu = 0.d0 + do i = 1, N_det_non_ref + call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef_interm_norm, N_int, N_det_ref,& + size(psi_ref_coef_interm_norm,1), N_states,ihpsi_current) + do j = 1, N_states + e_corr(i,j) = psi_non_ref_coef_interm_norm(i,j) * ihpsi_current(j) + accu(j) += e_corr(i,j) + enddo + enddo + double precision :: hjj,diag_h_mat_elem + do i = 1, N_det_non_ref + call filter_not_connected(psi_non_ref,psi_non_ref(1,1,i),N_int,N_det_non_ref,idx) + H_jj(i) = 0.d0 + do j = 1, idx(0) + H_jj(i) += e_corr(idx(j),1) + enddo + enddo + do i=1,N_Det + H_jj_total(i) = diag_h_mat_elem(psi_det(1,1,i),N_int) + call get_s2(psi_det(1,1,i),psi_det(1,1,i),N_int,S2_jj(i)) + enddo + do i=1, N_det_non_ref + H_jj_total(idx_non_ref(i)) += H_jj(i) + enddo + + + call davidson_diag_hjj_sjj(psi_det,CI_eigenvectors_sc2_no_amp,H_jj_total,S2_jj,CI_electronic_energy_sc2_no_amp,size(CI_eigenvectors_sc2_no_amp,1),N_Det,N_states,N_states_diag,N_int,6) + do i=1,N_states_diag + CI_eigenvectors_s2_sc2_no_amp(i) = S2_jj(i) + enddo + + deallocate(e_corr,ihpsi_current,accu,H_jj,idx,H_jj_total,s2_jj) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, CI_energy_sc2_no_amp, (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,min(N_det,N_states_diag) + CI_energy_sc2_no_amp(j) = CI_electronic_energy_sc2_no_amp(j) + nuclear_repulsion + enddo + do j=1,min(N_det,N_states) + write(st,'(I4)') j + call write_double(output_determinants,CI_energy_sc2_no_amp(j),'Energy of state '//trim(st)) + call write_double(output_determinants,CI_eigenvectors_s2_sc2_no_amp(j),'S^2 of state '//trim(st)) + enddo + +END_PROVIDER + +subroutine diagonalize_CI_sc2_no_amp + implicit none + integer :: i,j + do j=1,N_states + do i=1,N_det + psi_coef(i,j) = CI_eigenvectors_sc2_no_amp(i,j) + enddo + enddo + SOFT_TOUCH ci_eigenvectors_s2_sc2_no_amp ci_eigenvectors_sc2_no_amp ci_electronic_energy_sc2_no_amp ci_energy_sc2_no_amp psi_coef + +end + diff --git a/plugins/mrsc2_no_amp/sc2_no_amp.irp.f b/plugins/mrsc2_no_amp/sc2_no_amp.irp.f new file mode 100644 index 00000000..622d7236 --- /dev/null +++ b/plugins/mrsc2_no_amp/sc2_no_amp.irp.f @@ -0,0 +1,9 @@ +program pouet + implicit none + integer :: i + do i = 1, 10 + call diagonalize_CI_sc2_no_amp + TOUCH psi_coef + enddo + +end diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index da333b1e..b76540f7 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -1,4 +1,102 @@ +subroutine filter_not_connected(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the array idx which contains the index of the + ! + ! determinants in the array key1 that DO NOT interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that DO NOT interact with key1 + 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) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & + + popcnt( xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 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 (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do j=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& + popcnt(xor( key1(j,2,i), key2(j,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + endif + enddo + if (degree_x2 <= 5) then + exit + endif + enddo + + endif + idx(0) = l-1 +end + + subroutine filter_connected(key1,key2,Nint,sze,idx) use bitmasks implicit none