diff --git a/config/ifort.cfg b/config/ifort.cfg index 4b1429b8..843e887b 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -38,7 +38,7 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g ################# # [PROFILE] -FC : -p -g -traceback +FC : -p -g FCFLAGS : -xSSE4.2 -O2 -ip -ftz # Debugging flags @@ -53,7 +53,6 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz [DEBUG] FC : -g -traceback FCFLAGS : -xSSE2 -C -fpe0 -IRPF90_FLAGS : --openmp # 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/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..6071a18b --- /dev/null +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -0,0 +1,165 @@ +BEGIN_PROVIDER [integer, n_points_angular_grid] + implicit none + n_points_angular_grid = 50 +END_PROVIDER + +BEGIN_PROVIDER [integer, n_points_radial_grid] + implicit none + n_points_radial_grid = 10000 +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) +! 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 + +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 + +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 + 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-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 + 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, (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 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) + ! run over all points in space + do j = 1, nucl_num ! that are referred to each 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) + r(3) = grid_points_per_atom(3,l,k,j) + accu = 0.d0 + 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 + weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu +! print*,weight_functions_at_grid_points(l,k,j) + 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),mos_array(mo_tot_num) + do j = 1, nucl_num + 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 + 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 + +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..43eb1ab8 --- /dev/null +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -0,0 +1,54 @@ +double precision function step_function_becke(x) + implicit none + double precision, intent(in) :: x + double precision :: f_function_becke + integer :: i,n_max_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) + 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 + diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f new file mode 100644 index 00000000..4943783b --- /dev/null +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -0,0 +1,109 @@ + 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 + 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 + + ! 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-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 + 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 + +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) + 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 = 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/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/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/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 new file mode 100644 index 00000000..b9378575 --- /dev/null +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -0,0 +1,889 @@ +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 + 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 + return + 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_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 + 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 + 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 + 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 + H_matrix = 0.d0 + 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 :: extra_diag_H_elements(dim_in) + double precision, intent(in) :: convergence + integer :: i,j,iter + DIAG_H_ELEMENTS = 0.d0 + do iter = 1, 1 +! 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 + do i=1,sze + H_matrix_tmp(i,j) = H_matrix_all_dets(i,j) + enddo + enddo + 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) + 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 + 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/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 0594e56e..65d81e07 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 =',psi_energy(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/corr_energy_2h2p.irp.f b/plugins/FOBOCI/corr_energy_2h2p.irp.f index ada46bf2..40bfa5aa 100644 --- a/plugins/FOBOCI/corr_energy_2h2p.irp.f +++ b/plugins/FOBOCI/corr_energy_2h2p.irp.f @@ -15,7 +15,7 @@ integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -46,7 +46,7 @@ if(i_ok .ne.1)cycle delta_e = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = hij*hij/delta_e total_corr_e_2h2p += contrib ! Single orbital contribution @@ -81,8 +81,8 @@ k_part = list_virt(k) do l = k+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -114,8 +114,8 @@ k_part = list_virt(k) do l = k+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -161,7 +161,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -191,7 +191,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_2h1p += contrib corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib @@ -211,8 +211,8 @@ END_PROVIDER k_part = list_act(k) do l = 1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -241,8 +241,8 @@ END_PROVIDER k_part = list_act(k) do l = 1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok) @@ -276,7 +276,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -302,7 +302,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_1h2p += contrib @@ -324,8 +324,8 @@ END_PROVIDER k_part = list_act(k) do l = i+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 1 @@ -356,8 +356,8 @@ END_PROVIDER k_part = list_act(k) do l = i+1,n_virt_orb l_part = list_virt(l) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) - exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) + exc = get_mo_bielec_integral(i_hole,j_hole,l_part,k_part,mo_integrals_map) key_tmp = ref_bitmask ispin = 2 @@ -388,7 +388,7 @@ END_PROVIDER integer(bit_kind) :: key_tmp(N_int,2) integer :: i,j,k,l integer :: i_hole,j_hole,k_part,l_part - double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib + double precision :: get_mo_bielec_integral,hij,delta_e,exc,contrib double precision :: diag_H_mat_elem integer :: i_ok,ispin ! Alpha - Beta correlation energy @@ -412,7 +412,7 @@ END_PROVIDER if(i_ok .ne.1)cycle delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int)) - hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map) + hij = get_mo_bielec_integral(i_hole,j_hole,k_part,l_part,mo_integrals_map) contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij)) total_corr_e_1h1p_spin_flip += contrib 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/diag_fock_inactiv_virt.irp.f b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f index 83955e61..40d75fc4 100644 --- a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f +++ b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f @@ -38,7 +38,7 @@ end subroutine diag_inactive_virt_new_and_update_mos implicit none integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act - double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz + double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral character*(64) :: label tmp = 0.d0 do i = 1, mo_tot_num @@ -52,8 +52,8 @@ subroutine diag_inactive_virt_new_and_update_mos accu =0.d0 do k = 1, n_act_orb k_act = list_act(k) - accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map) - accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map) + accu += get_mo_bielec_integral(i_inact,k_act,j_inact,k_act,mo_integrals_map) + accu -= get_mo_bielec_integral(i_inact,k_act,k_act,j_inact,mo_integrals_map) enddo tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu @@ -67,7 +67,7 @@ subroutine diag_inactive_virt_new_and_update_mos accu =0.d0 do k = 1, n_act_orb k_act = list_act(k) - accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map) + accu += get_mo_bielec_integral(i_virt,k_act,j_virt,k_act,mo_integrals_map) enddo tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index a18f8fe5..dd1ed221 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 @@ -89,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) +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 + 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 @@ -111,9 +95,20 @@ 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) - 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 @@ -122,11 +117,19 @@ subroutine is_a_good_candidate(threshold,is_ok,verbose) 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) @@ -135,14 +138,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,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 + 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) @@ -151,6 +154,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 +195,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 @@ -278,9 +283,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 @@ -321,10 +328,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 - psi_energy(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 dc6519b8..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)) @@ -38,6 +39,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. @@ -45,87 +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) + 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 -! 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) @@ -136,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) @@ -145,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 @@ -159,10 +121,10 @@ subroutine FOBOCI_lmct_mlct_old_thr 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_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 @@ -178,24 +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) + 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)cycle - 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 + 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 - ! 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 -! if(dressing_2h2p)then -! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct) -! endif + 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 @@ -203,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 @@ -230,7 +200,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)) @@ -270,7 +240,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 @@ -304,7 +274,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)) @@ -342,7 +312,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 @@ -365,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 deleted file mode 100644 index bad073db..00000000 --- a/plugins/FOBOCI/hcc_1h1p.irp.f +++ /dev/null @@ -1,82 +0,0 @@ -program test_sc2 - implicit none - read_wf = .True. - touch read_wf - call routine - - -end - -subroutine routine - implicit none - double precision, allocatable :: energies(:),diag_H_elements(:) - double precision, allocatable :: H_matrix(:,:) - allocate(energies(N_states),diag_H_elements(N_det)) - call diagonalize_CI - call test_hcc - call test_mulliken - allocate(H_matrix(N_det,N_det)) - stop 'SC2_1h1p_full is not in the git!' -! 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) -! do i = 1, N_det -! psi_coef(i,1) *= coef_hf -! enddo - touch psi_coef - call pouet -end - -subroutine pouet - implicit none - double precision :: accu,coef_hf -! 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 - -end - -subroutine test_hcc - implicit none - double precision :: accu - 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) - enddo - -end - -subroutine test_mulliken - double precision :: accu - integer :: i - integer :: j - accu= 0.d0 - do i = 1, nucl_num - print*,i,nucl_charge(i),mulliken_spin_densities(i) - accu += mulliken_spin_densities(i) - enddo - print*,'Sum of Mulliken SD = ',accu -!print*,'AO SPIN POPULATIONS' - accu = 0.d0 -!do i = 1, ao_num -! accu += spin_gross_orbital_product(i) -! write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) -!enddo -!print*,'sum = ',accu -!accu = 0.d0 -!print*,'Angular momentum analysis' -!do i = 0, ao_l_max -! accu += spin_population_angular_momentum(i) -! print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i) -!print*,'sum = ',accu -!enddo - -end - diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 6fc60fae..7d194a54 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -212,12 +212,50 @@ 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 +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) @@ -588,14 +630,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/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/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index d870e4b0..79599065 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -7,16 +7,17 @@ s.set_selection_pt2("epstein_nesbet_2x2") #s.unset_openmp() print s -#s = H_apply("FCI_PT2") -#s.set_perturbation("epstein_nesbet_2x2") -#s.unset_openmp() -#print s - -s = H_apply_zmq("FCI_PT2") +s = H_apply("FCI_PT2") s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s +s = H_apply("FCI_PT2_new") +s.set_perturbation("decontracted") +s.unset_openmp() +print s + + s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index 42e773eb..a53064b4 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -92,8 +92,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 82cc9b79..078334f7 100644 --- a/plugins/Full_CI/full_ci_no_skip.irp.f +++ b/plugins/Full_CI/full_ci_no_skip.irp.f @@ -73,9 +73,11 @@ 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' - 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/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg new file mode 100644 index 00000000..2fcc26ad --- /dev/null +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -0,0 +1,7 @@ +[do_third_order_1h1p] +type: logical +doc: If true, compute the third order contribution for the 1h1p +interface: ezfio,provider,ocaml +default: True + + diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f new file mode 100644 index 00000000..6f17ab05 --- /dev/null +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -0,0 +1,187 @@ +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 + +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 new file mode 100644 index 00000000..13c8228a --- /dev/null +++ b/plugins/MRPT_Utils/MRPT_Utils.main.irp.f @@ -0,0 +1,43 @@ +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 fock_virt_total_spin_trace + provide delta_ij + + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + print *, 'PT2 = ', 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) + +end + +subroutine routine_2 + implicit none + integer :: i + do i = 1, n_core_inact_orb + 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,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 + diff --git a/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..a613d5f2 --- /dev/null +++ b/plugins/MRPT_Utils/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Selectors_full Generators_full Davidson diff --git a/plugins/MRPT_Utils/README.rst b/plugins/MRPT_Utils/README.rst new file mode 100644 index 00000000..6b7a8eff --- /dev/null +++ b/plugins/MRPT_Utils/README.rst @@ -0,0 +1,13 @@ +========== +MRPT_Utils +========== + +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_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f new file mode 100644 index 00000000..ac399ce7 --- /dev/null +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -0,0 +1,1114 @@ +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) + print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) + enddo +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), 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 + integer :: state_target + double precision :: energies(n_states_diag) + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, one_anhil, (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), 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 + double precision :: energies(n_states_diag) + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states)] + 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), 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) + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states)] + 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), 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 + 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,2,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_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + enddo + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +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 + 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), 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) + 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,2,i) = psi_active(j,2,i) + 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) + 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 + enddo + enddo + enddo + +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 + 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), 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 + integer :: state_target + 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,2,i) = psi_active(j,2,i) + 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_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 + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +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 + 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), 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 + integer :: state_target + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +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 + 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), 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 + integer :: state_target + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +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 + 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), 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 + integer :: state_target + 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,2,i) = psi_active(j,2,i) + enddo + enddo + 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 + 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 new file mode 100644 index 00000000..10cfe7c0 --- /dev/null +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -0,0 +1,708 @@ +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) + 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 + 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 + 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 + 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 + 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 + 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 + + 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 + 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 + 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) + + 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 + + ! 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) + 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 + + + ! 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) + alpha_beta += 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) + core_act += 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) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) + enddo + enddo +! 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 + +! 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 + + 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 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 + 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( & + 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( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) - & + 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( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) - & + get_mo_bielec_integral( & + 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(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(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(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(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) + accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij + enddo + enddo + 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 + 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( & + 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( & + 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( & + 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(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(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(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(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/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f new file mode 100644 index 00000000..d4ce0661 --- /dev/null +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -0,0 +1,210 @@ + 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 + 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 + enddo + END_PROVIDER + + 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 + implicit none + integer :: i,j,k + double precision :: accu_coulomb,accu_exchange(2) + double precision :: na,nb,ntot + double precision :: coulomb, exchange + double precision :: get_mo_bielec_integral + integer :: j_act_orb,k_act_orb,i_inact_core_orb + integer :: i_state + + 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 = 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(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 + 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 + enddo + END_PROVIDER + + 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 + implicit none + integer :: i,j,k + double precision :: accu_coulomb,accu_exchange(2) + double precision :: na,nb,ntot + double precision :: coulomb, exchange + 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 + + 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 = 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(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 + 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 + enddo + END_PROVIDER + + 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 + 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,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 + 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 + + + + + + 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,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 + 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(iorb,jorb) = accu + enddo + enddo + + END_PROVIDER + + + + diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f new file mode 100644 index 00000000..275af0e4 --- /dev/null +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -0,0 +1,186 @@ +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_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,hij + integer :: i_state, i_alpha + + integer(bit_kind),allocatable :: miniList(:,:,:) + integer,allocatable :: idx_miniList(:) + 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) + 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 + +! 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 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 + 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) + 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) +! 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) + 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..80739aa2 --- /dev/null +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -0,0 +1,369 @@ + + 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 + integer :: i_state + double precision :: accu(N_states) + 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_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_1h(i_state) = accu(i_state) + enddo + print*, '1h = ',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(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 + + ! 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 + 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 = ',accu + + ! 1h1p third order + 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 + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p(3)',accu + endif + + ! 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(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 + + ! 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(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 + + ! 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 + 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_1h2p(i_state) = accu(i_state) + enddo + print*, '1h2p = ',accu + + ! 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 + 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_2h1p(i_state) = accu(i_state) + enddo + print*, '2h1p = ',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(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 + delta_ij(i,i,i_state) += contrib_2h2p(i_state) + enddo + second_order_pt_new_2h2p(i_state) = contrib_2h2p(i_state) + enddo + print*, '2h2p = ',contrib_2h2p(1) + + + ! total + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det +! 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 + second_order_pt_new(i_state) = accu(i_state) + print*, 'total= ',accu(i_state) + enddo + + + + +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/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f new file mode 100644 index 00000000..fa5812e1 --- /dev/null +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -0,0 +1,958 @@ +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 + 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(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) + 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),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) + 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 + + +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 + 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(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) + 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 + + +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 + 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(iorb,aorb,rorb,borb,mo_integrals_map) & + + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) + else + hij = get_mo_bielec_integral(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 + 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 + 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 + 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/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f new file mode 100644 index 00000000..4c12dbe1 --- /dev/null +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -0,0 +1,796 @@ +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 + 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 + 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(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 + 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 + + 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) +! 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) + 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 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 + 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 + endif + 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 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 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 | 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 + + 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,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 + 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 + 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 + + 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(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 + 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 +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + integer :: i_hole,i_part + double precision :: hij_test + 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 + 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 + 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 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 > + + 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 + 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 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 + ! < 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_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,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 + ! < 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_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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! 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 !! en of test if jdet is a single or a double excitation of type K_ab + + 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 > + 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 !! jdet + + + enddo + enddo + enddo + enddo + + + + + +end + diff --git a/plugins/MRPT_Utils/print_1h2p.irp.f b/plugins/MRPT_Utils/print_1h2p.irp.f new file mode 100644 index 00000000..d10e1fb5 --- /dev/null +++ b/plugins/MRPT_Utils/print_1h2p.irp.f @@ -0,0 +1,51 @@ +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 + if(.False.)then + call give_1h2p_contrib(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*, '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 + endif + print*, 'third order ', accu + + deallocate (matrix_1h2p) +end 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..f08af1d5 --- /dev/null +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -0,0 +1,484 @@ + + 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 + 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 + 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),det_tmp_1(i,1)) + particles(i,2) = iand(virt_bitmask(i,2),det_tmp_1(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,coef_array,hij,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(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 + + integer :: n_holes_spin(2) + integer :: n_holes + integer :: holes_list(N_int*bit_kind_size,2) + + + 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) + 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) + 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(N_states) + 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) + 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) + do i_state = 1, N_states + delta_e_virt += fock_virt_total_spin_trace(i_part_virt,i_state) + enddo + 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(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) + 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 + 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 + 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 + 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) + ! first particle + jspin = 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_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) +! 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) + 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) +! 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) + 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) +! 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) + 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) +! 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) + + 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) +! 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) + 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) +! 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) + + 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 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 +! 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' +!print*, one_anhil_spin_trace(1), one_anhil_spin_trace(2) + + + 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/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f new file mode 100644 index 00000000..ba3b421b --- /dev/null +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -0,0 +1,757 @@ + +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) + 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 + 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) + 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_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(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 + 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 + 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 + 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(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 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 + 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 + 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 +! 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 + + ! | 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 + !!!! SECOND ORDER CONTRIBTIONS + ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,jspin} a_{corb,jspin} a_{iorb,ispin} | Idet > + do jspin = 1, 2 + 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(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 + 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 + + 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 + endif + enddo + + + + enddo ! ispin + do istate = 1, N_states + 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(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) + 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(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) + 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(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) + 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(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) + 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 + ! + ! | 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 + +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 + 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(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 + 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 + 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 .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 + 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 + 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 .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 + 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 + 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) + 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 + enddo + enddo + enddo + do istate =1, N_states + matrix_2h1p(idet,idet,istate) += accu_contrib(istate) + enddo + + endif + + enddo + enddo + enddo + enddo + enddo + + + + + +end + + 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..11ae18da --- /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 + 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(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 + 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/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/plugins/Perturbation/EZFIO.cfg b/plugins/Perturbation/EZFIO.cfg index ad26cfe5..9023accf 100644 --- a/plugins/Perturbation/EZFIO.cfg +++ b/plugins/Perturbation/EZFIO.cfg @@ -16,4 +16,5 @@ 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/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index eba3650e..25b89c5f 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Properties Hartree_Fock Davidson +Determinants Properties Hartree_Fock Davidson MRPT_Utils diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 66083f6f..b29e130f 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -45,6 +45,37 @@ 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) + H_pert_diag = 0.d0 + + + 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 @@ -67,8 +98,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) 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_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 @@ -85,6 +116,75 @@ 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 + + + +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 psi_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 - psi_energy(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 @@ -94,6 +194,8 @@ subroutine pt2_epstein_nesbet_2x2 ($arguments) end + + subroutine pt2_moller_plesset ($arguments) use bitmasks implicit none @@ -144,6 +246,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/Perturbation/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f new file mode 100644 index 00000000..efe7f375 --- /dev/null +++ b/plugins/Perturbation/pt2_new.irp.f @@ -0,0 +1,67 @@ +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 + 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 + diff --git a/plugins/Properties/EZFIO.cfg b/plugins/Properties/EZFIO.cfg index 02f42ad8..2a5ae803 100644 --- a/plugins/Properties/EZFIO.cfg +++ b/plugins/Properties/EZFIO.cfg @@ -2,4 +2,11 @@ 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/NEEDED_CHILDREN_MODULES b/plugins/Properties/NEEDED_CHILDREN_MODULES index aae89501..34de8ddb 100644 --- a/plugins/Properties/NEEDED_CHILDREN_MODULES +++ b/plugins/Properties/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants +Determinants Davidson 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/give_mos_at_r.irp.f b/plugins/Properties/give_mos_at_r.irp.f new file mode 100644 index 00000000..20a7f712 --- /dev/null +++ b/plugins/Properties/give_mos_at_r.irp.f @@ -0,0 +1,35 @@ +subroutine give_all_act_mos_at_r(r,mos_array) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_array(n_act_orb) + double precision :: aos_array(ao_num),accu + integer :: i,j,iorb +!print*,'n_act_orb = ',n_act_orb + call give_all_aos_at_r(r,aos_array) + do i = 1, n_act_orb + iorb = list_act(i) + accu = 0.d0 + do j = 1, ao_num + accu += mo_coef(j,iorb) * aos_array(j) + enddo + mos_array(i) = accu + enddo +end + +subroutine give_all_core_mos_at_r(r,mos_array) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: mos_array(n_core_orb) + double precision :: aos_array(ao_num),accu + integer :: i,j,iorb + call give_all_aos_at_r(r,aos_array) + do i = 1, n_core_orb + iorb = list_core(i) + accu = 0.d0 + do j = 1, ao_num + accu += mo_coef(j,iorb) * aos_array(j) + enddo + mos_array(i) = accu + enddo +end + diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index e31b3ba4..6fa39278 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 @@ -116,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 @@ -141,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/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/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..b9cbe4e8 --- /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(1) = 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(1) += delta_z + write(33,'(100(f16.10,X))')r(1),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 new file mode 100644 index 00000000..ec203026 --- /dev/null +++ b/plugins/Properties/test_two_body_dm.irp.f @@ -0,0 +1,105 @@ +program test_two_bod + implicit none + read_wf = .True. + touch read_wf + call routine +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 + accu = 0.d0 + + ! 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 + 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 + h1 = list_act(i) + accu_extra_diag += two_body_dm_ab_big_array_act(i,j,k,l) * get_mo_bielec_integral(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(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) + 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 u_0_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) + 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*,' threshold_selectors) then - N_det_selectors = i-1 + N_det_selectors = i exit endif enddo 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/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 52e0ef28..2d47c633 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) = 2 ! number of orbitals to be localized integer :: index_rot(1000,1) @@ -101,261 +101,73 @@ cmoref = 0.d0 irot = 0 -! H2 molecule for the mixed localization - do i=1,64 - irot(i,1) = i+2 - enddo + irot(1,1) = 11 + irot(2,1) = 12 + cmoref(15,1,1) = 1.d0 ! + cmoref(14,2,1) = 1.d0 ! - 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/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/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index bd66611b..cfb1d6bf 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 @@ -198,14 +206,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 """ @@ -224,7 +273,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/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 8d420b15..0938d3bd 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) ] @@ -145,6 +145,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 @@ -152,6 +153,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 @@ -179,20 +181,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/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 4984d9a8..87a02d10 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -1,107 +1,113 @@ +use bitmasks integer function number_of_holes(key_in) - ! 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 number_of_holes = 0 + 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) + 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 @@ -204,11 +210,13 @@ integer function number_of_particles(key_in) end logical function is_a_two_holes_two_particles(key_in) + 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 @@ -221,163 +229,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 +393,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,7 +406,9 @@ logical function is_a_two_holes_two_particles(key_in) integer function number_of_holes_verbose(key_in) + 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 @@ -410,23 +420,25 @@ 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 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 @@ -473,6 +485,17 @@ logical function is_a_1h2p(key_in) end +logical function is_a_2h1p(key_in) + 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) implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) @@ -506,3 +529,34 @@ logical function is_a_2p(key_in) end +logical function is_a_2h(key_in) + 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 + +logical function is_i_in_virtual(i) + 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 7bb6e16e..964c4ed8 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,25 +413,58 @@ 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 + + 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 inactive, active and virtual bitmasks + ! 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)) @@ -407,6 +472,36 @@ END_PROVIDER 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 + + BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] @@ -423,6 +518,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 @@ -431,10 +527,13 @@ 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 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 +543,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 @@ -458,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 @@ -497,11 +598,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 +616,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 +645,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/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index 085a35b7..9bbd00f5 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -324,8 +324,17 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia double precision :: cpu, wall include 'constants.include.F' + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, R, y, h, lambda + if(store_full_H_mat) then + stop 'TODO : put S^2 in stor_full_H_mat' + endif + + if(store_full_H_mat.and.sze.le.n_det_max_stored)then + provide H_matrix_all_dets + endif + PROVIDE nuclear_repulsion call write_time(iunit) @@ -418,6 +427,13 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia ! ----------------------------------------- call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8) +! do k=1,N_st +! 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 ! Compute h_kl = = diff --git a/src/Davidson/diagonalize_CI_mono.irp.f b/src/Davidson/diagonalize_CI_mono.irp.f deleted file mode 100644 index 1de9a211..00000000 --- a/src/Davidson/diagonalize_CI_mono.irp.f +++ /dev/null @@ -1,86 +0,0 @@ - BEGIN_PROVIDER [ double precision, CI_electronic_energy_mono, (N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_mono, (N_det,N_states_diag) ] -&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2_mono, (N_states_diag) ] - implicit none - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - integer :: i,j - - do j=1,N_states_diag - do i=1,N_det - CI_eigenvectors_mono(i,j) = psi_coef(i,j) - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors_mono,CI_electronic_energy, & - size(CI_eigenvectors_mono,1),N_det,N_states,N_states_diag,N_int,output_determinants) - - else if (diag_algorithm == "Lapack") then - - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - 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_mono(:) = 0.d0 - do i=1,N_det - CI_eigenvectors_mono(i,1) = eigenvectors(i,1) - enddo - integer :: i_state - double precision :: s2 - i_state = 0 - if (s2_eig) then - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,s2,N_det) - if(dabs(s2-expected_s2).le.0.3d0)then - print*,'j = ',j - print*,'e = ',eigenvalues(j) - print*,'c = ',dabs(eigenvectors(1,j)) - if(dabs(eigenvectors(1,j)).gt.0.9d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_mono(i_state) = eigenvalues(j) - CI_eigenvectors_s2_mono(i_state) = s2 - endif - endif - if (i_state.ge.N_states_diag) then - exit - endif - enddo - else - do j=1,N_states_diag - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,s2,N_det) - if(dabs(eigenvectors(1,j)).gt.0.9d0)then - i_state += 1 - do i=1,N_det - CI_eigenvectors_mono(i,i_state) = eigenvectors(i,j) - enddo - CI_electronic_energy_mono(i_state) = eigenvalues(j) - CI_eigenvectors_s2_mono(i_state) = s2 - endif - enddo - endif - deallocate(eigenvectors,eigenvalues) - endif - -END_PROVIDER - -subroutine diagonalize_CI_mono - implicit none - BEGIN_DOC -! Replace the coefficients of the CI states by the coefficients of the -! eigenstates of the CI matrix - END_DOC - integer :: i,j - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_mono(i,j) - enddo - enddo - SOFT_TOUCH psi_coef CI_electronic_energy_mono CI_eigenvectors_mono CI_eigenvectors_s2_mono -end diff --git a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f new file mode 100644 index 00000000..3bdc37c5 --- /dev/null +++ b/src/Davidson/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/Davidson/diagonalize_restart_and_save_lowest_state.irp.f b/src/Davidson/diagonalize_restart_and_save_lowest_state.irp.f new file mode 100644 index 00000000..11c98034 --- /dev/null +++ b/src/Davidson/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/Davidson/diagonalize_restart_and_save_one_state.irp.f b/src/Davidson/diagonalize_restart_and_save_one_state.irp.f new file mode 100644 index 00000000..c5f4e59d --- /dev/null +++ b/src/Davidson/diagonalize_restart_and_save_one_state.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/Davidson/print_H_matrix_restart.irp.f b/src/Davidson/print_H_matrix_restart.irp.f new file mode 100644 index 00000000..57fc3633 --- /dev/null +++ b/src/Davidson/print_H_matrix_restart.irp.f @@ -0,0 +1,176 @@ +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),s2_eigvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + print*,'Two first eigenvectors ' + call u_0_S2_u_0(s2_eigvalues,eigenvectors,n_det,keys_tmp,N_int,N_det,size(eigenvectors,1)) + do j =1, N_states + print*,'s2 = ',s2_eigvalues(j) + 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,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(h1,h2,p2,p1,mo_integrals_map) + h2 = 15 + p2 = 15 + k_b_iv = get_mo_bielec_integral(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(h1,h2,p1,p2,mo_integrals_map) + h1 = 16 + p1 = 15 + h2 = 15 + p2 = 16 + k_bv = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) + + h1 = 10 + p1 = 14 + h2 = 14 + p2 = 10 + k_ai = get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) + + h1 = 10 + p1 = 15 + h2 = 15 + p2 = 10 + k_bi = get_mo_bielec_integral(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(h1,h2,p1,p2,mo_integrals_map) + print*,'k_iv = ',k_iv +end diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 41e05bda..0676649e 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -106,3 +106,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 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 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/H_apply.irp.f b/src/Determinants/H_apply.irp.f index b047efdc..20eb3e83 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -214,13 +214,8 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) duplicate(i) = .False. enddo - found_duplicates = .False. - i=0 - j=0 - do while (i virt mono excitations + do i0 = 1, n_occ_ab(1) + i=occ(i0,1) + do j0 = 1, n_occ_ab_virt(1) + j = occ_virt(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + double precision :: accu + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu + mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu + mo_mono_elec_integral(i,j) + enddo + enddo + + ! virt ---> virt mono excitations + do i0 = 1, n_occ_ab_virt(1) + i=occ_virt(i0,1) + do j0 = 1, n_occ_ab_virt(1) + j = occ_virt(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j) + enddo + enddo + + ! docc ---> docc mono excitations + do i0 = 1, n_occ_ab(1) + i=occ(i0,1) + do j0 = 1, n_occ_ab(1) + j = occ(j0,1) + call get_mo_bielec_integrals_coulomb_ii(i,j,mo_tot_num,array_coulomb,mo_integrals_map) + call get_mo_bielec_integrals_exch_ii(i,j,mo_tot_num,array_exchange,mo_integrals_map) + accu = 0.d0 + do k0 = 1, n_occ_ab(1) + k = occ(k0,1) + accu += 2.d0 * array_coulomb(k) - array_exchange(k) + enddo + fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_mono_elec_integral(i,j) + fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_mono_elec_integral(i,j) + enddo + enddo + +END_PROVIDER + +subroutine get_mono_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij) + use bitmasks + implicit none + integer,intent(in) :: h,p,spin + double precision, intent(in) :: phase + integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2) + double precision, intent(out) :: hij + integer(bit_kind) :: differences(N_int,2) + integer(bit_kind) :: hole(N_int,2) + integer(bit_kind) :: partcl(N_int,2) + integer :: occ_hole(N_int*bit_kind_size,2) + integer :: occ_partcl(N_int*bit_kind_size,2) + integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2) + integer :: i0,i + do i = 1, N_int + differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask(i,1)) + differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask(i,2)) + hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1)) + hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2)) + partcl(i,1) = iand(differences(i,1),det_1(i,1)) + partcl(i,2) = iand(differences(i,2),det_1(i,2)) + enddo + call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int) + call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int) + hij = fock_operator_closed_shell_ref_bitmask(h,p) + ! holes :: direct terms + do i0 = 1, n_occ_ab_hole(1) + i = occ_hole(i0,1) + hij -= big_array_coulomb_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + do i0 = 1, n_occ_ab_hole(2) + i = occ_hole(i0,2) + hij -= big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + + ! holes :: exchange terms + do i0 = 1, n_occ_ab_hole(spin) + i = occ_hole(i0,spin) + hij += big_array_exchange_integrals(i,h,p) ! get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map) + enddo + + ! particles :: direct terms + do i0 = 1, n_occ_ab_partcl(1) + i = occ_partcl(i0,1) + hij += big_array_coulomb_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + do i0 = 1, n_occ_ab_partcl(2) + i = occ_partcl(i0,2) + hij += big_array_coulomb_integrals(i,h,p) !get_mo_bielec_integral_schwartz(h,i,p,i,mo_integrals_map) + enddo + + ! particles :: exchange terms + do i0 = 1, n_occ_ab_partcl(spin) + i = occ_partcl(i0,spin) + hij -= big_array_exchange_integrals(i,h,p)!get_mo_bielec_integral_schwartz(h,i,i,p,mo_integrals_map) + enddo + hij = hij * phase + +end + diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index af6390e2..8e802fd6 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 determinants for S^2') 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..af109e2d --- /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 + 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(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(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/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 7df6e79e..ed299447 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -495,8 +495,6 @@ end - - subroutine i_H_j(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -527,16 +525,23 @@ 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) if (exc(0,1,1) == 1) then ! Mono alpha, mono beta - 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) + 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( & + 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( & @@ -570,27 +575,14 @@ subroutine i_H_j(key_i,key_j,Nint,hij) ! Mono alpha m = exc(1,1,1) p = exc(1,2,1) - do k = 1, elec_alpha_num - hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) - enddo - do k = 1, elec_beta_num - hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) - enddo - + spin = 1 else ! Mono beta m = exc(1,1,2) p = exc(1,2,2) - - do k = 1, elec_alpha_num - hij = hij + mo_bielec_integral_mipi(occ(k,1),m,p) - enddo - do k = 1, elec_beta_num - hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) - enddo - + spin = 2 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) @@ -617,6 +609,8 @@ 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) @@ -668,27 +662,59 @@ 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 - hij = hij + mo_bielec_integral_mipi_anti(occ(k,1),m,p) + 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 enddo do k = 1, elec_beta_num - hij = hij + mo_bielec_integral_mipi(occ(k,2),m,p) + 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)) + 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 + mo_bielec_integral_mipi(occ(k,1),m,p) + hij = hij + mipi(occ(k,1)) enddo do k = 1, elec_beta_num - hij = hij + mo_bielec_integral_mipi_anti(occ(k,2),m,p) + hij = hij + mipi(occ(k,2)) - miip(occ(k,2)) enddo endif @@ -719,6 +745,8 @@ 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) @@ -743,8 +771,11 @@ 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 hij = phase*(get_mo_bielec_integral( & exc(1,1,1), & exc(2,1,1), & @@ -755,8 +786,31 @@ 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( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) + print*,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 + print*,'phase hij = ',phase + 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( & + 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( & exc(1,1,2), & exc(2,1,2), & @@ -772,26 +826,59 @@ 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 - hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,1),m,p) + 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 enddo do k = 1, elec_beta_num - hdouble = hdouble + mo_bielec_integral_mipi(occ(k,2),m,p) + 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)) 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 - hdouble = hdouble + mo_bielec_integral_mipi(occ(k,1),m,p) + 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)) enddo do k = 1, elec_beta_num - hdouble = hdouble + mo_bielec_integral_mipi_anti(occ(k,2),m,p) + hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2)) enddo endif @@ -802,8 +889,6 @@ subroutine i_H_j_verbose(key_i,key_j,Nint,hij,hmono,hdouble) hij = diag_H_mat_elem(key_i,Nint) end select end - - subroutine create_minilist(key_mask, fullList, miniList, idx_miniList, N_fullList, N_miniList, Nint) use bitmasks implicit none @@ -1047,6 +1132,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 @@ -1195,6 +1281,433 @@ 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_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(bit_kind) :: key_tmp(Nint,2) + + 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))) + 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(popcnt(xor(key_tmp(1,1),key_tmp(1,2))) == 0)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 + + 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) + 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 .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 + 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 .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 + 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))) + 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(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 + + 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 + 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) @@ -1639,3 +2152,43 @@ subroutine get_phase(key1,key2,phase,Nint) call get_excitation(key1, key2, exc, degree, phase, Nint) 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/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 new file mode 100644 index 00000000..aa8f630b --- /dev/null +++ b/src/Determinants/two_body_dm_map.irp.f @@ -0,0 +1,619 @@ + +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 + 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) + 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) + 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 + + 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 + + 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)) + call map_unique(two_body_dm_ab_map) + + deallocate(buffer_i,buffer_value) + +end + + 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_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_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> + ! 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_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_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 + 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) + 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 +! 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> + ! 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) + 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 + 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 : + ! 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_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 : + ! 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_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 + + 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 + ! Two spin symmetry + big_array(h1,p1,h2,p2) += contrib + big_array(h2,p2,h1,p1) += contrib + ! Hermicity : hole-particle symmetry + big_array(p1,h1,p2,h2) += contrib + big_array(p2,h2,p1,h1) += contrib + + +end + +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(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib + 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 + 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_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp + enddo + enddo + enddo + enddo + +end + +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(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) + double precision :: contrib,contrib_tmp + 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 ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + 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_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/Determinants/utils.irp.f b/src/Determinants/utils.irp.f index 22faee83..dbd5a7ef 100644 --- a/src/Determinants/utils.irp.f +++ b/src/Determinants/utils.irp.f @@ -1,15 +1,17 @@ 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) 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 - do j =i,N_det + 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 +20,4 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ] !$OMP END PARALLEL DO END_PROVIDER + diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 3834b121..4e7e494f 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -5,6 +5,27 @@ interface: ezfio,provider,ocaml default: False ezfio_name: direct +[no_vvvv_integrals] +type: logical +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 + +[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 9eadbf35..d8a18437 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,6 +350,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 print*,'Reading the AO integrals' call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map) 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..41037b34 --- /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 + 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(i,j,k,l,mo_integrals_map) + big_array_coulomb_integrals(j,i,k) = integral + l = j + integral = get_mo_bielec_integral(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 b41a3177..53b45060 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -402,25 +402,6 @@ double precision function get_mo_bielec_integral(i,j,k,l,map) endif 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 - type(map_type), intent(inout) :: map - 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 - !DIR$ FORCEINLINE - get_mo_bielec_integral_schwartz = get_mo_bielec_integral(i,j,k,l,map) - else - get_mo_bielec_integral_schwartz = 0.d0 - endif -end - double precision function mo_bielec_integral(i,j,k,l) implicit none @@ -431,6 +412,7 @@ double precision function mo_bielec_integral(i,j,k,l) double precision :: get_mo_bielec_integral PROVIDE mo_bielec_integrals_in_map mo_integrals_cache !DIR$ FORCEINLINE + PROVIDE mo_bielec_integrals_in_map mo_bielec_integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) return end @@ -520,6 +502,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 e581b536..b56f3518 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -20,12 +20,15 @@ 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) BEGIN_DOC ! If True, the map of MO bielectronic integrals is provided END_DOC - + mo_bielec_integrals_in_map = .True. if (read_mo_integrals) then print*,'Reading the MO integrals' @@ -34,9 +37,138 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] return endif - call add_integrals_to_map(full_ijkl_bitmask_4) + 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,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) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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) = 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 !!!!!!!!!!!!!!!!!!!!!!! + if(.not.no_vvv_integrals)then + 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) + enddo + call add_integrals_to_map_three_indices(mask_ijk) + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 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 + ! + 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) + 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) + endif + if (write_mo_integrals) then + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") + 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 @@ -80,6 +212,50 @@ subroutine add_integrals_to_map(mask_ijkl) 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 ' @@ -88,11 +264,13 @@ subroutine add_integrals_to_map(mask_ijkl) 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) & + !$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, & @@ -110,14 +288,9 @@ subroutine add_integrals_to_map(mask_ijkl) buffer_value(size_buffer) ) thread_num = 0 -!$ thread_num = omp_get_thread_num() + !$ 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 @@ -240,9 +413,14 @@ subroutine add_integrals_to_map(mask_ijkl) exit endif bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + ! i1+=1 enddo - do i = 1, min(k,j1-i1) + do i0 = 1, n_i + i = list_ijkl(i0,1) + if(i> min(k,j1-i1+list_ijkl(1,1)-1))then + exit + endif if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then cycle endif @@ -264,7 +442,7 @@ subroutine add_integrals_to_map(mask_ijkl) 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 ', & + print*, 100.*float(l1)/float(ao_num), '% in ', & wall_2-wall_1, 's', map_mb(mo_integrals_map) ,'MB' endif endif @@ -272,14 +450,12 @@ subroutine add_integrals_to_map(mask_ijkl) !$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) @@ -296,15 +472,585 @@ subroutine add_integrals_to_map(mask_ijkl) 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), ')' - if (write_mo_integrals) then - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") +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 + integer :: m + 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(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,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 + !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)) + 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 + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + bielec_tmp_1 = 0.d0 + j0 = l0 + j = list_ijkl(j0,2) + 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 i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then !min(k,j1-i1) + exit + 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 + 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 (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 + + 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 + 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), ')' + 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 ) + 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 ) + + 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) + + !$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) & + !$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 + j = list_ijkl(j0,2) + if (j > l) then + exit + endif + j1 += 1 + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + 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 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 + 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 (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) + + 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), ')' + + +end @@ -341,7 +1087,7 @@ end !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & !$OMP iqrs, iqsr,iqri,iqis) & !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,& - !$OMP ao_integrals_threshold,do_direct_integrals) & + !$OMP ao_integrals_threshold,do_direct_integrals) & !$OMP REDUCTION(+:mo_bielec_integral_jj_from_ao,mo_bielec_integral_jj_exchange_from_ao) allocate( int_value(ao_num), int_idx(ao_num), & @@ -384,9 +1130,9 @@ end 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 @@ -439,6 +1185,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 @@ -456,55 +1351,14 @@ 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) - 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) ] - 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) = dsqrt(mo_bielec_integral_jj(k,i)) + 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 @@ -517,15 +1371,15 @@ 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 - - + + 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_bielec_integral_jj_exchange mo_bielec_integrals_in_map - + implicit none + 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 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..a5a324ed --- /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(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 +! 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/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 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/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index e44e8c2c..9c3b35b5 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -606,3 +606,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 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