diff --git a/src/README.rst b/src/README.rst index 9b987305..f4ca0e31 100644 --- a/src/README.rst +++ b/src/README.rst @@ -1,3 +1,51 @@ ========================== The core modules of the QP ========================== + +*** How are handled the DFT functionals in QP2 ? +================================================ + The Exchange and Correlation energies/potentials can be accessed by the following providers + energy_x + energy_c + potential_x_alpha_ao + potential_c_alpha_ao + potential_x_beta_ao + potential_c_beta_ao + + These providers are automatically linked to the providers of the actual exchange/correlation energies of a given functional + through the character keywords + "exchange_functional" + "correlation_functional" + + All the providers for the available functionals are in the folder "functionals", with one file "my_functional.irp.f" per functional. + + Ex : if "exchange_functional" == "sr_pbe", then energy_x will contain the exchange correlation functional defined in "functiona/sr_pbe.irp.f", which corresponds to the short-range PBE functional (at the value mu_erf for the range separation parameter) + + +*** How are handled the DFT functionals in QP2 ? +================================================ + + Creating a new functional and propagating it through the whole QP2 programs is easy as all dependencies are handled by a script. + + To do so, let us assume that the name of your functional is "my_func". + Then you just have to create the file "my_func.irp.f" in the folder "functional" which shoud contain + + +) if you're adding an exchange functional, then create the provider "energy_x_my_func" + + +) if you're adding a correlation functional, create the provider "energy_c_my_func" + + +) if you want to add the echange potentials, create the providers "potential_x_alpha_ao_my_func", "potential_x_beta_ao_my_func" which are the exchange potentials on the AO basis for the alpha/beta electrons + + +) if you want to add the correlation potentials, create the providers "potential_c_alpha_ao_my_func", "potential_c_beta_ao_my_func" which are the correlation potentials on the AO basis for the alpha/beta electrons + + That's all :) + + Then, when running whatever DFT calculation or accessing/using the providers: + energy_x + energy_c + potential_x_alpha_ao + potential_c_alpha_ao + potential_x_beta_ao + potential_c_beta_ao + + if exchange_functional = mu_func, then you will automatically have access to what you need, such as kohn sham orbital optimization and so on ... diff --git a/src/bitmask/EZFIO.cfg b/src/bitmask/EZFIO.cfg new file mode 100644 index 00000000..9d713304 --- /dev/null +++ b/src/bitmask/EZFIO.cfg @@ -0,0 +1,5 @@ +[n_act_orb] +type: integer +doc: Number of active |MOs| +interface: ezfio + diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index d30e989f..d83d69e9 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -49,9 +49,10 @@ BEGIN_PROVIDER [ integer, n_act_orb] n_act_orb += 1 endif enddo - call write_int(6,n_act_orb, 'Number of active MOs') - + if (mpi_master) then + call ezfio_set_bitmask_n_act_orb(n_act_orb) + endif END_PROVIDER BEGIN_PROVIDER [ integer, n_virt_orb ] @@ -413,3 +414,34 @@ END_PROVIDER print *, list_inact_act(1:n_inact_act_orb) END_PROVIDER + +BEGIN_PROVIDER [integer, n_all_but_del_orb] + implicit none + integer :: i + n_all_but_del_orb = 0 + do i = 1, mo_num + if( trim(mo_class(i))=="Core" & + .or. trim(mo_class(i))=="Inactive" & + .or. trim(mo_class(i))=="Active" & + .or. trim(mo_class(i))=="Virtual" )then + n_all_but_del_orb +=1 + endif + enddo +END_PROVIDER + +BEGIN_PROVIDER [integer, list_all_but_del_orb, (n_all_but_del_orb)] + implicit none + integer :: i,j + j = 0 + do i = 1, mo_num + if( trim(mo_class(i))=="Core" & + .or. trim(mo_class(i))=="Inactive" & + .or. trim(mo_class(i))=="Active" & + .or. trim(mo_class(i))=="Virtual" )then + j += 1 + list_all_but_del_orb(j) = i + endif + enddo + +END_PROVIDER + diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 3d1ff0f9..d181d732 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -49,15 +49,11 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] P0tuvx= 0.d0 do istate=1,N_states do x = 1, n_act_orb - xx = list_act(x) do v = 1, n_act_orb - vv = list_act(v) do u = 1, n_act_orb - uu = list_act(u) do t = 1, n_act_orb - tt = list_act(t) - P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x) -! P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x) + ! 1 1 2 2 1 2 1 2 + P0tuvx(t,u,v,x) = state_av_act_2_rdm_spin_trace_mo(t,v,u,x) enddo enddo enddo diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 362da85d..cfb26b59 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -24,40 +24,6 @@ subroutine print_grad enddo end -subroutine routine_bis - implicit none - integer :: i,j - double precision :: accu_d,accu_od -!accu_d = 0.d0 -!accu_od = 0.d0 -!print*,'' -!print*,'' -!print*,'' -!do i = 1, mo_num -! write(*,'(100(F8.5,X))')super_ci_dm(i,:) -! accu_d += super_ci_dm(i,i) -! do j = i+1, mo_num -! accu_od += dabs(super_ci_dm(i,j) - super_ci_dm(j,i)) -! enddo -!enddo -!print*,'' -!print*,'' -!print*,'accu_d = ',accu_d -!print*,'n_elec = ',elec_num -!print*,'accu_od= ',accu_od -!print*,'' -!accu_d = 0.d0 -!do i = 1, N_det -! accu_d += psi_coef(i,1)**2 -!enddo -!print*,'accu_d = ',accu_d -!provide superci_natorb - - provide switch_mo_coef - mo_coef = switch_mo_coef - call save_mos -end - subroutine routine integer :: i,j,k,l integer :: ii,jj,kk,ll @@ -75,30 +41,11 @@ subroutine routine do ii = 1, n_act_orb i = list_act(ii) integral = get_two_e_integral(i,j,k,l,mo_integrals_map) - accu(1) += state_av_act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral + accu(1) += state_av_act_2_rdm_spin_trace_mo(ii,jj,kk,ll) * integral enddo enddo enddo enddo print*,'accu = ',accu(1) - accu = 0.d0 - do ll = 1, n_act_orb - l = list_act(ll) - do kk = 1, n_act_orb - k = list_act(kk) - do jj = 1, n_act_orb - j = list_act(jj) - do ii = 1, n_act_orb - i = list_act(ii) - integral = get_two_e_integral(i,j,k,l,mo_integrals_map) - accu(1) += state_av_act_two_rdm_openmp_spin_trace_mo(ii,jj,kk,ll) * integral - enddo - enddo - enddo - enddo - print*,'accu = ',accu(1) - print*,'psi_energy_two_e = ',psi_energy_two_e - - print *, psi_energy_with_nucl_rep end diff --git a/src/density_for_dft/EZFIO.cfg b/src/density_for_dft/EZFIO.cfg index 42b8eab4..63d6bc08 100644 --- a/src/density_for_dft/EZFIO.cfg +++ b/src/density_for_dft/EZFIO.cfg @@ -11,10 +11,10 @@ interface: ezfio,provider,ocaml default: 0.5 [no_core_density] -type: character*(32) -doc: Type of density. If [no_core_dm] then all elements of the density matrix involving at least one orbital set as core are set to zero +type: logical +doc: If [no_core_density] then all elements of the density matrix involving at least one orbital set as core are set to zero. The default is False in order to take all the density. interface: ezfio, provider, ocaml -default: full_density +default: False [normalize_dm] type: logical diff --git a/src/density_for_dft/density_for_dft.irp.f b/src/density_for_dft/density_for_dft.irp.f index c925bdf8..ee70cd38 100644 --- a/src/density_for_dft/density_for_dft.irp.f +++ b/src/density_for_dft/density_for_dft.irp.f @@ -22,7 +22,7 @@ BEGIN_PROVIDER [double precision, one_e_dm_mo_alpha_for_dft, (mo_num,mo_num, N_s one_e_dm_mo_alpha_for_dft(:,:,1) = one_e_dm_mo_alpha_average(:,:) endif - if(no_core_density .EQ. "no_core_dm")then + if(no_core_density)then integer :: ii,i,j do ii = 1, n_core_orb i = list_core(ii) @@ -73,7 +73,7 @@ BEGIN_PROVIDER [double precision, one_e_dm_mo_beta_for_dft, (mo_num,mo_num, N_st one_e_dm_mo_beta_for_dft(:,:,1) = one_e_dm_mo_beta_average(:,:) endif - if(no_core_density .EQ. "no_core_dm")then + if(no_core_density)then integer :: ii,i,j do ii = 1, n_core_orb i = list_core(ii) diff --git a/src/dft_keywords/EZFIO.cfg b/src/dft_keywords/EZFIO.cfg index 3c3ed22a..b452c863 100644 --- a/src/dft_keywords/EZFIO.cfg +++ b/src/dft_keywords/EZFIO.cfg @@ -2,13 +2,13 @@ type: character*(32) doc: name of the exchange functional interface: ezfio, provider, ocaml -default: short_range_LDA +default: sr_pbe [correlation_functional] type: character*(32) doc: name of the correlation functional interface: ezfio, provider, ocaml -default: short_range_LDA +default: sr_pbe [HF_exchange] type: double precision diff --git a/src/dft_utils_in_r/dm_in_r.irp.f b/src/dft_utils_in_r/dm_in_r.irp.f index 18eb5403..7b0b1e0f 100644 --- a/src/dft_utils_in_r/dm_in_r.irp.f +++ b/src/dft_utils_in_r/dm_in_r.irp.f @@ -1,435 +1,103 @@ -subroutine dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - implicit none + BEGIN_PROVIDER [double precision, one_e_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, one_e_dm_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_alpha_at_r, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_beta_at_r, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, scal_prod_grad_one_e_dm_ab, (n_points_final_grid,N_states) ] +&BEGIN_PROVIDER [double precision, one_e_stuff_for_pbe, (3,n_points_final_grid,N_states) ] BEGIN_DOC -! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z -! output : dm_a = alpha density evaluated at r(3) -! output : dm_b = beta density evaluated at r(3) + ! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate) + ! + ! one_e_dm_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate) + ! + ! one_e_dm_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate) + ! + ! one_e_dm_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate) + ! + ! one_e_grad_2_dm_alpha_at_r(i,istate) = (d\dx n_alpha(r_i,istate))^2 + (d\dy n_alpha(r_i,istate))^2 + (d\dz n_alpha(r_i,istate))^2 + ! + ! scal_prod_grad_one_e_dm_ab(i,istate) = grad n_alpha(r_i) . grad n_beta(r_i) + ! + ! where r_i is the ith point of the grid and istate is the state number + ! + ! !!!!! WARNING !!!! if no_core_density = .True. then all core electrons are removed END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - integer :: istate - double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v - call give_all_aos_at_r(r,aos_array) - do istate = 1, N_states - aos_array_bis = aos_array - ! alpha density - call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - ! beta density - aos_array_bis = aos_array - call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - enddo -end - - -subroutine dm_dft_alpha_beta_and_all_aos_at_r(r,dm_a,dm_b,aos_array) - BEGIN_DOC -! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z -! output : dm_a = alpha density evaluated at r -! output : dm_b = beta density evaluated at r -! output : aos_array(i) = ao(i) evaluated at r - END_DOC - implicit none - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - double precision, intent(out) :: aos_array(ao_num) - integer :: istate - double precision :: aos_array_bis(ao_num),u_dot_v - call give_all_aos_at_r(r,aos_array) - do istate = 1, N_states - aos_array_bis = aos_array - ! alpha density - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - ! beta density - aos_array_bis = aos_array - call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - enddo -end - - - - subroutine density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array) - implicit none - BEGIN_DOC -! input: -! -! * r(1) ==> r(1) = x, r(2) = y, r(3) = z -! -! output: -! -! * dm_a = alpha density evaluated at r -! * dm_b = beta density evaluated at r -! * aos_array(i) = ao(i) evaluated at r -! * grad_dm_a(1) = X gradient of the alpha density evaluated in r -! * grad_dm_a(1) = X gradient of the beta density evaluated in r -! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r -! - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) - double precision, intent(out) :: grad_aos_array(3,ao_num) - integer :: i,j,istate - double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v - double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) - - call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array) - do i = 1, ao_num - do j = 1, 3 - aos_grad_array(i,j) = grad_aos_array(j,i) - enddo - enddo - - do istate = 1, N_states - ! alpha density - ! aos_array_bis = \rho_ao * aos_array - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - ! aos_grad_array_bis = \rho_ao * aos_grad_array - - ! beta density - call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - ! aos_grad_array_bis = \rho_ao * aos_grad_array - enddo - grad_dm_a *= 2.d0 - grad_dm_b *= 2.d0 - end - - - - subroutine density_and_grad_lapl_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, lapl_dm_a, lapl_dm_b, aos_array, grad_aos_array, lapl_aos_array) - implicit none - BEGIN_DOC -! input: -! -! * r(1) ==> r(1) = x, r(2) = y, r(3) = z -! -! output: -! -! * dm_a = alpha density evaluated at r -! * dm_b = beta density evaluated at r -! * aos_array(i) = ao(i) evaluated at r -! * grad_dm_a(1) = X gradient of the alpha density evaluated in r -! * grad_dm_a(1) = X gradient of the beta density evaluated in r -! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r -! - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) - double precision, intent(out) :: lapl_dm_a(3,N_states),lapl_dm_b(3,N_states) - double precision, intent(out) :: grad_aos_array(3,ao_num) - double precision, intent(out) :: lapl_aos_array(3,ao_num) - integer :: i,j,istate - double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v - double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) - double precision :: aos_lapl_array(ao_num,3) - - call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,grad_aos_array,lapl_aos_array) - do i = 1, ao_num - do j = 1, 3 - aos_grad_array(i,j) = grad_aos_array(j,i) - aos_lapl_array(i,j) = lapl_aos_array(j,i) - enddo - enddo - - do istate = 1, N_states - ! alpha density - ! aos_array_bis = \rho_ao * aos_array - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - - ! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i) - lapl_dm_a(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num) - lapl_dm_a(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num) - lapl_dm_a(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num) - - ! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1) - ! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i) - lapl_dm_a(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num) - lapl_dm_a(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num) - lapl_dm_a(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num) - - - ! beta density - call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - - ! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i) - lapl_dm_b(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num) - lapl_dm_b(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num) - lapl_dm_b(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num) - - ! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1) - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1) - ! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i) - lapl_dm_b(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num) - lapl_dm_b(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num) - lapl_dm_b(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num) - enddo - grad_dm_a *= 2.d0 - grad_dm_b *= 2.d0 - - end - - - - -subroutine dm_dft_alpha_beta_no_core_at_r(r,dm_a,dm_b) - implicit none - BEGIN_DOC -! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z -! output : dm_a = alpha density evaluated at r(3) without the core orbitals -! output : dm_b = beta density evaluated at r(3) without the core orbitals - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - integer :: istate - double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v - call give_all_aos_at_r(r,aos_array) - do istate = 1, N_states - aos_array_bis = aos_array - ! alpha density - call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - ! beta density - aos_array_bis = aos_array - call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - enddo -end - - subroutine dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array) - implicit none - BEGIN_DOC -! input: -! -! * r(1) ==> r(1) = x, r(2) = y, r(3) = z -! -! output: -! -! * dm_a = alpha density evaluated at r without the core orbitals -! * dm_b = beta density evaluated at r without the core orbitals -! * aos_array(i) = ao(i) evaluated at r without the core orbitals -! * grad_dm_a(1) = X gradient of the alpha density evaluated in r without the core orbitals -! * grad_dm_a(1) = X gradient of the beta density evaluated in r without the core orbitals -! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r -! - END_DOC - double precision, intent(in) :: r(3) - double precision, intent(out) :: dm_a(N_states),dm_b(N_states) - double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) - double precision, intent(out) :: grad_aos_array(3,ao_num) - integer :: i,j,istate - double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v - double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) - - call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array) - do i = 1, ao_num - do j = 1, 3 - aos_grad_array(i,j) = grad_aos_array(j,i) - enddo - enddo - - do istate = 1, N_states - ! alpha density - ! aos_array_bis = \rho_ao * aos_array - call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),size(one_e_dm_alpha_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1) - dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - ! aos_grad_array_bis = \rho_ao * aos_grad_array - - ! beta density - call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),size(one_e_dm_beta_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1) - dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) - - ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) - grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) - grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) - grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) - ! aos_grad_array_bis = \rho_ao * aos_grad_array - enddo - grad_dm_a *= 2.d0 - grad_dm_b *= 2.d0 - end - - - - BEGIN_PROVIDER [double precision, one_e_dm_alpha_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_dm_beta_in_r, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] implicit none integer :: i,j,k,l,m,istate double precision :: contrib double precision :: r(3) - double precision :: aos_array(ao_num),mos_array(mo_num) - do j = 1, nucl_num - do k = 1, n_points_radial_grid -1 - do l = 1, n_points_integration_angular - do istate = 1, N_States - one_e_dm_alpha_in_r(l,k,j,istate) = 0.d0 - one_e_dm_beta_in_r(l,k,j,istate) = 0.d0 - enddo - 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) + double precision, allocatable :: aos_array(:),grad_aos_array(:,:) + double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:) + allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states)) + allocate(aos_array(ao_num),grad_aos_array(3,ao_num)) + do istate = 1, N_states + do i = 1, n_points_final_grid + r(1) = final_grid_points(1,i) + r(2) = final_grid_points(2,i) + r(3) = final_grid_points(3,i) - double precision :: dm_a(N_states),dm_b(N_states) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - do istate=1,N_states - one_e_dm_alpha_in_r(l,k,j,istate) = dm_a(istate) - one_e_dm_beta_in_r(l,k,j,istate) = dm_b(istate) - enddo + call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array) - enddo - enddo + ! alpha/beta density + one_e_dm_and_grad_alpha_in_r(4,i,istate) = dm_a(istate) + one_e_dm_and_grad_beta_in_r(4,i,istate) = dm_b(istate) + + ! alpha/beta density gradients + one_e_dm_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate) + one_e_dm_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate) + one_e_dm_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate) + + one_e_dm_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate) + one_e_dm_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate) + one_e_dm_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate) + + ! alpha/beta squared of the gradients + one_e_grad_2_dm_alpha_at_r(i,istate) = dm_a_grad(1,istate) * dm_a_grad(1,istate) & + + dm_a_grad(2,istate) * dm_a_grad(2,istate) & + + dm_a_grad(3,istate) * dm_a_grad(3,istate) + one_e_grad_2_dm_beta_at_r(i,istate) = dm_b_grad(1,istate) * dm_b_grad(1,istate) & + + dm_b_grad(2,istate) * dm_b_grad(2,istate) & + + dm_b_grad(3,istate) * dm_b_grad(3,istate) + + ! scalar product between alpha and beta density gradient + scal_prod_grad_one_e_dm_ab(i,istate) = dm_a_grad(1,istate) * dm_b_grad(1,istate) & + + dm_a_grad(2,istate) * dm_b_grad(2,istate) & + + dm_a_grad(3,istate) * dm_b_grad(3,istate) + + ! some stuffs needed for GGA type potentials + one_e_stuff_for_pbe(1,i,istate) = 2.D0 * (dm_a_grad(1,istate) + dm_b_grad(1,istate) ) & + * (dm_a(istate) + dm_b(istate)) + one_e_stuff_for_pbe(2,i,istate) = 2.D0 * (dm_a_grad(2,istate) + dm_b_grad(2,istate) ) & + * (dm_a(istate) + dm_b(istate)) + one_e_stuff_for_pbe(3,i,istate) = 2.D0 * (dm_a_grad(3,istate) + dm_b_grad(3,istate) ) & + * (dm_a(istate) + dm_b(istate)) enddo + enddo END_PROVIDER - BEGIN_PROVIDER [double precision, one_e_dm_alpha_at_r, (n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_dm_beta_at_r, (n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (N_states) ] + BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (N_states) ] &BEGIN_PROVIDER [double precision, elec_alpha_num_grid_becke , (N_states) ] +&BEGIN_PROVIDER [double precision, elec_num_grid_becke , (N_states) ] implicit none BEGIN_DOC -! one_e_dm_alpha_at_r(i,istate) = n_alpha(r_i,istate) -! one_e_dm_beta_at_r(i,istate) = n_beta(r_i,istate) -! where r_i is the ith point of the grid and istate is the state number + ! number of electrons when the one-e alpha/beta densities are numerically integrated on the DFT grid + ! + ! !!!!! WARNING !!!! if no_core_density = .True. then all core electrons are removed END_DOC integer :: i,istate - double precision :: r(3) - double precision, allocatable :: dm_a(:),dm_b(:) - allocate(dm_a(N_states),dm_b(N_states)) + double precision :: r(3),weight do istate = 1, N_states do i = 1, n_points_final_grid r(1) = final_grid_points(1,i) r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) - call dm_dft_alpha_beta_at_r(r,dm_a,dm_b) - one_e_dm_alpha_at_r(i,istate) = dm_a(istate) - one_e_dm_beta_at_r(i,istate) = dm_b(istate) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, one_e_dm_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_dm_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_alpha_at_r, (n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_grad_2_dm_beta_at_r, (n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_grad_dm_squared_at_r, (3,n_points_final_grid,N_states) ] - BEGIN_DOC -! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate) -! one_e_dm_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate) -! one_e_dm_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate) -! one_e_dm_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate) -! one_e_grad_2_dm_alpha_at_r(i,istate) = (d\dx n_alpha(r_i,istate))^2 + (d\dy n_alpha(r_i,istate))^2 + (d\dz n_alpha(r_i,istate))^2 -! where r_i is the ith point of the grid and istate is the state number - END_DOC - implicit none - integer :: i,j,k,l,m,istate - double precision :: contrib - double precision :: r(3) - double precision, allocatable :: aos_array(:),grad_aos_array(:,:) - double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:) - allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states)) - allocate(aos_array(ao_num),grad_aos_array(3,ao_num)) - do istate = 1, N_states - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - !!!! Works also with the ao basis - call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array) - one_e_dm_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate) - one_e_dm_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate) - one_e_dm_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate) - one_e_dm_and_grad_alpha_in_r(4,i,istate) = dm_a(istate) - one_e_grad_2_dm_alpha_at_r(i,istate) = dm_a_grad(1,istate) * dm_a_grad(1,istate) + dm_a_grad(2,istate) * dm_a_grad(2,istate) + dm_a_grad(3,istate) * dm_a_grad(3,istate) - - one_e_dm_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate) - one_e_dm_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate) - one_e_dm_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate) - one_e_dm_and_grad_beta_in_r(4,i,istate) = dm_b(istate) - one_e_grad_2_dm_beta_at_r(i,istate) = dm_b_grad(1,istate) * dm_b_grad(1,istate) + dm_b_grad(2,istate) * dm_b_grad(2,istate) + dm_b_grad(3,istate) * dm_b_grad(3,istate) - one_e_grad_dm_squared_at_r(1,i,istate) = 2.D0 * (dm_a_grad(1,istate) + dm_b_grad(1,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate)) - one_e_grad_dm_squared_at_r(2,i,istate) = 2.D0 * (dm_a_grad(2,istate) + dm_b_grad(2,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate)) - one_e_grad_dm_squared_at_r(3,i,istate) = 2.D0 * (dm_a_grad(3,istate) + dm_b_grad(3,istate) ) * (one_e_dm_and_grad_alpha_in_r(4,i,istate) + one_e_dm_and_grad_beta_in_r(4,i,istate)) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, one_e_dm_no_core_and_grad_alpha_in_r, (4,n_points_final_grid,N_states) ] -&BEGIN_PROVIDER [double precision, one_e_dm_no_core_and_grad_beta_in_r, (4,n_points_final_grid,N_states) ] - BEGIN_DOC -! one_e_dm_no_core_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate) without core orbitals -! one_e_dm_no_core_and_grad_alpha_in_r(2,i,i_state) = d\dy n_alpha(r_i,istate) without core orbitals -! one_e_dm_no_core_and_grad_alpha_in_r(3,i,i_state) = d\dz n_alpha(r_i,istate) without core orbitals -! one_e_dm_no_core_and_grad_alpha_in_r(4,i,i_state) = n_alpha(r_i,istate) without core orbitals -! where r_i is the ith point of the grid and istate is the state number - END_DOC - implicit none - integer :: i,j,k,l,m,istate - double precision :: contrib - double precision :: r(3) - double precision, allocatable :: aos_array(:),grad_aos_array(:,:) - double precision, allocatable :: dm_a(:),dm_b(:), dm_a_grad(:,:), dm_b_grad(:,:) - allocate(dm_a(N_states),dm_b(N_states), dm_a_grad(3,N_states), dm_b_grad(3,N_states)) - allocate(aos_array(ao_num),grad_aos_array(3,ao_num)) - do istate = 1, N_states - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - !!!! Works also with the ao basis - call dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, dm_a_grad, dm_b_grad, aos_array, grad_aos_array) - one_e_dm_no_core_and_grad_alpha_in_r(1,i,istate) = dm_a_grad(1,istate) - one_e_dm_no_core_and_grad_alpha_in_r(2,i,istate) = dm_a_grad(2,istate) - one_e_dm_no_core_and_grad_alpha_in_r(3,i,istate) = dm_a_grad(3,istate) - one_e_dm_no_core_and_grad_alpha_in_r(4,i,istate) = dm_a(istate) - - one_e_dm_no_core_and_grad_beta_in_r(1,i,istate) = dm_b_grad(1,istate) - one_e_dm_no_core_and_grad_beta_in_r(2,i,istate) = dm_b_grad(2,istate) - one_e_dm_no_core_and_grad_beta_in_r(3,i,istate) = dm_b_grad(3,istate) - one_e_dm_no_core_and_grad_beta_in_r(4,i,istate) = dm_b(istate) + weight = final_weight_at_r_vector(i) + + elec_alpha_num_grid_becke(istate) += one_e_dm_and_grad_alpha_in_r(4,i,istate) * weight + elec_beta_num_grid_becke(istate) += one_e_dm_and_grad_beta_in_r(4,i,istate) * weight enddo + elec_num_grid_becke(istate) = elec_alpha_num_grid_becke(istate) + elec_beta_num_grid_becke(istate) enddo END_PROVIDER diff --git a/src/dft_utils_in_r/dm_in_r_routines.irp.f b/src/dft_utils_in_r/dm_in_r_routines.irp.f new file mode 100644 index 00000000..6fa99e22 --- /dev/null +++ b/src/dft_utils_in_r/dm_in_r_routines.irp.f @@ -0,0 +1,290 @@ + +subroutine dm_dft_alpha_beta_at_r(r,dm_a,dm_b) + implicit none + BEGIN_DOC +! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z +! output : dm_a = alpha density evaluated at r(3) +! output : dm_b = beta density evaluated at r(3) + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + integer :: istate + double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v + call give_all_aos_at_r(r,aos_array) + do istate = 1, N_states + aos_array_bis = aos_array + ! alpha density + call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + ! beta density + aos_array_bis = aos_array + call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + enddo +end + + +subroutine dm_dft_alpha_beta_and_all_aos_at_r(r,dm_a,dm_b,aos_array) + BEGIN_DOC +! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z +! output : dm_a = alpha density evaluated at r +! output : dm_b = beta density evaluated at r +! output : aos_array(i) = ao(i) evaluated at r + END_DOC + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + double precision, intent(out) :: aos_array(ao_num) + integer :: istate + double precision :: aos_array_bis(ao_num),u_dot_v + call give_all_aos_at_r(r,aos_array) + do istate = 1, N_states + aos_array_bis = aos_array + ! alpha density + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + ! beta density + aos_array_bis = aos_array + call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + enddo +end + + + + subroutine density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array) + implicit none + BEGIN_DOC +! input: +! +! * r(1) ==> r(1) = x, r(2) = y, r(3) = z +! +! output: +! +! * dm_a = alpha density evaluated at r +! * dm_b = beta density evaluated at r +! * aos_array(i) = ao(i) evaluated at r +! * grad_dm_a(1) = X gradient of the alpha density evaluated in r +! * grad_dm_a(1) = X gradient of the beta density evaluated in r +! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r +! + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) + double precision, intent(out) :: grad_aos_array(3,ao_num) + integer :: i,j,istate + double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v + double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) + + call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array) + do i = 1, ao_num + do j = 1, 3 + aos_grad_array(i,j) = grad_aos_array(j,i) + enddo + enddo + + do istate = 1, N_states + ! alpha density + ! aos_array_bis = \rho_ao * aos_array + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + ! aos_grad_array_bis = \rho_ao * aos_grad_array + + ! beta density + call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + ! aos_grad_array_bis = \rho_ao * aos_grad_array + enddo + grad_dm_a *= 2.d0 + grad_dm_b *= 2.d0 + end + + + + subroutine density_and_grad_lapl_alpha_beta_and_all_aos_and_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, lapl_dm_a, lapl_dm_b, aos_array, grad_aos_array, lapl_aos_array) + implicit none + BEGIN_DOC +! input: +! +! * r(1) ==> r(1) = x, r(2) = y, r(3) = z +! +! output: +! +! * dm_a = alpha density evaluated at r +! * dm_b = beta density evaluated at r +! * aos_array(i) = ao(i) evaluated at r +! * grad_dm_a(1) = X gradient of the alpha density evaluated in r +! * grad_dm_a(1) = X gradient of the beta density evaluated in r +! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r +! + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) + double precision, intent(out) :: lapl_dm_a(3,N_states),lapl_dm_b(3,N_states) + double precision, intent(out) :: grad_aos_array(3,ao_num) + double precision, intent(out) :: lapl_aos_array(3,ao_num) + integer :: i,j,istate + double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v + double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) + double precision :: aos_lapl_array(ao_num,3) + + call give_all_aos_and_grad_and_lapl_at_r(r,aos_array,grad_aos_array,lapl_aos_array) + do i = 1, ao_num + do j = 1, 3 + aos_grad_array(i,j) = grad_aos_array(j,i) + aos_lapl_array(i,j) = lapl_aos_array(j,i) + enddo + enddo + + do istate = 1, N_states + ! alpha density + ! aos_array_bis = \rho_ao * aos_array + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + + ! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i) + lapl_dm_a(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num) + lapl_dm_a(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num) + lapl_dm_a(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num) + + ! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1) + ! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i) + lapl_dm_a(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num) + lapl_dm_a(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num) + lapl_dm_a(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num) + + + ! beta density + call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft(1,1,istate),size(one_e_dm_beta_ao_for_dft,1),aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + + ! lapl_dm(1) = \sum_i aos_lapl_array(i,1) * aos_array_bis(i) + lapl_dm_b(1,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,1),aos_array_bis,ao_num) + lapl_dm_b(2,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,2),aos_array_bis,ao_num) + lapl_dm_b(3,istate) = 2.d0 * u_dot_v(aos_lapl_array(1,3),aos_array_bis,ao_num) + + ! aos_grad_array_bis(1) = \rho_ao * aos_grad_array(1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,1),1,0.d0,aos_grad_array_bis(1,1),1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,2),1,0.d0,aos_grad_array_bis(1,2),1) + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft(1,1,istate),size(one_e_dm_alpha_ao_for_dft,1),aos_grad_array(1,3),1,0.d0,aos_grad_array_bis(1,3),1) + ! lapl_dm(1) += \sum_i aos_grad_array(i,1) * aos_grad_array_bis(i) + lapl_dm_b(1,istate) += 2.d0 * u_dot_v(aos_grad_array(1,1),aos_grad_array_bis,ao_num) + lapl_dm_b(2,istate) += 2.d0 * u_dot_v(aos_grad_array(1,2),aos_grad_array_bis,ao_num) + lapl_dm_b(3,istate) += 2.d0 * u_dot_v(aos_grad_array(1,3),aos_grad_array_bis,ao_num) + enddo + grad_dm_a *= 2.d0 + grad_dm_b *= 2.d0 + + end + + + + +subroutine dm_dft_alpha_beta_no_core_at_r(r,dm_a,dm_b) + implicit none + BEGIN_DOC +! input: r(1) ==> r(1) = x, r(2) = y, r(3) = z +! output : dm_a = alpha density evaluated at r(3) without the core orbitals +! output : dm_b = beta density evaluated at r(3) without the core orbitals + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + integer :: istate + double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v + call give_all_aos_at_r(r,aos_array) + do istate = 1, N_states + aos_array_bis = aos_array + ! alpha density + call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + ! beta density + aos_array_bis = aos_array + call dgemv('N',ao_num,ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),ao_num,aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + enddo +end + + subroutine dens_grad_a_b_no_core_and_aos_grad_aos_at_r(r,dm_a,dm_b, grad_dm_a, grad_dm_b, aos_array, grad_aos_array) + implicit none + BEGIN_DOC +! input: +! +! * r(1) ==> r(1) = x, r(2) = y, r(3) = z +! +! output: +! +! * dm_a = alpha density evaluated at r without the core orbitals +! * dm_b = beta density evaluated at r without the core orbitals +! * aos_array(i) = ao(i) evaluated at r without the core orbitals +! * grad_dm_a(1) = X gradient of the alpha density evaluated in r without the core orbitals +! * grad_dm_a(1) = X gradient of the beta density evaluated in r without the core orbitals +! * grad_aos_array(1) = X gradient of the aos(i) evaluated at r +! + END_DOC + double precision, intent(in) :: r(3) + double precision, intent(out) :: dm_a(N_states),dm_b(N_states) + double precision, intent(out) :: grad_dm_a(3,N_states),grad_dm_b(3,N_states) + double precision, intent(out) :: grad_aos_array(3,ao_num) + integer :: i,j,istate + double precision :: aos_array(ao_num),aos_array_bis(ao_num),u_dot_v + double precision :: aos_grad_array(ao_num,3), aos_grad_array_bis(ao_num,3) + + call give_all_aos_and_grad_at_r(r,aos_array,grad_aos_array) + do i = 1, ao_num + do j = 1, 3 + aos_grad_array(i,j) = grad_aos_array(j,i) + enddo + enddo + + do istate = 1, N_states + ! alpha density + ! aos_array_bis = \rho_ao * aos_array + call dsymv('U',ao_num,1.d0,one_e_dm_alpha_ao_for_dft_no_core(1,1,istate),size(one_e_dm_alpha_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1) + dm_a(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_a(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_a(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_a(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + ! aos_grad_array_bis = \rho_ao * aos_grad_array + + ! beta density + call dsymv('U',ao_num,1.d0,one_e_dm_beta_ao_for_dft_no_core(1,1,istate),size(one_e_dm_beta_ao_for_dft_no_core,1),aos_array,1,0.d0,aos_array_bis,1) + dm_b(istate) = u_dot_v(aos_array,aos_array_bis,ao_num) + + ! grad_dm(1) = \sum_i aos_grad_array(i,1) * aos_array_bis(i) + grad_dm_b(1,istate) = u_dot_v(aos_grad_array(1,1),aos_array_bis,ao_num) + grad_dm_b(2,istate) = u_dot_v(aos_grad_array(1,2),aos_array_bis,ao_num) + grad_dm_b(3,istate) = u_dot_v(aos_grad_array(1,3),aos_array_bis,ao_num) + ! aos_grad_array_bis = \rho_ao * aos_grad_array + enddo + grad_dm_a *= 2.d0 + grad_dm_b *= 2.d0 + end + + diff --git a/src/dft_utils_one_e/ec_lyp.irp.f b/src/dft_utils_one_e/ec_lyp.irp.f deleted file mode 100644 index 22d15a9c..00000000 --- a/src/dft_utils_one_e/ec_lyp.irp.f +++ /dev/null @@ -1,125 +0,0 @@ -subroutine give_all_stuffs_in_r_for_lyp_88(r,rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2) - implicit none - double precision, intent(in) :: r(3) - double precision, intent(out) :: rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_2(N_states),rho(N_states) - double precision :: grad_rho_a(3,N_states),grad_rho_b(3,N_states),grad_rho_a_b(N_states) - double precision :: grad_aos_array(3,ao_num),aos_array(ao_num) - - call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,rho_a,rho_b, grad_rho_a, grad_rho_b, aos_array, grad_aos_array) - integer :: i,istate - rho = rho_a + rho_b - grad_rho_a_2 = 0.d0 - grad_rho_b_2 = 0.d0 - grad_rho_a_b = 0.d0 - do istate = 1, N_states - do i = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(i,istate) * grad_rho_a(i,istate) - grad_rho_b_2(istate) += grad_rho_b(i,istate) * grad_rho_b(i,istate) - grad_rho_a_b(istate) += grad_rho_a(i,istate) * grad_rho_b(i,istate) - enddo - enddo - grad_rho_2 = grad_rho_a_2 + grad_rho_b_2 + 2.d0 * grad_rho_a_b - -end - - -double precision function ec_lyp_88(rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2) - - implicit none - - BEGIN_DOC -! LYP functional of the Lee, Yan, Parr, Phys. Rev B 1988, Vol 37, page 785. -! The expression used is the one by Miehlich, Savin, Stoll, Preuss, CPL, 1989 which gets rid of the laplacian of the density - END_DOC - - include 'constants.include.F' - -! Input variables - double precision, intent(in) :: rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2 -! Local variables - double precision :: a,b,c,d,c_f,omega,delta - double precision :: rho_13,rho_inv_13,rho_83,rho_113,rho_inv_113,denom - double precision :: thr,huge_num,rho_inv - double precision :: cst_2_113,cst_8_3,rho_2,rho_a_2,rho_b_2 - double precision :: tmp1,tmp2,tmp3,tmp4 - double precision :: big1,big2,big3 - - -! Constants of the LYP correlation functional - - a = 0.04918d0 - b = 0.132d0 - c = 0.2533d0 - d = 0.349d0 - - ec_lyp_88 = 0.d0 - - thr = 1d-15 - huge_num = 1.d0/thr - if(dabs(rho_a).lt.thr)then - return - endif - - if(dabs(rho_b).lt.thr)then - return - endif - - if(rho.lt.0.d0)then - print*,'pb !! rho.lt.0.d0' - stop - endif - - rho_13 = rho**(1.d0/3.d0) - rho_113 = rho**(11.d0/3.d0) - - if(dabs(rho_13) < thr) then - rho_inv_13 = huge_num - else - rho_inv_13 = 1.d0/rho_13 - endif - - if (dabs(rho_113) < thr) then - rho_inv_113 = huge_num - else - rho_inv_113 = 1.d0/rho_113 - endif - - if (dabs(rho) < thr) then - rho_inv = huge_num - else - rho_inv = 1.d0/rho - endif - -! Useful quantities to predefine - - denom = 1d0/(1d0 + d*rho_inv_13) - omega = rho_inv_113*exp(-c*rho_inv_13)*denom - delta = c*rho_inv_13 + d*rho_inv_13*denom - c_f = 0.3d0*(3.d0*pi*pi)**(2.d0/3.d0) - - rho_2 = rho *rho - rho_a_2 = rho_a*rho_a - rho_b_2 = rho_b*rho_b - - cst_2_113 = 2.d0**(11.d0/3.d0) - cst_8_3 = 8.d0/3.d0 - - ! first term in the equation (2) of Preuss CPL, 1989 - - big1 = 4.d0*denom*rho_a*rho_b*rho_inv - - tmp1 = cst_2_113*c_f*(rho_a**cst_8_3 + rho_b**cst_8_3) - tmp2 = (47.d0/18.d0 - 7.d0/18.d0*delta)*grad_rho_2 - tmp3 = - (5d0/2d0 - 1.d0/18d0*delta)*(grad_rho_a_2 + grad_rho_b_2) - tmp4 = - (delta - 11d0)/9d0*(rho_a*rho_inv*grad_rho_a_2 + rho_b*rho_inv*grad_rho_b_2) - big2 = rho_a*rho_b*(tmp1 + tmp2 + tmp3 + tmp4) - - tmp1 = -2d0/3d0*rho_2*grad_rho_2 - tmp2 = grad_rho_b_2*(2d0/3d0*rho_2 - rho_a_2) - tmp3 = grad_rho_a_2*(2d0/3d0*rho_2 - rho_b_2) - big3 = tmp1 + tmp2 + tmp3 - - ec_lyp_88 = -a*big1 -a*b*omega*big2 -a*b*omega*big3 - -end - diff --git a/src/dft_utils_one_e/ec_lyp_2.irp.f b/src/dft_utils_one_e/ec_lyp_2.irp.f deleted file mode 100644 index e97a0e00..00000000 --- a/src/dft_utils_one_e/ec_lyp_2.irp.f +++ /dev/null @@ -1,28 +0,0 @@ -double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB) - include 'constants.include.F' - implicit none - double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB - double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E - ec_lyp2 = 0.d0 - Tol=1D-14 - E=2.718281828459045D0 - caa=0.04918D0 - cab=0.132D0 - cac=0.2533D0 - cad=0.349D0 - cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0))) - - - RA = MAX(RhoA,0D0) - RB = MAX(RhoB,0D0) - IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN - IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN - comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0))) - cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0)) - cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0 - cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0 - cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0) - ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0)))) - endif - endif -end diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f deleted file mode 100644 index 741129eb..00000000 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ /dev/null @@ -1,99 +0,0 @@ -double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) - include 'constants.include.F' - implicit none - double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 - double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 - double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 - double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf - double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 - double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 - thr = 1.d-12 - nup = max(rho_a,thr) - ndo = max(rho_b,thr) - rho = nup + ndo - ec_scan = 0.d0 - if((rho).lt.thr)return - ! constants ... - rho_inv = 1.d0/rho - cst_13 = 1.d0/3.d0 - cst_23 = 2.d0 * cst_13 - cst_43 = 4.d0 * cst_13 - cst_53 = 5.d0 * cst_13 - cst_18 = 1.d0/8.d0 - cst_3pi2 = 3.d0 * pi*pi - drho2 = max(grad_rho_2,thr) - drho = dsqrt(drho2) - if((nup-ndo).gt.0.d0)then - spin_d = max(nup-ndo,thr) - else - spin_d = min(nup-ndo,-thr) - endif - c_1c = 0.64d0 - c_2c = 1.5d0 - d_c = 0.7d0 - b_1c = 0.0285764d0 - b_2c = 0.0889d0 - b_3c = 0.125541d0 - gama = 0.031091d0 - ! correlation energy lsda1 - call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) - - ! correlation energy per particle - e_c_lsda1 = e_c_lsda1/rho - xi = spin_d/rho - rs = (cst_43 * pi * rho)**(-cst_13) - s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) - t_w = drho2 * cst_18 * rho_inv - ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) - t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi - t_unif = max(t_unif,thr) - alpha = (tau - t_w)/t_unif - cst_1alph= 1.d0 - alpha - if(cst_1alph.gt.0.d0)then - cst_1alph= max(cst_1alph,thr) - else - cst_1alph= min(cst_1alph,-thr) - endif - inv_1alph= 1.d0/cst_1alph - phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) - phi_3 = phi*phi*phi - t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) - w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 - a = beta_rs(rs) /(gama * w_1) - g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 - h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) - ! interpolation function - - if(cst_1alph.gt.0.d0)then - fc_alpha = dexp(-c_1c * alpha * inv_1alph) - else - fc_alpha = - d_c * dexp(c_2c * inv_1alph) - endif - ! first part of the correlation energy - e_c_1 = e_c_lsda1 + h1 - - dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) - gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) - e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) - w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 - beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 - cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi - - x_inf = 0.128026d0 - f0 = -0.9d0 - g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 - - h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) - e_c_0 = (e_c_lsda0 + h0) * gc_xi - - ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) -end - - -double precision function beta_rs(rs) - implicit none - double precision, intent(in) ::rs - beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) - -end - diff --git a/src/dft_utils_one_e/ec_scan_2.irp.f b/src/dft_utils_one_e/ec_scan_2.irp.f deleted file mode 100644 index 4807b89f..00000000 --- a/src/dft_utils_one_e/ec_scan_2.irp.f +++ /dev/null @@ -1,100 +0,0 @@ -double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) - include 'constants.include.F' - implicit none - double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 - double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 - double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 - double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf - double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 - double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 - thr = 1.d-12 - nup = max(rho_a,thr) - ndo = max(rho_b,thr) - rho = nup + ndo - ec_scan = 0.d0 - if((rho).lt.thr)return - ! constants ... - rho_inv = 1.d0/rho - cst_13 = 1.d0/3.d0 - cst_23 = 2.d0 * cst_13 - cst_43 = 4.d0 * cst_13 - cst_53 = 5.d0 * cst_13 - cst_18 = 1.d0/8.d0 - cst_3pi2 = 3.d0 * pi*pi - drho2 = max(grad_rho_2,thr) - drho = dsqrt(drho2) - if((nup-ndo).gt.0.d0)then - spin_d = max(nup-ndo,thr) - else - spin_d = min(nup-ndo,-thr) - endif - c_1c = 0.64d0 - c_2c = 1.5d0 - d_c = 0.7d0 - b_1c = 0.0285764d0 - b_2c = 0.0889d0 - b_3c = 0.125541d0 - gama = 0.031091d0 - ! correlation energy lsda1 - call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) - - xi = spin_d/rho - rs = (cst_43 * pi * rho)**(-cst_13) - s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) - t_w = drho2 * cst_18 * rho_inv - ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) - t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi - t_unif = max(t_unif,thr) - alpha = (tau - t_w)/t_unif - cst_1alph= 1.d0 - alpha - if(cst_1alph.gt.0.d0)then - cst_1alph= max(cst_1alph,thr) - else - cst_1alph= min(cst_1alph,-thr) - endif - inv_1alph= 1.d0/cst_1alph - phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) - phi_3 = phi*phi*phi - t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) - w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 - a = beta_rs(rs) /(gama * w_1) - g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 - h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) - ! interpolation function - fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph) - ! first part of the correlation energy - e_c_1 = e_c_lsda1 + h1 - - dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) - gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) - e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) - w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 - beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 - cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi - - x_inf = 0.128026d0 - f0 = -0.9d0 - g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 - - h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) - e_c_0 = (e_c_lsda0 + h0) * gc_xi - - ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) -end - -double precision function step_f(x) - implicit none - double precision, intent(in) :: x - if(x.lt.0.d0)then - step_f = 0.d0 - else - step_f = 1.d0 - endif -end - -double precision function beta_rs(rs) - implicit none - double precision, intent(in) ::rs - beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) - -end diff --git a/src/dft_utils_one_e/effective_pot.irp.f b/src/dft_utils_one_e/effective_pot.irp.f index cf36060a..27f4841e 100644 --- a/src/dft_utils_one_e/effective_pot.irp.f +++ b/src/dft_utils_one_e/effective_pot.irp.f @@ -7,10 +7,12 @@ ! Effective_one_e_potential(i,j) = $\rangle i_{MO}| v_{H}^{sr} |j_{MO}\rangle + \rangle i_{MO}| h_{core} |j_{MO}\rangle + \rangle i_{MO}|v_{xc} |j_{MO}\rangle$ ! ! on the |MO| basis +! ! Taking the expectation value does not provide any energy, but -! effective_one_e_potential(i,j) is the potential coupling DFT and WFT part to -! be used in any WFT calculation. ! +! effective_one_e_potential(i,j) is the potential coupling DFT and WFT parts +! +! and it is used in any RS-DFT based calculations END_DOC do istate = 1, N_states do j = 1, mo_num diff --git a/src/dft_utils_one_e/garbage_func.irp.f b/src/dft_utils_one_e/garbage_func.irp.f new file mode 100644 index 00000000..d104a69f --- /dev/null +++ b/src/dft_utils_one_e/garbage_func.irp.f @@ -0,0 +1,264 @@ + +subroutine give_all_stuffs_in_r_for_lyp_88(r,rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(out) :: rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_2(N_states),rho(N_states) + double precision :: grad_rho_a(3,N_states),grad_rho_b(3,N_states),grad_rho_a_b(N_states) + double precision :: grad_aos_array(3,ao_num),aos_array(ao_num) + + call density_and_grad_alpha_beta_and_all_aos_and_grad_aos_at_r(r,rho_a,rho_b, grad_rho_a, grad_rho_b, aos_array, grad_aos_array) + integer :: i,istate + rho = rho_a + rho_b + grad_rho_a_2 = 0.d0 + grad_rho_b_2 = 0.d0 + grad_rho_a_b = 0.d0 + do istate = 1, N_states + do i = 1, 3 + grad_rho_a_2(istate) += grad_rho_a(i,istate) * grad_rho_a(i,istate) + grad_rho_b_2(istate) += grad_rho_b(i,istate) * grad_rho_b(i,istate) + grad_rho_a_b(istate) += grad_rho_a(i,istate) * grad_rho_b(i,istate) + enddo + enddo + grad_rho_2 = grad_rho_a_2 + grad_rho_b_2 + 2.d0 * grad_rho_a_b + +end + + +double precision function ec_lyp_88(rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2) + + implicit none + + BEGIN_DOC +! LYP functional of the Lee, Yan, Parr, Phys. Rev B 1988, Vol 37, page 785. +! The expression used is the one by Miehlich, Savin, Stoll, Preuss, CPL, 1989 which gets rid of the laplacian of the density + END_DOC + + include 'constants.include.F' + +! Input variables + double precision, intent(in) :: rho,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_2 +! Local variables + double precision :: a,b,c,d,c_f,omega,delta + double precision :: rho_13,rho_inv_13,rho_83,rho_113,rho_inv_113,denom + double precision :: thr,huge_num,rho_inv + double precision :: cst_2_113,cst_8_3,rho_2,rho_a_2,rho_b_2 + double precision :: tmp1,tmp2,tmp3,tmp4 + double precision :: big1,big2,big3 + + +! Constants of the LYP correlation functional + + a = 0.04918d0 + b = 0.132d0 + c = 0.2533d0 + d = 0.349d0 + + ec_lyp_88 = 0.d0 + + thr = 1d-15 + huge_num = 1.d0/thr + if(dabs(rho_a).lt.thr)then + return + endif + + if(dabs(rho_b).lt.thr)then + return + endif + + if(rho.lt.0.d0)then + print*,'pb !! rho.lt.0.d0' + stop + endif + + rho_13 = rho**(1.d0/3.d0) + rho_113 = rho**(11.d0/3.d0) + + if(dabs(rho_13) < thr) then + rho_inv_13 = huge_num + else + rho_inv_13 = 1.d0/rho_13 + endif + + if (dabs(rho_113) < thr) then + rho_inv_113 = huge_num + else + rho_inv_113 = 1.d0/rho_113 + endif + + if (dabs(rho) < thr) then + rho_inv = huge_num + else + rho_inv = 1.d0/rho + endif + +! Useful quantities to predefine + + denom = 1d0/(1d0 + d*rho_inv_13) + omega = rho_inv_113*exp(-c*rho_inv_13)*denom + delta = c*rho_inv_13 + d*rho_inv_13*denom + c_f = 0.3d0*(3.d0*pi*pi)**(2.d0/3.d0) + + rho_2 = rho *rho + rho_a_2 = rho_a*rho_a + rho_b_2 = rho_b*rho_b + + cst_2_113 = 2.d0**(11.d0/3.d0) + cst_8_3 = 8.d0/3.d0 + + ! first term in the equation (2) of Preuss CPL, 1989 + + big1 = 4.d0*denom*rho_a*rho_b*rho_inv + + tmp1 = cst_2_113*c_f*(rho_a**cst_8_3 + rho_b**cst_8_3) + tmp2 = (47.d0/18.d0 - 7.d0/18.d0*delta)*grad_rho_2 + tmp3 = - (5d0/2d0 - 1.d0/18d0*delta)*(grad_rho_a_2 + grad_rho_b_2) + tmp4 = - (delta - 11d0)/9d0*(rho_a*rho_inv*grad_rho_a_2 + rho_b*rho_inv*grad_rho_b_2) + big2 = rho_a*rho_b*(tmp1 + tmp2 + tmp3 + tmp4) + + tmp1 = -2d0/3d0*rho_2*grad_rho_2 + tmp2 = grad_rho_b_2*(2d0/3d0*rho_2 - rho_a_2) + tmp3 = grad_rho_a_2*(2d0/3d0*rho_2 - rho_b_2) + big3 = tmp1 + tmp2 + tmp3 + + ec_lyp_88 = -a*big1 -a*b*omega*big2 -a*b*omega*big3 + +end + +double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB) + include 'constants.include.F' + implicit none + double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB + double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E + ec_lyp2 = 0.d0 + Tol=1D-14 + E=2.718281828459045D0 + caa=0.04918D0 + cab=0.132D0 + cac=0.2533D0 + cad=0.349D0 + cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0))) + + + RA = MAX(RhoA,0D0) + RB = MAX(RhoB,0D0) + IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN + IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN + comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0))) + cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0)) + cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0 + cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0 + cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0) + ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0)))) + endif + endif +end + +double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) + include 'constants.include.F' + implicit none + double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 + double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 + double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 + double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf + double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 + double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 + thr = 1.d-12 + nup = max(rho_a,thr) + ndo = max(rho_b,thr) + rho = nup + ndo + ec_scan = 0.d0 + if((rho).lt.thr)return + ! constants ... + rho_inv = 1.d0/rho + cst_13 = 1.d0/3.d0 + cst_23 = 2.d0 * cst_13 + cst_43 = 4.d0 * cst_13 + cst_53 = 5.d0 * cst_13 + cst_18 = 1.d0/8.d0 + cst_3pi2 = 3.d0 * pi*pi + drho2 = max(grad_rho_2,thr) + drho = dsqrt(drho2) + if((nup-ndo).gt.0.d0)then + spin_d = max(nup-ndo,thr) + else + spin_d = min(nup-ndo,-thr) + endif + c_1c = 0.64d0 + c_2c = 1.5d0 + d_c = 0.7d0 + b_1c = 0.0285764d0 + b_2c = 0.0889d0 + b_3c = 0.125541d0 + gama = 0.031091d0 + ! correlation energy lsda1 + call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) + + ! correlation energy per particle + e_c_lsda1 = e_c_lsda1/rho + xi = spin_d/rho + rs = (cst_43 * pi * rho)**(-cst_13) + s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) + t_w = drho2 * cst_18 * rho_inv + ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) + t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi + t_unif = max(t_unif,thr) + alpha = (tau - t_w)/t_unif + cst_1alph= 1.d0 - alpha + if(cst_1alph.gt.0.d0)then + cst_1alph= max(cst_1alph,thr) + else + cst_1alph= min(cst_1alph,-thr) + endif + inv_1alph= 1.d0/cst_1alph + phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) + phi_3 = phi*phi*phi + t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) + w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 + a = beta_rs(rs) /(gama * w_1) + g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 + h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) + ! interpolation function + + if(cst_1alph.gt.0.d0)then + fc_alpha = dexp(-c_1c * alpha * inv_1alph) + else + fc_alpha = - d_c * dexp(c_2c * inv_1alph) + endif + ! first part of the correlation energy + e_c_1 = e_c_lsda1 + h1 + + dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) + gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) + e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) + w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 + beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 + cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi + + x_inf = 0.128026d0 + f0 = -0.9d0 + g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 + + h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) + e_c_0 = (e_c_lsda0 + h0) * gc_xi + + ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) +end + + +double precision function beta_rs(rs) + implicit none + double precision, intent(in) ::rs + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) + +end + + +double precision function step_f(x) + implicit none + double precision, intent(in) :: x + if(x.lt.0.d0)then + step_f = 0.d0 + else + step_f = 1.d0 + endif +end diff --git a/src/dft_utils_one_e/mu_erf_dft.irp.f b/src/dft_utils_one_e/mu_erf_dft.irp.f index 3a3a2f28..53effcb6 100644 --- a/src/dft_utils_one_e/mu_erf_dft.irp.f +++ b/src/dft_utils_one_e/mu_erf_dft.irp.f @@ -1,7 +1,9 @@ BEGIN_PROVIDER [double precision, mu_erf_dft] implicit none BEGIN_DOC -! range separation parameter used in RS-DFT. It is set to mu_erf in order to be consistent with the two electrons integrals erf +! range separation parameter used in RS-DFT. +! +! It is set to mu_erf in order to be consistent with the module "ao_two_e_erf_ints" END_DOC mu_erf_dft = mu_erf diff --git a/src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f b/src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f index 272a49bb..919543fe 100644 --- a/src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f +++ b/src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f @@ -1,5 +1,10 @@ subroutine rho_ab_to_rho_oc(rho_a,rho_b,rho_o,rho_c) implicit none + BEGIN_DOC +! convert rho_alpha, rho_beta to rho_c, rho_o +! +! rho_c = total density, rho_o spin density + END_DOC double precision, intent(in) :: rho_a,rho_b double precision, intent(out) :: rho_o,rho_c rho_c=rho_a+rho_b @@ -8,6 +13,11 @@ end subroutine rho_oc_to_rho_ab(rho_o,rho_c,rho_a,rho_b) implicit none + BEGIN_DOC +! convert rho_c, rho_o to rho_alpha, rho_beta +! +! rho_c = total density, rho_o spin density + END_DOC double precision, intent(in) :: rho_o,rho_c double precision, intent(out) :: rho_a,rho_b rho_a= 0.5d0*(rho_c+rho_o) @@ -18,6 +28,13 @@ end subroutine grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,grad_rho_o_2,grad_rho_c_2,grad_rho_o_c) implicit none + BEGIN_DOC +! convert (grad_rho_a_2, grad_rho_b_2, grad_rho_a.grad_rho_b, ) +! +! to (grad_rho_c_2, grad_rho_o_2, grad_rho_o.grad_rho_c) +! +! rho_c = total density, rho_o spin density + END_DOC double precision, intent(in) :: grad_rho_a_2,grad_rho_b_2,grad_rho_a_b double precision, intent(out) :: grad_rho_o_2,grad_rho_c_2,grad_rho_o_c grad_rho_c_2 = grad_rho_a_2 + grad_rho_b_2 + 2d0*grad_rho_a_b @@ -28,6 +45,11 @@ end subroutine v_rho_ab_to_v_rho_oc(v_rho_a,v_rho_b,v_rho_o,v_rho_c) + BEGIN_DOC +! convert v_rho_alpha, v_rho_beta to v_rho_c, v_rho_o +! +! rho_c = total density, rho_o spin density + END_DOC implicit none double precision, intent(in) :: v_rho_a,v_rho_b double precision, intent(out) :: v_rho_o,v_rho_c @@ -37,6 +59,11 @@ end subroutine v_rho_oc_to_v_rho_ab(v_rho_o,v_rho_c,v_rho_a,v_rho_b) implicit none + BEGIN_DOC +! convert v_rho_alpha, v_rho_beta to v_rho_c, v_rho_o +! +! rho_c = total density, rho_o spin density + END_DOC double precision, intent(in) :: v_rho_o,v_rho_c double precision, intent(out) :: v_rho_a,v_rho_b v_rho_a = v_rho_c + v_rho_o @@ -47,6 +74,13 @@ end subroutine v_grad_rho_oc_to_v_grad_rho_ab(v_grad_rho_o_2,v_grad_rho_c_2,v_grad_rho_o_c,v_grad_rho_a_2,v_grad_rho_b_2,v_grad_rho_a_b) implicit none + BEGIN_DOC +! convert (v_grad_rho_c_2, v_grad_rho_o_2, v_grad_rho_o.grad_rho_c) +! +! to (v_grad_rho_a_2, v_grad_rho_b_2, v_grad_rho_a.grad_rho_b) +! +! rho_c = total density, rho_o spin density + END_DOC double precision, intent(in) :: v_grad_rho_o_2,v_grad_rho_c_2,v_grad_rho_o_c double precision, intent(out) :: v_grad_rho_a_2,v_grad_rho_b_2,v_grad_rho_a_b v_grad_rho_a_2 = v_grad_rho_o_2 + v_grad_rho_c_2 + v_grad_rho_o_c diff --git a/src/dft_utils_one_e/exc_sr_lda.irp.f b/src/dft_utils_one_e/routines_exc_sr_lda.irp.f similarity index 100% rename from src/dft_utils_one_e/exc_sr_lda.irp.f rename to src/dft_utils_one_e/routines_exc_sr_lda.irp.f diff --git a/src/dft_utils_one_e/exc_sr_pbe.irp.f b/src/dft_utils_one_e/routines_exc_sr_pbe.irp.f similarity index 96% rename from src/dft_utils_one_e/exc_sr_pbe.irp.f rename to src/dft_utils_one_e/routines_exc_sr_pbe.irp.f index 4188ebc6..fe4cb40e 100644 --- a/src/dft_utils_one_e/exc_sr_pbe.irp.f +++ b/src/dft_utils_one_e/routines_exc_sr_pbe.irp.f @@ -189,16 +189,27 @@ end subroutine ex_pbe_sr(mu,rho_a,rho_b,grd_rho_a_2,grd_rho_b_2,grd_rho_a_b,ex,vx_rho_a,vx_rho_b,vx_grd_rho_a_2,vx_grd_rho_b_2,vx_grd_rho_a_b) BEGIN_DOC !mu = range separation parameter +! !rho_a = density alpha +! !rho_b = density beta +! !grd_rho_a_2 = (gradient rho_a)^2 +! !grd_rho_b_2 = (gradient rho_b)^2 +! !grd_rho_a_b = (gradient rho_a).(gradient rho_b) +! !ex = exchange energy density at the density and corresponding gradients of the density +! !vx_rho_a = d ex / d rho_a +! !vx_rho_b = d ex / d rho_b +! !vx_grd_rho_a_2 = d ex / d grd_rho_a_2 +! !vx_grd_rho_b_2 = d ex / d grd_rho_b_2 +! !vx_grd_rho_a_b = d ex / d grd_rho_a_b END_DOC @@ -313,10 +324,15 @@ END_DOC subroutine ex_pbe_sr_only(mu,rho_a,rho_b,grd_rho_a_2,grd_rho_b_2,grd_rho_a_b,ex) BEGIN_DOC !rho_a = density alpha +! !rho_b = density beta +! !grd_rho_a_2 = (gradient rho_a)^2 +! !grd_rho_b_2 = (gradient rho_b)^2 +! !grd_rho_a_b = (gradient rho_a).(gradient rho_b) +! !ex = exchange energy density at point r END_DOC diff --git a/src/dft_utils_one_e/sr_exc.irp.f b/src/dft_utils_one_e/sr_exc.irp.f deleted file mode 100644 index 3c5a6db5..00000000 --- a/src/dft_utils_one_e/sr_exc.irp.f +++ /dev/null @@ -1,86 +0,0 @@ - - - BEGIN_PROVIDER[double precision, energy_sr_x_lda, (N_states) ] -&BEGIN_PROVIDER[double precision, energy_sr_c_lda, (N_states) ] - implicit none - BEGIN_DOC -! exchange/correlation energy with the short range lda functional - END_DOC - integer :: istate,i,j - double precision :: r(3) - double precision :: mu,weight - double precision :: e_c,vc_a,vc_b,e_x,vx_a,vx_b - double precision, allocatable :: rhoa(:),rhob(:) - allocate(rhoa(N_states), rhob(N_states)) - energy_sr_x_lda = 0.d0 - energy_sr_c_lda = 0.d0 - do istate = 1, N_states - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) - call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) - call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) - energy_sr_x_lda(istate) += weight * e_x - energy_sr_c_lda(istate) += weight * e_c - enddo - enddo - - END_PROVIDER - - BEGIN_PROVIDER[double precision, energy_sr_x_pbe, (N_states) ] -&BEGIN_PROVIDER[double precision, energy_sr_c_pbe, (N_states) ] - implicit none - BEGIN_DOC -! exchange/correlation energy with the short range pbe functional - END_DOC - integer :: istate,i,j,m - double precision :: r(3) - double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - - - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) - energy_sr_x_pbe = 0.d0 - energy_sr_c_pbe = 0.d0 - do istate = 1, N_states - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) - grad_rho_a_2 = 0.d0 - grad_rho_b_2 = 0.d0 - grad_rho_a_b = 0.d0 - do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) - enddo - - ! inputs - call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange - ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation - ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - energy_sr_x_pbe += ex * weight - energy_sr_c_pbe += ec * weight - enddo - enddo - - -END_PROVIDER - diff --git a/src/dft_utils_one_e/utils.irp.f b/src/dft_utils_one_e/utils.irp.f index 06ba4f30..21816fa8 100644 --- a/src/dft_utils_one_e/utils.irp.f +++ b/src/dft_utils_one_e/utils.irp.f @@ -1,58 +1,30 @@ -subroutine GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & +subroutine GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) implicit none BEGIN_DOC ! routine that helps in building the x/c potentials on the AO basis for a GGA functional with a short-range interaction END_DOC - double precision, intent(in) :: r(3),rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states) - double precision, intent(out) :: ex(N_states),vx_rho_a(N_states),vx_rho_b(N_states),vx_grad_rho_a_2(N_states),vx_grad_rho_b_2(N_states),vx_grad_rho_a_b(N_states) - double precision, intent(out) :: ec(N_states),vc_rho_a(N_states),vc_rho_b(N_states),vc_grad_rho_a_2(N_states),vc_grad_rho_b_2(N_states),vc_grad_rho_a_b(N_states) - integer :: istate - double precision :: r2(3),dr2(3), local_potential,r12,dx2,mu - do istate = 1, N_states - call ex_pbe_sr(mu_erf_dft,rho_a(istate),rho_b(istate),grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),ex(istate),vx_rho_a(istate),vx_rho_b(istate),vx_grad_rho_a_2(istate),vx_grad_rho_b_2(istate),vx_grad_rho_a_b(istate)) + double precision, intent(in) :: mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision, intent(out) :: ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b + double precision, intent(out) :: ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b + double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo - double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo - ! convertion from (alpha,beta) formalism to (closed, open) formalism - call rho_ab_to_rho_oc(rho_a(istate),rho_b(istate),rhoo,rhoc) - call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),sigmaoo,sigmacc,sigmaco) - call ec_pbe_sr(mu_erf_dft,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec(istate),vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo) + ! exhange energy and potentials + call ex_pbe_sr(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b) - call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a(istate),vc_rho_b(istate)) - call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2(istate),vc_grad_rho_b_2(istate),vc_grad_rho_a_b(istate)) - enddo + ! convertion from (alpha,beta) formalism to (closed, open) formalism + call rho_ab_to_rho_oc(rho_a,rho_b,rhoo,rhoc) + call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2,grad_rho_b_2,grad_rho_a_b,sigmaoo,sigmacc,sigmaco) + + ! correlation energy and potentials + call ec_pbe_sr(mu,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo) + + ! convertion from (closed, open) formalism to (alpha,beta) formalism + call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a,vc_rho_b) + call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b) end -subroutine GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & - ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & - ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - implicit none - BEGIN_DOC - ! routine that helps in building the x/c potentials on the AO basis for a GGA functional - END_DOC - double precision, intent(in) :: r(3),rho_a(N_states),rho_b(N_states),grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states) - double precision, intent(out) :: ex(N_states),vx_rho_a(N_states),vx_rho_b(N_states),vx_grad_rho_a_2(N_states),vx_grad_rho_b_2(N_states),vx_grad_rho_a_b(N_states) - double precision, intent(out) :: ec(N_states),vc_rho_a(N_states),vc_rho_b(N_states),vc_grad_rho_a_2(N_states),vc_grad_rho_b_2(N_states),vc_grad_rho_a_b(N_states) - integer :: istate - double precision :: r2(3),dr2(3), local_potential,r12,dx2 - double precision :: mu_local - mu_local = 1.d-9 - do istate = 1, N_states - call ex_pbe_sr(mu_local,rho_a(istate),rho_b(istate),grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),ex(istate),vx_rho_a(istate),vx_rho_b(istate),vx_grad_rho_a_2(istate),vx_grad_rho_b_2(istate),vx_grad_rho_a_b(istate)) - - double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo - ! convertion from (alpha,beta) formalism to (closed, open) formalism - call rho_ab_to_rho_oc(rho_a(istate),rho_b(istate),rhoo,rhoc) - call grad_rho_ab_to_grad_rho_oc(grad_rho_a_2(istate),grad_rho_b_2(istate),grad_rho_a_b(istate),sigmaoo,sigmacc,sigmaco) - - call ec_pbe_sr(mu_local,rhoc,rhoo,sigmacc,sigmaco,sigmaoo,ec(istate),vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo) - - call v_rho_oc_to_v_rho_ab(vrhoo,vrhoc,vc_rho_a(istate),vc_rho_b(istate)) - call v_grad_rho_oc_to_v_grad_rho_ab(vsigmaoo,vsigmacc,vsigmaco,vc_grad_rho_a_2(istate),vc_grad_rho_b_2(istate),vc_grad_rho_a_b(istate)) - enddo -end - diff --git a/src/functionals/lda.irp.f b/src/functionals/lda.irp.f index 73bb8e5c..ef935d9b 100644 --- a/src/functionals/lda.irp.f +++ b/src/functionals/lda.irp.f @@ -19,8 +19,8 @@ r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ex_lda(rhoa(istate),rhob(istate),e_x,vx_a,vx_b) energy_x_lda(istate) += weight * e_x enddo @@ -46,8 +46,8 @@ r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda(rhoa(istate),rhob(istate),e_c,vc_a,vc_b) energy_c_lda(istate) += weight * e_c enddo @@ -142,8 +142,8 @@ END_PROVIDER r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) do j =1, ao_num @@ -181,8 +181,8 @@ END_PROVIDER r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) do j =1, ao_num diff --git a/src/functionals/pbe.irp.f b/src/functionals/pbe.irp.f index f6122f89..23b3925b 100644 --- a/src/functionals/pbe.irp.f +++ b/src/functionals/pbe.irp.f @@ -1,114 +1,63 @@ - BEGIN_PROVIDER[double precision, energy_x_pbe, (N_states) ] +&BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ] implicit none BEGIN_DOC + ! exchange / correlation energies with the short-range version Perdew-Burke-Ernzerhof GGA functional + ! + ! defined in Chem. Phys.329, 276 (2006) + END_DOC + BEGIN_DOC ! exchange/correlation energy with the short range pbe functional END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) energy_x_pbe = 0.d0 - do istate = 1, N_states - do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) - weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) - grad_rho_a_2 = 0.d0 - grad_rho_b_2 = 0.d0 - grad_rho_a_b = 0.d0 - do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) - enddo - - ! inputs - call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange - ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation - ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - energy_x_pbe += ex * weight - enddo - enddo - - -END_PROVIDER - -BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ] - implicit none - BEGIN_DOC -! exchange/correlation energy with the short range pbe functional - END_DOC - integer :: istate,i,j,m - double precision :: r(3) - double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - - - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) energy_c_pbe = 0.d0 + mu = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - energy_c_pbe += ec * weight + energy_x_pbe(istate) += ex * weight + energy_c_pbe(istate) += ec * weight enddo enddo END_PROVIDER - - BEGIN_PROVIDER [double precision, potential_x_alpha_ao_pbe,(ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, potential_x_beta_ao_pbe,(ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, potential_c_alpha_ao_pbe,(ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, potential_c_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none BEGIN_DOC - ! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional + ! exchange / correlation potential for alpha / beta electrons with the short-range version Perdew-Burke-Ernzerhof GGA functional + ! + ! defined in Chem. Phys.329, 276 (2006) END_DOC integer :: i,j,istate do istate = 1, n_states @@ -125,8 +74,6 @@ END_PROVIDER END_PROVIDER - - BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, potential_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none @@ -138,7 +85,7 @@ END_PROVIDER do i = 1, ao_num do j = 1, ao_num potential_xc_alpha_ao_pbe(j,i,istate) = pot_scal_xc_alpha_ao_pbe(j,i,istate) + pot_grad_xc_alpha_ao_pbe(j,i,istate) + pot_grad_xc_alpha_ao_pbe(i,j,istate) - potential_xc_beta_ao_pbe(j,i,istate) = pot_scal_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(i,j,istate) + potential_xc_beta_ao_pbe(j,i,istate) = pot_scal_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(j,i,istate) + pot_grad_xc_beta_ao_pbe(i,j,istate) enddo enddo enddo @@ -146,82 +93,76 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER[double precision, aos_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] implicit none BEGIN_DOC +! intermediates to compute the sr_pbe potentials +! ! aos_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) - allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states)) - - aos_dvc_alpha_pbe_w = 0.d0 - aos_dvc_beta_pbe_w = 0.d0 - aos_dvx_alpha_pbe_w = 0.d0 - aos_dvx_beta_pbe_w = 0.d0 - + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3) + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b + aos_d_vc_alpha_pbe_w= 0.d0 + aos_d_vc_beta_pbe_w = 0.d0 + aos_d_vx_alpha_pbe_w= 0.d0 + aos_d_vx_beta_pbe_w = 0.d0 + mu = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - vx_rho_a(istate) *= weight - vc_rho_a(istate) *= weight - vx_rho_b(istate) *= weight - vc_rho_b(istate) *= weight + vx_rho_a *= weight + vc_rho_a *= weight + vx_rho_b *= weight + vc_rho_b *= weight do m= 1,3 - contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate)) - contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate)) + contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) ) + contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) ) enddo do j = 1, ao_num - aos_vc_alpha_pbe_w(j,i,istate) = vc_rho_a(istate) * aos_in_r_array(j,i) - aos_vc_beta_pbe_w (j,i,istate) = vc_rho_b(istate) * aos_in_r_array(j,i) - aos_vx_alpha_pbe_w(j,i,istate) = vx_rho_a(istate) * aos_in_r_array(j,i) - aos_vx_beta_pbe_w (j,i,istate) = vx_rho_b(istate) * aos_in_r_array(j,i) + aos_vc_alpha_pbe_w(j,i,istate) = vc_rho_a * aos_in_r_array(j,i) + aos_vc_beta_pbe_w (j,i,istate) = vc_rho_b * aos_in_r_array(j,i) + aos_vx_alpha_pbe_w(j,i,istate) = vx_rho_a * aos_in_r_array(j,i) + aos_vx_beta_pbe_w (j,i,istate) = vx_rho_b * aos_in_r_array(j,i) enddo do j = 1, ao_num do m = 1,3 - aos_dvc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dvc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dvx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dvx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m) * aos_grad_in_r_array_transp_xyz(m,j,i) enddo enddo enddo @@ -235,6 +176,8 @@ END_PROVIDER &BEGIN_PROVIDER [double precision, pot_scal_x_beta_ao_pbe, (ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, pot_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)] implicit none +! intermediates to compute the sr_pbe potentials +! integer :: istate BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential @@ -247,24 +190,24 @@ END_PROVIDER call wall_time(wall_1) do istate = 1, N_states ! correlation alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vc_alpha_pbe_w(1,1,istate),size(aos_vc_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vc_alpha_pbe_w(1,1,istate),size(aos_vc_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_c_alpha_ao_pbe(1,1,istate),size(pot_scal_c_alpha_ao_pbe,1)) ! correlation beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vc_beta_pbe_w(1,1,istate),size(aos_vc_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vc_beta_pbe_w(1,1,istate),size(aos_vc_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_c_beta_ao_pbe(1,1,istate),size(pot_scal_c_beta_ao_pbe,1)) ! exchange alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vx_alpha_pbe_w(1,1,istate),size(aos_vx_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vx_alpha_pbe_w(1,1,istate),size(aos_vx_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_x_alpha_ao_pbe(1,1,istate),size(pot_scal_x_alpha_ao_pbe,1)) ! exchange beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vx_beta_pbe_w(1,1,istate),size(aos_vx_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vx_beta_pbe_w(1,1,istate),size(aos_vx_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_x_beta_ao_pbe(1,1,istate), size(pot_scal_x_beta_ao_pbe,1)) enddo @@ -290,24 +233,24 @@ END_PROVIDER pot_grad_x_beta_ao_pbe = 0.d0 do istate = 1, N_states ! correlation alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvc_alpha_pbe_w(1,1,istate),size(aos_dvc_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vc_alpha_pbe_w(1,1,istate),size(aos_d_vc_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_c_alpha_ao_pbe(1,1,istate),size(pot_grad_c_alpha_ao_pbe,1)) ! correlation beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvc_beta_pbe_w(1,1,istate),size(aos_dvc_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vc_beta_pbe_w(1,1,istate),size(aos_d_vc_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_c_beta_ao_pbe(1,1,istate),size(pot_grad_c_beta_ao_pbe,1)) ! exchange alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvx_alpha_pbe_w(1,1,istate),size(aos_dvx_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vx_alpha_pbe_w(1,1,istate),size(aos_d_vx_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_x_alpha_ao_pbe(1,1,istate),size(pot_grad_x_alpha_ao_pbe,1)) ! exchange beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvx_beta_pbe_w(1,1,istate),size(aos_dvx_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vx_beta_pbe_w(1,1,istate),size(aos_d_vx_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_x_beta_ao_pbe(1,1,istate),size(pot_grad_x_beta_ao_pbe,1)) enddo @@ -318,70 +261,62 @@ END_PROVIDER BEGIN_PROVIDER[double precision, aos_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dvxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_d_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] implicit none BEGIN_DOC ! aos_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) - allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states)) + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3) + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b - aos_dvxc_alpha_pbe_w = 0.d0 - aos_dvxc_beta_pbe_w = 0.d0 + mu = 0.d0 + aos_d_vxc_alpha_pbe_w = 0.d0 + aos_d_vxc_beta_pbe_w = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - vx_rho_a(istate) *= weight - vc_rho_a(istate) *= weight - vx_rho_b(istate) *= weight - vc_rho_b(istate) *= weight + vx_rho_a *= weight + vc_rho_a *= weight + vx_rho_b *= weight + vc_rho_b *= weight do m= 1,3 - contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate)) - contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate)) + contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) ) + contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) ) enddo do j = 1, ao_num - aos_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a(istate) + vx_rho_a(istate) ) * aos_in_r_array(j,i) - aos_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b(istate) + vx_rho_b(istate) ) * aos_in_r_array(j,i) + aos_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a + vx_rho_a ) * aos_in_r_array(j,i) + aos_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b + vx_rho_b ) * aos_in_r_array(j,i) enddo do j = 1, ao_num do m = 1,3 - aos_dvxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m,istate) + contrib_grad_xa(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dvxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m,istate) + contrib_grad_xb(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m) + contrib_grad_xa(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_d_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m) + contrib_grad_xb(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i) enddo enddo enddo @@ -403,14 +338,14 @@ END_PROVIDER call wall_time(wall_1) do istate = 1, N_states ! exchange - correlation alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vxc_alpha_pbe_w(1,1,istate),size(aos_vxc_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vxc_alpha_pbe_w(1,1,istate),size(aos_vxc_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_scal_xc_alpha_ao_pbe,1)) ! exchange - correlation beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_vxc_beta_pbe_w(1,1,istate),size(aos_vxc_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_vxc_beta_pbe_w(1,1,istate),size(aos_vxc_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_scal_xc_beta_ao_pbe(1,1,istate),size(pot_scal_xc_beta_ao_pbe,1)) enddo call wall_time(wall_2) @@ -430,18 +365,19 @@ END_PROVIDER pot_grad_xc_alpha_ao_pbe = 0.d0 pot_grad_xc_beta_ao_pbe = 0.d0 do istate = 1, N_states - ! correlation alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvxc_alpha_pbe_w(1,1,istate),size(aos_dvxc_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + ! exchange - correlation alpha + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vxc_alpha_pbe_w(1,1,istate),size(aos_d_vxc_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_grad_xc_alpha_ao_pbe,1)) - ! correlation beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dvxc_beta_pbe_w(1,1,istate),size(aos_dvxc_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + ! exchange - correlation beta + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_d_vxc_beta_pbe_w(1,1,istate),size(aos_d_vxc_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_grad_xc_beta_ao_pbe(1,1,istate),size(pot_grad_xc_beta_ao_pbe,1)) enddo call wall_time(wall_2) END_PROVIDER + diff --git a/src/functionals/sr_lda.irp.f b/src/functionals/sr_lda.irp.f index 0e009542..965a744c 100644 --- a/src/functionals/sr_lda.irp.f +++ b/src/functionals/sr_lda.irp.f @@ -19,8 +19,8 @@ r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,vx_a,vx_b) energy_x_sr_lda(istate) += weight * e_x enddo @@ -46,8 +46,8 @@ r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,vc_a,vc_b) energy_c_sr_lda(istate) += weight * e_c enddo @@ -120,8 +120,8 @@ END_PROVIDER r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) call ex_lda_sr(mu_erf_dft,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num @@ -156,8 +156,8 @@ END_PROVIDER r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rhoa(istate) = one_e_dm_alpha_at_r(i,istate) - rhob(istate) = one_e_dm_beta_at_r(i,istate) + rhoa(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rhob(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) call ec_lda_sr(mu_local,rhoa(istate),rhob(istate),e_c,sr_vc_a,sr_vc_b) call ex_lda_sr(mu_local,rhoa(istate),rhob(istate),e_x,sr_vx_a,sr_vx_b) do j =1, ao_num diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index c0cd3cd1..af202cfb 100644 --- a/src/functionals/sr_pbe.irp.f +++ b/src/functionals/sr_pbe.irp.f @@ -3,55 +3,95 @@ &BEGIN_PROVIDER[double precision, energy_c_sr_pbe, (N_states) ] implicit none BEGIN_DOC + ! exchange / correlation energies with the short-range version Perdew-Burke-Ernzerhof GGA functional + ! + ! defined in Chem. Phys.329, 276 (2006) + END_DOC + BEGIN_DOC ! exchange/correlation energy with the short range pbe functional END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) energy_x_sr_pbe = 0.d0 energy_c_sr_pbe = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - energy_x_sr_pbe += ex * weight - energy_c_sr_pbe += ec * weight + energy_x_sr_pbe(istate) += ex * weight + energy_c_sr_pbe(istate) += ec * weight enddo enddo END_PROVIDER + BEGIN_PROVIDER [double precision, potential_x_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, potential_x_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, potential_c_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, potential_c_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] + implicit none + BEGIN_DOC + ! exchange / correlation potential for alpha / beta electrons with the short-range version Perdew-Burke-Ernzerhof GGA functional + ! + ! defined in Chem. Phys.329, 276 (2006) + END_DOC + integer :: i,j,istate + do istate = 1, n_states + do i = 1, ao_num + do j = 1, ao_num + potential_x_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(i,j,istate) + potential_x_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(i,j,istate) + + potential_c_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(i,j,istate) + potential_c_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(i,j,istate) + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, potential_xc_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] + implicit none + BEGIN_DOC + ! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional + END_DOC + integer :: i,j,istate + do istate = 1, n_states + do i = 1, ao_num + do j = 1, ao_num + potential_xc_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(i,j,istate) + potential_xc_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(i,j,istate) + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER[double precision, aos_sr_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_sr_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] @@ -63,72 +103,64 @@ END_PROVIDER &BEGIN_PROVIDER[double precision, aos_dsr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] implicit none BEGIN_DOC +! intermediates to compute the sr_pbe potentials +! ! aos_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - - - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) - allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states)) + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3) + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b aos_dsr_vc_alpha_pbe_w= 0.d0 aos_dsr_vc_beta_pbe_w = 0.d0 aos_dsr_vx_alpha_pbe_w= 0.d0 aos_dsr_vx_beta_pbe_w = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - vx_rho_a(istate) *= weight - vc_rho_a(istate) *= weight - vx_rho_b(istate) *= weight - vc_rho_b(istate) *= weight + vx_rho_a *= weight + vc_rho_a *= weight + vx_rho_b *= weight + vc_rho_b *= weight do m= 1,3 - contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate)) - contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate)) + contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) ) + contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) ) enddo do j = 1, ao_num - aos_sr_vc_alpha_pbe_w(j,i,istate) = vc_rho_a(istate) * aos_in_r_array(j,i) - aos_sr_vc_beta_pbe_w (j,i,istate) = vc_rho_b(istate) * aos_in_r_array(j,i) - aos_sr_vx_alpha_pbe_w(j,i,istate) = vx_rho_a(istate) * aos_in_r_array(j,i) - aos_sr_vx_beta_pbe_w (j,i,istate) = vx_rho_b(istate) * aos_in_r_array(j,i) + aos_sr_vc_alpha_pbe_w(j,i,istate) = vc_rho_a * aos_in_r_array(j,i) + aos_sr_vc_beta_pbe_w (j,i,istate) = vc_rho_b * aos_in_r_array(j,i) + aos_sr_vx_alpha_pbe_w(j,i,istate) = vx_rho_a * aos_in_r_array(j,i) + aos_sr_vx_beta_pbe_w (j,i,istate) = vx_rho_b * aos_in_r_array(j,i) enddo do j = 1, ao_num do m = 1,3 - aos_dsr_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dsr_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dsr_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dsr_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m,istate) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vc_alpha_pbe_w(j,i,istate) += contrib_grad_ca(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vc_beta_pbe_w (j,i,istate) += contrib_grad_cb(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vx_alpha_pbe_w(j,i,istate) += contrib_grad_xa(m) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vx_beta_pbe_w (j,i,istate) += contrib_grad_xb(m) * aos_grad_in_r_array_transp_xyz(m,j,i) enddo enddo enddo @@ -142,6 +174,8 @@ END_PROVIDER &BEGIN_PROVIDER [double precision, pot_sr_scal_x_beta_ao_pbe, (ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, pot_sr_scal_c_beta_ao_pbe, (ao_num,ao_num,N_states)] implicit none +! intermediates to compute the sr_pbe potentials +! integer :: istate BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential @@ -154,24 +188,24 @@ END_PROVIDER call wall_time(wall_1) do istate = 1, N_states ! correlation alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vc_alpha_pbe_w(1,1,istate),size(aos_sr_vc_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vc_alpha_pbe_w(1,1,istate),size(aos_sr_vc_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_c_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_c_alpha_ao_pbe,1)) ! correlation beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vc_beta_pbe_w(1,1,istate),size(aos_sr_vc_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vc_beta_pbe_w(1,1,istate),size(aos_sr_vc_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_c_beta_ao_pbe(1,1,istate),size(pot_sr_scal_c_beta_ao_pbe,1)) ! exchange alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vx_alpha_pbe_w(1,1,istate),size(aos_sr_vx_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vx_alpha_pbe_w(1,1,istate),size(aos_sr_vx_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_x_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_x_alpha_ao_pbe,1)) ! exchange beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vx_beta_pbe_w(1,1,istate),size(aos_sr_vx_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vx_beta_pbe_w(1,1,istate),size(aos_sr_vx_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_x_beta_ao_pbe(1,1,istate), size(pot_sr_scal_x_beta_ao_pbe,1)) enddo @@ -197,24 +231,24 @@ END_PROVIDER pot_sr_grad_x_beta_ao_pbe = 0.d0 do istate = 1, N_states ! correlation alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vc_alpha_pbe_w(1,1,istate),size(aos_dsr_vc_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vc_alpha_pbe_w(1,1,istate),size(aos_dsr_vc_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_c_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_c_alpha_ao_pbe,1)) ! correlation beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vc_beta_pbe_w(1,1,istate),size(aos_dsr_vc_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vc_beta_pbe_w(1,1,istate),size(aos_dsr_vc_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_c_beta_ao_pbe(1,1,istate),size(pot_sr_grad_c_beta_ao_pbe,1)) ! exchange alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vx_alpha_pbe_w(1,1,istate),size(aos_dsr_vx_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vx_alpha_pbe_w(1,1,istate),size(aos_dsr_vx_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_x_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_x_alpha_ao_pbe,1)) ! exchange beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vx_beta_pbe_w(1,1,istate),size(aos_dsr_vx_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vx_beta_pbe_w(1,1,istate),size(aos_dsr_vx_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_x_beta_ao_pbe(1,1,istate),size(pot_sr_grad_x_beta_ao_pbe,1)) enddo @@ -222,29 +256,6 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, potential_x_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, potential_x_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, potential_c_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, potential_c_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] - implicit none - BEGIN_DOC - ! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional - END_DOC - integer :: i,j,istate - do istate = 1, n_states - do i = 1, ao_num - do j = 1, ao_num - potential_x_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(j,i,istate) + pot_sr_grad_x_alpha_ao_pbe(i,j,istate) - potential_x_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(j,i,istate) + pot_sr_grad_x_beta_ao_pbe(i,j,istate) - - potential_c_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(j,i,istate) + pot_sr_grad_c_alpha_ao_pbe(i,j,istate) - potential_c_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(j,i,istate) + pot_sr_grad_c_beta_ao_pbe(i,j,istate) - enddo - enddo - enddo - -END_PROVIDER - BEGIN_PROVIDER[double precision, aos_sr_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] &BEGIN_PROVIDER[double precision, aos_sr_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] @@ -255,65 +266,54 @@ END_PROVIDER ! aos_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) END_DOC integer :: istate,i,j,m - double precision :: r(3) double precision :: mu,weight - double precision, allocatable :: ex(:), ec(:) - double precision, allocatable :: rho_a(:),rho_b(:),grad_rho_a(:,:),grad_rho_b(:,:),grad_rho_a_2(:),grad_rho_b_2(:),grad_rho_a_b(:) - double precision, allocatable :: contrib_grad_xa(:,:),contrib_grad_xb(:,:),contrib_grad_ca(:,:),contrib_grad_cb(:,:) - double precision, allocatable :: vc_rho_a(:), vc_rho_b(:), vx_rho_a(:), vx_rho_b(:) - double precision, allocatable :: vx_grad_rho_a_2(:), vx_grad_rho_b_2(:), vx_grad_rho_a_b(:), vc_grad_rho_a_2(:), vc_grad_rho_b_2(:), vc_grad_rho_a_b(:) - allocate(vc_rho_a(N_states), vc_rho_b(N_states), vx_rho_a(N_states), vx_rho_b(N_states)) - allocate(vx_grad_rho_a_2(N_states), vx_grad_rho_b_2(N_states), vx_grad_rho_a_b(N_states), vc_grad_rho_a_2(N_states), vc_grad_rho_b_2(N_states), vc_grad_rho_a_b(N_states)) - - - allocate(rho_a(N_states), rho_b(N_states),grad_rho_a(3,N_states),grad_rho_b(3,N_states)) - allocate(grad_rho_a_2(N_states),grad_rho_b_2(N_states),grad_rho_a_b(N_states), ex(N_states), ec(N_states)) - allocate(contrib_grad_xa(3,N_states),contrib_grad_xb(3,N_states),contrib_grad_ca(3,N_states),contrib_grad_cb(3,N_states)) + double precision :: ex, ec + double precision :: rho_a,rho_b,grad_rho_a(3),grad_rho_b(3),grad_rho_a_2,grad_rho_b_2,grad_rho_a_b + double precision :: contrib_grad_xa(3),contrib_grad_xb(3),contrib_grad_ca(3),contrib_grad_cb(3) + double precision :: vc_rho_a, vc_rho_b, vx_rho_a, vx_rho_b + double precision :: vx_grad_rho_a_2, vx_grad_rho_b_2, vx_grad_rho_a_b, vc_grad_rho_a_2, vc_grad_rho_b_2, vc_grad_rho_a_b aos_dsr_vxc_alpha_pbe_w = 0.d0 aos_dsr_vxc_beta_pbe_w = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid - r(1) = final_grid_points(1,i) - r(2) = final_grid_points(2,i) - r(3) = final_grid_points(3,i) weight = final_weight_at_r_vector(i) - rho_a(istate) = one_e_dm_and_grad_alpha_in_r(4,i,istate) - rho_b(istate) = one_e_dm_and_grad_beta_in_r(4,i,istate) - grad_rho_a(1:3,istate) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) - grad_rho_b(1:3,istate) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) + rho_a = one_e_dm_and_grad_alpha_in_r(4,i,istate) + rho_b = one_e_dm_and_grad_beta_in_r(4,i,istate) + grad_rho_a(1:3) = one_e_dm_and_grad_alpha_in_r(1:3,i,istate) + grad_rho_b(1:3) = one_e_dm_and_grad_beta_in_r(1:3,i,istate) grad_rho_a_2 = 0.d0 grad_rho_b_2 = 0.d0 grad_rho_a_b = 0.d0 do m = 1, 3 - grad_rho_a_2(istate) += grad_rho_a(m,istate) * grad_rho_a(m,istate) - grad_rho_b_2(istate) += grad_rho_b(m,istate) * grad_rho_b(m,istate) - grad_rho_a_b(istate) += grad_rho_a(m,istate) * grad_rho_b(m,istate) + grad_rho_a_2 += grad_rho_a(m) * grad_rho_a(m) + grad_rho_b_2 += grad_rho_b(m) * grad_rho_b(m) + grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo ! inputs - call GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange + call GGA_sr_type_functionals(mu_erf_dft,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! outputs exchange ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs correlation ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) - vx_rho_a(istate) *= weight - vc_rho_a(istate) *= weight - vx_rho_b(istate) *= weight - vc_rho_b(istate) *= weight + vx_rho_a *= weight + vc_rho_a *= weight + vx_rho_b *= weight + vc_rho_b *= weight do m= 1,3 - contrib_grad_ca(m,istate) = weight * (2.d0 * vc_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_xa(m,istate) = weight * (2.d0 * vx_grad_rho_a_2(istate) * grad_rho_a(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_b(m,istate)) - contrib_grad_cb(m,istate) = weight * (2.d0 * vc_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vc_grad_rho_a_b(istate) * grad_rho_a(m,istate)) - contrib_grad_xb(m,istate) = weight * (2.d0 * vx_grad_rho_b_2(istate) * grad_rho_b(m,istate) + vx_grad_rho_a_b(istate) * grad_rho_a(m,istate)) + contrib_grad_ca(m) = weight * (2.d0 * vc_grad_rho_a_2 * grad_rho_a(m) + vc_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_xa(m) = weight * (2.d0 * vx_grad_rho_a_2 * grad_rho_a(m) + vx_grad_rho_a_b * grad_rho_b(m) ) + contrib_grad_cb(m) = weight * (2.d0 * vc_grad_rho_b_2 * grad_rho_b(m) + vc_grad_rho_a_b * grad_rho_a(m) ) + contrib_grad_xb(m) = weight * (2.d0 * vx_grad_rho_b_2 * grad_rho_b(m) + vx_grad_rho_a_b * grad_rho_a(m) ) enddo do j = 1, ao_num - aos_sr_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a(istate) + vx_rho_a(istate) ) * aos_in_r_array(j,i) - aos_sr_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b(istate) + vx_rho_b(istate) ) * aos_in_r_array(j,i) + aos_sr_vxc_alpha_pbe_w(j,i,istate) = ( vc_rho_a + vx_rho_a ) * aos_in_r_array(j,i) + aos_sr_vxc_beta_pbe_w (j,i,istate) = ( vc_rho_b + vx_rho_b ) * aos_in_r_array(j,i) enddo do j = 1, ao_num do m = 1,3 - aos_dsr_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m,istate) + contrib_grad_xa(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i) - aos_dsr_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m,istate) + contrib_grad_xb(m,istate) ) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vxc_alpha_pbe_w(j,i,istate) += ( contrib_grad_ca(m) + contrib_grad_xa(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i) + aos_dsr_vxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m) + contrib_grad_xb(m) ) * aos_grad_in_r_array_transp_xyz(m,j,i) enddo enddo enddo @@ -335,14 +335,14 @@ END_PROVIDER call wall_time(wall_1) do istate = 1, N_states ! exchange - correlation alpha - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vxc_alpha_pbe_w(1,1,istate),size(aos_sr_vxc_alpha_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vxc_alpha_pbe_w(1,1,istate),size(aos_sr_vxc_alpha_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_xc_alpha_ao_pbe,1)) ! exchange - correlation beta - call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_sr_vxc_beta_pbe_w(1,1,istate),size(aos_sr_vxc_beta_pbe_w,1), & - aos_in_r_array,size(aos_in_r_array,1),1.d0, & + call dgemm('N','T',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_sr_vxc_beta_pbe_w(1,1,istate),size(aos_sr_vxc_beta_pbe_w,1), & + aos_in_r_array,size(aos_in_r_array,1),1.d0, & pot_sr_scal_xc_beta_ao_pbe(1,1,istate),size(pot_sr_scal_xc_beta_ao_pbe,1)) enddo call wall_time(wall_2) @@ -363,14 +363,14 @@ END_PROVIDER pot_sr_grad_xc_beta_ao_pbe = 0.d0 do istate = 1, N_states ! exchange - correlation alpha - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vxc_alpha_pbe_w(1,1,istate),size(aos_dsr_vxc_alpha_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vxc_alpha_pbe_w(1,1,istate),size(aos_dsr_vxc_alpha_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_xc_alpha_ao_pbe,1)) ! exchange - correlation beta - call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & - aos_dsr_vxc_beta_pbe_w(1,1,istate),size(aos_dsr_vxc_beta_pbe_w,1), & - aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & + call dgemm('N','N',ao_num,ao_num,n_points_final_grid,1.d0, & + aos_dsr_vxc_beta_pbe_w(1,1,istate),size(aos_dsr_vxc_beta_pbe_w,1), & + aos_in_r_array_transp,size(aos_in_r_array_transp,1),1.d0, & pot_sr_grad_xc_beta_ao_pbe(1,1,istate),size(pot_sr_grad_xc_beta_ao_pbe,1)) enddo @@ -378,20 +378,3 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, potential_xc_alpha_ao_sr_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, potential_xc_beta_ao_sr_pbe,(ao_num,ao_num,N_states)] - implicit none - BEGIN_DOC - ! exchange / correlation potential for alpha / beta electrons with the Perdew-Burke-Ernzerhof GGA functional - END_DOC - integer :: i,j,istate - do istate = 1, n_states - do i = 1, ao_num - do j = 1, ao_num - potential_xc_alpha_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(j,i,istate) + pot_sr_grad_xc_alpha_ao_pbe(i,j,istate) - potential_xc_beta_ao_sr_pbe(j,i,istate) = pot_sr_scal_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(j,i,istate) + pot_sr_grad_xc_beta_ao_pbe(i,j,istate) - enddo - enddo - enddo - -END_PROVIDER diff --git a/src/hartree_fock/10.hf.bats b/src/hartree_fock/10.hf.bats index a45d5daf..4b750c87 100644 --- a/src/hartree_fock/10.hf.bats +++ b/src/hartree_fock/10.hf.bats @@ -11,7 +11,7 @@ function run() { qp edit --check qp reset --mos qp run scf - qp set_frozen_core +# qp set_frozen_core energy="$(ezfio get hartree_fock energy)" eq $energy $2 $thresh } diff --git a/src/mo_one_e_ints/EZFIO.cfg b/src/mo_one_e_ints/EZFIO.cfg index 1cb77b6e..0f31b16a 100644 --- a/src/mo_one_e_ints/EZFIO.cfg +++ b/src/mo_one_e_ints/EZFIO.cfg @@ -24,7 +24,6 @@ interface: ezfio,provider,ocaml default: None - [mo_integrals_pseudo] type: double precision doc: Pseudopotential integrals in |MO| basis set diff --git a/src/two_body_rdm/EZFIO.cfg b/src/two_body_rdm/EZFIO.cfg new file mode 100644 index 00000000..4ca39d73 --- /dev/null +++ b/src/two_body_rdm/EZFIO.cfg @@ -0,0 +1,48 @@ +[two_rdm_ab_disk] +type: double precision +doc: active part of the two body rdm alpha/beta stored on disk +interface: ezfio +size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states) + +[io_two_body_rdm_ab] +type: Disk_access +doc: Read/Write the active part of the two-body rdm for alpha/beta electrons from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[two_rdm_aa_disk] +type: double precision +doc: active part of the two body rdm alpha/alpha stored on disk +interface: ezfio +size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states) + +[io_two_body_rdm_aa] +type: Disk_access +doc: Read/Write the active part of the two-body rdm for alpha/alpha electrons from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[two_rdm_bb_disk] +type: double precision +doc: active part of the two body rdm beta/beta stored on disk +interface: ezfio +size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states) + +[io_two_body_rdm_bb] +type: Disk_access +doc: Read/Write the active part of the two-body rdm for beta/beta electrons from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[two_rdm_spin_trace_disk] +type: double precision +doc: active part of the two body rdm spin trace stored on disk +interface: ezfio +size: (bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,bitmask.n_act_orb,determinants.n_states) + +[io_two_body_rdm_spin_trace] +type: Disk_access +doc: Read/Write the active part of the two-body rdm for spin trace electrons from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED index 711fbf96..221550d2 100644 --- a/src/two_body_rdm/NEED +++ b/src/two_body_rdm/NEED @@ -1 +1,2 @@ -davidson_undressed +two_rdm_routines +density_for_dft diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index 978240c9..c82f7b0a 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -3,6 +3,6 @@ two_body_rdm ============ Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as -arrays, with pysicists notation, consistent with the two-electron integrals in the -MO basis. +arrays, with pysicists notation, consistent with the two-electron integrals in the MO basis. + diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f deleted file mode 100644 index fb3c421c..00000000 --- a/src/two_body_rdm/ab_only_routines.irp.f +++ /dev/null @@ -1,402 +0,0 @@ - - subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - integer, intent(in) :: N_st,sze - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: u_0(sze,N_st) - integer :: k - double precision, allocatable :: u_t(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate(u_t(N_st,N_det)) - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) - enddo - call dtranspose( & - u_0, & - size(u_0, 1), & - u_t, & - size(u_t, 1), & - N_det, N_st) - - call two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) - deallocate(u_t) - - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) - enddo - - end - - - subroutine two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes the alpha/beta part of the two-body density matrix - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - double precision, intent(in) :: u_t(N_st,N_det) - - - PROVIDE N_int - - select case (N_int) - case (1) - call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (2) - call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (3) - call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (4) - call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case default - call two_rdm_ab_nstates_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - end select - end - BEGIN_TEMPLATE - - subroutine two_rdm_ab_nstates_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - double precision, intent(in) :: u_t(N_st,N_det) - - double precision :: hij, sij - integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b - integer :: lrow, lcol - integer :: mrow, mcol - integer(bit_kind) :: spindet($N_int) - integer(bit_kind) :: tmp_det($N_int,2) - integer(bit_kind) :: tmp_det2($N_int,2) - integer(bit_kind) :: tmp_det3($N_int,2) - integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_doubles - integer, allocatable :: doubles(:) - integer, allocatable :: singles_a(:) - integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), idx0(:) - integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax - integer*8 :: k8 - - maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 - allocate(idx0(maxab)) - - do i=1,maxab - idx0(i) = i - enddo - - ! Prepare the array of all alpha single excitations - ! ------------------------------------------------- - - PROVIDE N_int nthreads_davidson - - ! Alpha/Beta double excitations - ! ============================= - - allocate( buffer($N_int,maxab), & - singles_a(maxab), & - singles_b(maxab), & - doubles(maxab), & - idx(maxab)) - - kcol_prev=-1 - - ASSERT (iend <= N_det) - ASSERT (istart > 0) - ASSERT (istep > 0) - - do k_a=istart+ishift,iend,istep - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - if (kcol /= kcol_prev) then - call get_all_spin_singles_$N_int( & - psi_det_beta_unique, idx0, & - tmp_det(1,2), N_det_beta_unique, & - singles_b, n_singles_b) - endif - kcol_prev = kcol - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles_b - lcol = singles_b(i) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - ASSERT (l_a <= N_det) - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) - - ASSERT (l_a <= N_det) - idx(j) = l_a - l_a = l_a+1 - enddo - j = j-1 - - call get_all_spin_singles_$N_int( & - buffer, idx, tmp_det(1,1), j, & - singles_a, n_singles_a ) - - ! Loop over alpha singles - ! ----------------------- - - do k = 1,n_singles_a - l_a = singles_a(k) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - !!!!!!!!!!!!!!!!!! ALPHA BETA - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - enddo - - enddo - - enddo - - - do k_a=istart+ishift,iend,istep - - - ! Single and double alpha excitations - ! =================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - ! Initial determinant is at k_b in beta-major representation - ! ---------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - - spindet(1:$N_int) = tmp_det(1:$N_int,1) - - ! Loop inside the beta column to gather all the connected alphas - lcol = psi_bilinear_matrix_columns(k_a) - l_a = psi_bilinear_matrix_columns_loc(lcol) - do i=1,N_det_alpha_unique - if (l_a > N_det) exit - lcol = psi_bilinear_matrix_columns(l_a) - if (lcol /= kcol) exit - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) - idx(i) = l_a - l_a = l_a+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_a, doubles, n_singles_a, n_doubles ) - - ! Compute Hij for all alpha singles - ! ---------------------------------- - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - do i=1,n_singles_a - l_a = singles_a(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - !!!! MONO SPIN - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - - enddo - - - !! Compute Hij for all alpha doubles - !! ---------------------------------- - ! - !do i=1,n_doubles - ! l_a = doubles(i) - ! ASSERT (l_a <= N_det) - - ! lrow = psi_bilinear_matrix_rows(l_a) - ! ASSERT (lrow <= N_det_alpha_unique) - - ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) - ! do l=1,N_st - ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - ! ! same spin => sij = 0 - ! enddo - !enddo - - - - ! Single and double beta excitations - ! ================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - kcol = psi_bilinear_matrix_columns(k_a) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - spindet(1:$N_int) = tmp_det(1:$N_int,2) - - ! Initial determinant is at k_b in beta-major representation - ! ----------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - - ! Loop inside the alpha row to gather all the connected betas - lrow = psi_bilinear_matrix_transp_rows(k_b) - l_b = psi_bilinear_matrix_transp_rows_loc(lrow) - do i=1,N_det_beta_unique - if (l_b > N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l_b) - if (lrow /= krow) exit - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) - idx(i) = l_b - l_b = l_b+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_b, doubles, n_singles_b, n_doubles ) - - ! Compute Hij for all beta singles - ! ---------------------------------- - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - do i=1,n_singles_b - l_b = singles_b(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) - l_a = psi_bilinear_matrix_transp_order(l_b) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - ASSERT (l_a <= N_det) - enddo - ! - !! Compute Hij for all beta doubles - !! ---------------------------------- - ! - !do i=1,n_doubles - ! l_b = doubles(i) - ! ASSERT (l_b <= N_det) - - ! lcol = psi_bilinear_matrix_transp_columns(l_b) - ! ASSERT (lcol <= N_det_beta_unique) - - ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) - ! l_a = psi_bilinear_matrix_transp_order(l_b) - ! ASSERT (l_a <= N_det) - - ! do l=1,N_st - ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - ! ! same spin => sij = 0 - ! enddo - !enddo - - - ! Diagonal contribution - ! ===================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem - double precision :: c_1(N_states),c_2(N_states) - do l = 1, N_states - c_1(l) = u_t(l,k_a) - enddo - - call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) - - end do - deallocate(buffer, singles_a, singles_b, doubles, idx) - - end - - SUBST [ N_int ] - - 1;; - 2;; - 3;; - 4;; - N_int;; - - END_TEMPLATE diff --git a/src/two_body_rdm/act_2_rdm.irp.f b/src/two_body_rdm/act_2_rdm.irp.f new file mode 100644 index 00000000..3d4a9ace --- /dev/null +++ b/src/two_body_rdm/act_2_rdm.irp.f @@ -0,0 +1,155 @@ + + BEGIN_PROVIDER [double precision, act_2_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * N_{\beta}^{act} +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta +! +! act_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessary have symmetry between electron 1 and 2 + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for alpha/beta spin + print*,'' + print*,'Providing act_2_rdm_ab_mo ' + ispin = 3 + act_2_rdm_ab_mo = 0.d0 + call wall_time(wall_1) + if(read_two_body_rdm_ab)then + print*,'Reading act_2_rdm_ab_mo from disk ...' + call ezfio_get_two_body_rdm_two_rdm_ab_disk(act_2_rdm_ab_mo) + else + call orb_range_2_rdm_openmp(act_2_rdm_ab_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + endif + if(write_two_body_rdm_ab)then + print*,'Writing act_2_rdm_ab_mo on disk ...' + call ezfio_set_two_body_rdm_two_rdm_ab_disk(act_2_rdm_ab_mo) + call ezfio_set_two_body_rdm_io_two_body_rdm_ab("Read") + endif + call wall_time(wall_2) + print*,'Wall time to provide act_2_rdm_ab_mo',wall_2 - wall_1 + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_2_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of ALPHA/ALPHA electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * (N_{\alpha}^{act} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for alpha/beta spin + print*,'' + print*,'Providing act_2_rdm_aa_mo ' + ispin = 1 + act_2_rdm_aa_mo = 0.d0 + call wall_time(wall_1) + if(read_two_body_rdm_aa)then + print*,'Reading act_2_rdm_aa_mo from disk ...' + call ezfio_get_two_body_rdm_two_rdm_aa_disk(act_2_rdm_aa_mo) + else + call orb_range_2_rdm_openmp(act_2_rdm_aa_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + endif + if(write_two_body_rdm_aa)then + print*,'Writing act_2_rdm_aa_mo on disk ...' + call ezfio_set_two_body_rdm_two_rdm_aa_disk(act_2_rdm_aa_mo) + call ezfio_set_two_body_rdm_io_two_body_rdm_aa("Read") + endif + + call wall_time(wall_2) + print*,'Wall time to provide act_2_rdm_aa_mo',wall_2 - wall_1 + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_2_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of BETA/BETA electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta}^{act} * (N_{\beta}^{act} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for beta/beta spin + print*,'' + print*,'Providing act_2_rdm_bb_mo ' + ispin = 2 + act_2_rdm_bb_mo = 0.d0 + call wall_time(wall_1) + if(read_two_body_rdm_bb)then + print*,'Reading act_2_rdm_bb_mo from disk ...' + call ezfio_get_two_body_rdm_two_rdm_bb_disk(act_2_rdm_bb_mo) + else + call orb_range_2_rdm_openmp(act_2_rdm_bb_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + endif + if(write_two_body_rdm_bb)then + print*,'Writing act_2_rdm_bb_mo on disk ...' + call ezfio_set_two_body_rdm_two_rdm_bb_disk(act_2_rdm_bb_mo) + call ezfio_set_two_body_rdm_io_two_body_rdm_bb("Read") + endif + + call wall_time(wall_2) + print*,'Wall time to provide act_2_rdm_bb_mo',wall_2 - wall_1 + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_2_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_2_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM +! +! \sum_{\sigma,\sigma'} +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec}^{act} * (N_{elec}^{act} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for beta/beta spin + print*,'' + print*,'Providing act_2_rdm_spin_trace_mo ' + ispin = 4 + act_2_rdm_spin_trace_mo = 0.d0 + call wall_time(wall_1) + if(read_two_body_rdm_spin_trace)then + print*,'Reading act_2_rdm_spin_trace_mo from disk ...' + call ezfio_get_two_body_rdm_two_rdm_spin_trace_disk(act_2_rdm_spin_trace_mo) + else + call orb_range_2_rdm_openmp(act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + endif + if(write_two_body_rdm_spin_trace)then + print*,'Writing act_2_rdm_spin_trace_mo on disk ...' + call ezfio_set_two_body_rdm_two_rdm_spin_trace_disk(act_2_rdm_spin_trace_mo) + call ezfio_set_two_body_rdm_io_two_body_rdm_spin_trace("Read") + endif + + call wall_time(wall_2) + print*,'Wall time to provide act_2_rdm_spin_trace_mo',wall_2 - wall_1 + END_PROVIDER diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f deleted file mode 100644 index fa036e6a..00000000 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ /dev/null @@ -1,442 +0,0 @@ -subroutine all_two_rdm_dm_nstates(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - integer, intent(in) :: N_st,sze - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: u_0(sze,N_st) - integer :: k - double precision, allocatable :: u_t(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate(u_t(N_st,N_det)) - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) - enddo - call dtranspose( & - u_0, & - size(u_0, 1), & - u_t, & - size(u_t, 1), & - N_det, N_st) - - call all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) - deallocate(u_t) - - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) - enddo - -end - - -subroutine all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes two-rdm - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - double precision, intent(in) :: u_t(N_st,N_det) - - - PROVIDE N_int - - select case (N_int) - case (1) - call all_two_rdm_dm_nstates_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (2) - call all_two_rdm_dm_nstates_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (3) - call all_two_rdm_dm_nstates_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (4) - call all_two_rdm_dm_nstates_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case default - call all_two_rdm_dm_nstates_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - end select -end - - BEGIN_TEMPLATE - -subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - double precision, intent(in) :: u_t(N_st,N_det) - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - - integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b - integer :: lrow, lcol - integer :: mrow, mcol - integer(bit_kind) :: spindet($N_int) - integer(bit_kind) :: tmp_det($N_int,2) - integer(bit_kind) :: tmp_det2($N_int,2) - integer(bit_kind) :: tmp_det3($N_int,2) - integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_doubles - integer, allocatable :: doubles(:) - integer, allocatable :: singles_a(:) - integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), idx0(:) - integer :: maxab, n_singles_a, n_singles_b, kcol_prev - integer*8 :: k8 - - maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 - allocate(idx0(maxab)) - - do i=1,maxab - idx0(i) = i - enddo - - ! Prepare the array of all alpha single excitations - ! ------------------------------------------------- - - PROVIDE N_int nthreads_davidson - !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & - ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & - ! !$OMP psi_bilinear_matrix_columns, & - ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& - ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& - ! !$OMP psi_bilinear_matrix_transp_rows, & - ! !$OMP psi_bilinear_matrix_transp_columns, & - ! !$OMP psi_bilinear_matrix_transp_order, N_st, & - ! !$OMP psi_bilinear_matrix_order_transp_reverse, & - ! !$OMP psi_bilinear_matrix_columns_loc, & - ! !$OMP psi_bilinear_matrix_transp_rows_loc, & - ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab) & - ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& - ! !$OMP lcol, lrow, l_a, l_b, & - ! !$OMP buffer, doubles, n_doubles, & - ! !$OMP tmp_det2, idx, l, kcol_prev, & - ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, k8) - - ! Alpha/Beta double excitations - ! ============================= - - allocate( buffer($N_int,maxab), & - singles_a(maxab), & - singles_b(maxab), & - doubles(maxab), & - idx(maxab)) - - kcol_prev=-1 - - ASSERT (iend <= N_det) - ASSERT (istart > 0) - ASSERT (istep > 0) - - !!$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - if (kcol /= kcol_prev) then - call get_all_spin_singles_$N_int( & - psi_det_beta_unique, idx0, & - tmp_det(1,2), N_det_beta_unique, & - singles_b, n_singles_b) - endif - kcol_prev = kcol - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles_b - lcol = singles_b(i) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - ASSERT (l_a <= N_det) - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) - - ASSERT (l_a <= N_det) - idx(j) = l_a - l_a = l_a+1 - enddo - j = j-1 - - call get_all_spin_singles_$N_int( & - buffer, idx, tmp_det(1,1), j, & - singles_a, n_singles_a ) - - ! Loop over alpha singles - ! ----------------------- - - do k = 1,n_singles_a - l_a = singles_a(k) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - enddo - - enddo - - enddo - ! !$OMP END DO - - ! !$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - - ! Single and double alpha exitations - ! =================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - ! Initial determinant is at k_b in beta-major representation - ! ---------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - spindet(1:$N_int) = tmp_det(1:$N_int,1) - - ! Loop inside the beta column to gather all the connected alphas - lcol = psi_bilinear_matrix_columns(k_a) - l_a = psi_bilinear_matrix_columns_loc(lcol) - do i=1,N_det_alpha_unique - if (l_a > N_det) exit - lcol = psi_bilinear_matrix_columns(l_a) - if (lcol /= kcol) exit - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) - idx(i) = l_a - l_a = l_a+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_a, doubles, n_singles_a, n_doubles ) - - ! Compute Hij for all alpha singles - ! ---------------------------------- - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - do i=1,n_singles_a - l_a = singles_a(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - ! increment the alpha/beta part for single excitations - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - ! increment the alpha/alpha part for single excitations - call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) - - enddo - - - ! Compute Hij for all alpha doubles - ! ---------------------------------- - - do i=1,n_doubles - l_a = doubles(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) - enddo - - - ! Single and double beta excitations - ! ================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - kcol = psi_bilinear_matrix_columns(k_a) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - spindet(1:$N_int) = tmp_det(1:$N_int,2) - - ! Initial determinant is at k_b in beta-major representation - ! ----------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - ! Loop inside the alpha row to gather all the connected betas - lrow = psi_bilinear_matrix_transp_rows(k_b) - l_b = psi_bilinear_matrix_transp_rows_loc(lrow) - do i=1,N_det_beta_unique - if (l_b > N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l_b) - if (lrow /= krow) exit - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) - idx(i) = l_b - l_b = l_b+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_b, doubles, n_singles_b, n_doubles ) - - ! Compute Hij for all beta singles - ! ---------------------------------- - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - do i=1,n_singles_b - l_b = singles_b(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) - l_a = psi_bilinear_matrix_transp_order(l_b) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - ! increment the alpha/beta part for single excitations - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - ! increment the beta /beta part for single excitations - call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) - enddo - - ! Compute Hij for all beta doubles - ! ---------------------------------- - - do i=1,n_doubles - l_b = doubles(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - l_a = psi_bilinear_matrix_transp_order(l_b) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) - ASSERT (l_a <= N_det) - - enddo - - - ! Diagonal contribution - ! ===================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - double precision, external :: diag_wee_mat_elem, diag_S_mat_elem - - double precision :: c_1(N_states),c_2(N_states) - do l = 1, N_states - c_1(l) = u_t(l,k_a) - enddo - - call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) - - end do - !!$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx) - !!$OMP END PARALLEL - -end - - SUBST [ N_int ] - - 1;; - 2;; - 3;; - 4;; - N_int;; - - END_TEMPLATE - diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_2_rdm.irp.f deleted file mode 100644 index bc503223..00000000 --- a/src/two_body_rdm/all_states_2_rdm.irp.f +++ /dev/null @@ -1,83 +0,0 @@ - - - - BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = 1.d0/dble(N_states) - integer :: ispin - ! condition for alpha/beta spin - ispin = 1 - all_states_act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, all_states_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! all_states_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = 1.d0/dble(N_states) - integer :: ispin - ! condition for alpha/beta spin - ispin = 2 - all_states_act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_all_states_two_rdm(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = 1.d0/dble(N_states) - integer :: ispin - ! condition for alpha/beta spin - print*,'' - print*,'' - print*,'' - print*,'providint all_states_act_two_rdm_alpha_beta_mo ' - ispin = 3 - print*,'ispin = ',ispin - all_states_act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - - BEGIN_PROVIDER [double precision, all_states_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] - implicit none - BEGIN_DOC -! all_states_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices -! The active part of the two-electron energy can be computed as: -! -! \sum_{i,j,k,l = 1, n_act_orb} all_states_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > -! -! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) - END_DOC - double precision, allocatable :: state_weights(:) - allocate(state_weights(N_states)) - state_weights = 1.d0/dble(N_states) - integer :: ispin - ! condition for alpha/beta spin - ispin = 4 - all_states_act_two_rdm_spin_trace_mo = 0.d0 - integer :: i - - call orb_range_all_states_two_rdm(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f deleted file mode 100644 index 8f40f32a..00000000 --- a/src/two_body_rdm/all_states_routines.irp.f +++ /dev/null @@ -1,495 +0,0 @@ -subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) - use bitmasks - implicit none - BEGIN_DOC - ! if ispin == 1 :: alpha/alpha 2rdm - ! == 2 :: beta /beta 2rdm - ! == 3 :: alpha/beta 2rdm - ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - integer, intent(in) :: N_st,sze - integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - double precision, intent(in) :: u_0(sze,N_st) - - integer :: k - double precision, allocatable :: u_t(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate(u_t(N_st,N_det)) - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) - enddo - call dtranspose( & - u_0, & - size(u_0, 1), & - u_t, & - size(u_t, 1), & - N_det, N_st) - - call orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1) - deallocate(u_t) - - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) - enddo - -end - -subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes two-rdm - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - double precision, intent(in) :: u_t(N_st,N_det) - - integer :: k - - PROVIDE N_int - - select case (N_int) - case (1) - call orb_range_all_states_two_rdm_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - case (2) - call orb_range_all_states_two_rdm_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - case (3) - call orb_range_all_states_two_rdm_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - case (4) - call orb_range_all_states_two_rdm_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - case default - call orb_range_all_states_two_rdm_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - end select -end - - - - - BEGIN_TEMPLATE -subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes the two rdm for the N_st vectors |u_t> - ! if ispin == 1 :: alpha/alpha 2rdm - ! == 2 :: beta /beta 2rdm - ! == 3 :: alpha/beta 2rdm - ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) - ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb - ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - double precision, intent(in) :: u_t(N_st,N_det) - integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - - integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b - integer :: lrow, lcol - integer :: mrow, mcol - integer(bit_kind) :: spindet($N_int) - integer(bit_kind) :: tmp_det($N_int,2) - integer(bit_kind) :: tmp_det2($N_int,2) - integer(bit_kind) :: tmp_det3($N_int,2) - integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_doubles - integer, allocatable :: doubles(:) - integer, allocatable :: singles_a(:) - integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), idx0(:) - integer :: maxab, n_singles_a, n_singles_b, kcol_prev - integer*8 :: k8 - double precision,allocatable :: c_contrib(:) - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - integer(bit_kind) :: orb_bitmask($N_int) - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - else - print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work' - print*,'ispin = ',ispin - stop - endif - - PROVIDE N_int - - call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) - - maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 - allocate(idx0(maxab)) - - do i=1,maxab - idx0(i) = i - enddo - - ! Prepare the array of all alpha single excitations - ! ------------------------------------------------- - - PROVIDE N_int nthreads_davidson - !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & - ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & - ! !$OMP psi_bilinear_matrix_columns, & - ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& - ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& - ! !$OMP psi_bilinear_matrix_transp_rows, & - ! !$OMP psi_bilinear_matrix_transp_columns, & - ! !$OMP psi_bilinear_matrix_transp_order, N_st, & - ! !$OMP psi_bilinear_matrix_order_transp_reverse, & - ! !$OMP psi_bilinear_matrix_columns_loc, & - ! !$OMP psi_bilinear_matrix_transp_rows_loc, & - ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab) & - ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& - ! !$OMP lcol, lrow, l_a, l_b, & - ! !$OMP buffer, doubles, n_doubles, & - ! !$OMP tmp_det2, idx, l, kcol_prev, & - ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, k8) - - ! Alpha/Beta double excitations - ! ============================= - - allocate( buffer($N_int,maxab), & - singles_a(maxab), & - singles_b(maxab), & - doubles(maxab), & - idx(maxab),c_contrib(N_st)) - - kcol_prev=-1 - - ASSERT (iend <= N_det) - ASSERT (istart > 0) - ASSERT (istep > 0) - - !!$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - if (kcol /= kcol_prev) then - call get_all_spin_singles_$N_int( & - psi_det_beta_unique, idx0, & - tmp_det(1,2), N_det_beta_unique, & - singles_b, n_singles_b) - endif - kcol_prev = kcol - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles_b - lcol = singles_b(i) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - ASSERT (l_a <= N_det) - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) - - ASSERT (l_a <= N_det) - idx(j) = l_a - l_a = l_a+1 - enddo - j = j-1 - - call get_all_spin_singles_$N_int( & - buffer, idx, tmp_det(1,1), j, & - singles_a, n_singles_a ) - - ! Loop over alpha singles - ! ----------------------- - - if(alpha_beta.or.spin_trace)then - do k = 1,n_singles_a - l_a = singles_a(k) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - c_contrib = 0.d0 - do l= 1, N_st - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_contrib(l) = c_1(l) * c_2(l) - enddo - call orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - enddo - endif - - enddo - - enddo - ! !$OMP END DO - - ! !$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - - ! Single and double alpha exitations - ! =================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - ! Initial determinant is at k_b in beta-major representation - ! ---------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - spindet(1:$N_int) = tmp_det(1:$N_int,1) - - ! Loop inside the beta column to gather all the connected alphas - lcol = psi_bilinear_matrix_columns(k_a) - l_a = psi_bilinear_matrix_columns_loc(lcol) - do i=1,N_det_alpha_unique - if (l_a > N_det) exit - lcol = psi_bilinear_matrix_columns(l_a) - if (lcol /= kcol) exit - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) - idx(i) = l_a - l_a = l_a+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_a, doubles, n_singles_a, n_doubles ) - - ! Compute Hij for all alpha singles - ! ---------------------------------- - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - do i=1,n_singles_a - l_a = singles_a(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - c_contrib = 0.d0 - do l= 1, N_st - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_contrib(l) = c_1(l) * c_2(l) - enddo - if(alpha_beta.or.spin_trace.or.alpha_alpha)then - ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - ! increment the alpha/alpha part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - endif - - enddo - - - ! Compute Hij for all alpha doubles - ! ---------------------------------- - - if(alpha_alpha.or.spin_trace)then - do i=1,n_doubles - l_a = doubles(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - c_contrib = 0.d0 - do l= 1, N_st - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_contrib(l) += c_1(l) * c_2(l) - enddo - call orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - enddo - endif - - - ! Single and double beta excitations - ! ================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - kcol = psi_bilinear_matrix_columns(k_a) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - spindet(1:$N_int) = tmp_det(1:$N_int,2) - - ! Initial determinant is at k_b in beta-major representation - ! ----------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - ! Loop inside the alpha row to gather all the connected betas - lrow = psi_bilinear_matrix_transp_rows(k_b) - l_b = psi_bilinear_matrix_transp_rows_loc(lrow) - do i=1,N_det_beta_unique - if (l_b > N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l_b) - if (lrow /= krow) exit - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) - idx(i) = l_b - l_b = l_b+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_b, doubles, n_singles_b, n_doubles ) - - ! Compute Hij for all beta singles - ! ---------------------------------- - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - do i=1,n_singles_b - l_b = singles_b(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) - l_a = psi_bilinear_matrix_transp_order(l_b) - c_contrib = 0.d0 - do l= 1, N_st - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_contrib(l) = c_1(l) * c_2(l) - enddo - if(alpha_beta.or.spin_trace.or.beta_beta)then - ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - ! increment the beta /beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - endif - enddo - - ! Compute Hij for all beta doubles - ! ---------------------------------- - - if(beta_beta.or.spin_trace)then - do i=1,n_doubles - l_b = doubles(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - l_a = psi_bilinear_matrix_transp_order(l_b) - c_contrib = 0.d0 - do l= 1, N_st - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_contrib(l) = c_1(l) * c_2(l) - enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - ASSERT (l_a <= N_det) - - enddo - endif - - - ! Diagonal contribution - ! ===================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - double precision, external :: diag_wee_mat_elem, diag_S_mat_elem - - double precision :: c_1(N_states),c_2(N_states) - c_contrib = 0.d0 - do l = 1, N_st - c_1(l) = u_t(l,k_a) - c_contrib(l) = c_1(l) * c_1(l) - enddo - - call orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - - end do - !!$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx) - !!$OMP END PARALLEL - -end - - SUBST [ N_int ] - - 1;; - 2;; - 3;; - 4;; - N_int;; - - END_TEMPLATE - diff --git a/src/two_body_rdm/compute.irp.f b/src/two_body_rdm/compute.irp.f deleted file mode 100644 index 112d2e36..00000000 --- a/src/two_body_rdm/compute.irp.f +++ /dev/null @@ -1,269 +0,0 @@ - - - subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2) - double precision, intent(in) :: c_1(N_states) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate - double precision :: c_1_bis - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - do istate = 1, N_states - c_1_bis = c_1(istate) * c_1(istate) - do i = 1, n_occ_ab(1) - h1 = occ(i,1) - do j = 1, n_occ_ab(2) - h2 = occ(j,2) - big_array(h1,h1,h2,h2,istate) += c_1_bis - enddo - enddo - enddo - end - - - subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2) - double precision, intent(in) :: c_1(N_states) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate - double precision :: c_1_bis - BEGIN_DOC -! no factor 1/2 have to be taken into account as the permutations are already taken into account - END_DOC - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - do istate = 1, N_states - c_1_bis = c_1(istate) * c_1(istate) - do i = 1, n_occ_ab(1) - h1 = occ(i,1) - do j = 1, n_occ_ab(2) - h2 = occ(j,2) - big_array_ab(h1,h1,h2,h2,istate) += c_1_bis - enddo - do j = 1, n_occ_ab(1) - h2 = occ(j,1) - big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis - big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis - enddo - enddo - do i = 1, n_occ_ab(2) - h1 = occ(i,2) - do j = 1, n_occ_ab(2) - h2 = occ(j,2) - big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis - big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis - enddo - enddo - enddo - end - - - subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2,2) - double precision :: phase - call get_double_excitation(det_1,det_2,exc,phase,N_int) - h1 = exc(1,1,1) - h2 = exc(1,1,2) - p1 = exc(1,2,1) - p2 = exc(1,2,2) - do istate = 1, N_states - big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) -! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) - enddo - end - - subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - p1 = exc(1,2,1) - do istate = 1, N_states - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase - enddo - enddo - else - ! Mono beta - h1 = exc(1,1,2) - p1 = exc(1,2,2) - do istate = 1, N_states - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase - enddo - enddo - endif - end - - subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS - END_DOC - use bitmasks - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - p1 = exc(1,2,1) - do istate = 1, N_states - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase - big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase - - big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase - big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase - enddo - enddo - else - return - endif - end - - subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if (exc(0,1,1) == 1) then - return - else - ! Mono beta - h1 = exc(1,1,2) - p1 = exc(1,2,2) - do istate = 1, N_states - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase - big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase - - big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase - big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase - enddo - enddo - endif - end - - - subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2) - double precision :: phase - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - h2 =exc(2,1) - p1 =exc(1,2) - p2 =exc(2,2) -!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) - do istate = 1, N_states - big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) - big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) - - big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) - big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) - enddo - end - - subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS - END_DOC - implicit none - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - double precision, intent(in) :: c_1(N_states),c_2(N_states) - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2) - double precision :: phase - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - h2 =exc(2,1) - p1 =exc(1,2) - p2 =exc(2,2) -!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) - do istate = 1, N_states - big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) - big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) - - big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) - big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) - enddo - end - diff --git a/src/two_body_rdm/compute_all_states.irp.f b/src/two_body_rdm/compute_all_states.irp.f deleted file mode 100644 index 7606e353..00000000 --- a/src/two_body_rdm/compute_all_states.irp.f +++ /dev/null @@ -1,660 +0,0 @@ - - subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals - END_DOC - implicit none - integer, intent(in) :: dim1,N_st - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - double precision, intent(in) :: c_1(N_st) - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - do istate = 1, N_st - do i = 1, n_occ_ab(1) - h1 = occ(i,1) - do j = 1, n_occ_ab(2) - h2 = occ(j,2) - big_array(h1,h2,h1,h2,istate) += c_1(istate) - enddo - enddo - enddo - end - - - subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm - END_DOC - implicit none - integer, intent(in) :: dim1,N_st,ispin - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - double precision, intent(in) :: c_1(N_st) - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate - integer(bit_kind) :: det_1_act(N_int,2) - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - do i = 1, N_int - det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) - det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) - enddo - - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) - logical :: is_integer_in_string - integer :: i1,i2 - if(alpha_beta)then - do istate = 1, N_st - do i = 1, n_occ_ab(1) - i1 = occ(i,1) - do j = 1, n_occ_ab(2) - i2 = occ(j,2) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += c_1(istate) - enddo - enddo - enddo - else if (alpha_alpha)then - do istate = 1, N_st - do i = 1, n_occ_ab(1) - i1 = occ(i,1) - do j = 1, n_occ_ab(1) - i2 = occ(j,1) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) - big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) - enddo - enddo - enddo - else if (beta_beta)then - do istate = 1, N_st - do i = 1, n_occ_ab(2) - i1 = occ(i,2) - do j = 1, n_occ_ab(2) - i2 = occ(j,2) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) - big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) - enddo - enddo - enddo - else if(spin_trace)then - ! 0.5 * (alpha beta + beta alpha) - do istate = 1, N_st - do i = 1, n_occ_ab(1) - i1 = occ(i,1) - do j = 1, n_occ_ab(2) - i2 = occ(j,2) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) - big_array(h2,h1,h2,h1,istate) += 0.5d0 * c_1(istate) - enddo - enddo - do i = 1, n_occ_ab(1) - i1 = occ(i,1) - do j = 1, n_occ_ab(1) - i2 = occ(j,1) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) - big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) - enddo - enddo - do i = 1, n_occ_ab(2) - i1 = occ(i,2) - do j = 1, n_occ_ab(2) - i2 = occ(j,2) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) - big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) - enddo - enddo - enddo - endif - end - - - subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 3 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - call get_double_excitation(det_1,det_2,exc,phase,N_int) - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - h2 = exc(1,1,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - p2 = exc(1,2,2) - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) - do istate = 1, N_st - if(alpha_beta)then - big_array(h1,h2,p1,p2,istate) += c_1(istate) * phase - else if(spin_trace)then - big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase - big_array(p1,p2,h1,h2,istate) += 0.5d0 * c_1(istate) * phase - endif - enddo - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 3 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(alpha_beta)then - do istate = 1, N_st - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2,istate) += c_1(istate) * phase - enddo - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h2,h1,h2,p1,istate) += c_1(istate) * phase - enddo - endif - enddo - else if(spin_trace)then - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do istate = 1, N_st - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase - big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase - enddo - enddo - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do istate = 1, N_st - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase - big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase - enddo - enddo - endif - endif - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 1 or 4 will do something - END_DOC - use bitmasks - implicit none - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(alpha_alpha.or.spin_trace)then - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do istate = 1, N_st - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase - big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase - - big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase - big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase - enddo - enddo - else - return - endif - endif - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 2 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 - integer :: exc(0:2,2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(beta_beta.or.spin_trace)then - if (exc(0,1,1) == 1) then - return - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do istate = 1, N_st - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase - big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase - - big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase - big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase - enddo - enddo - endif - endif - end - - - subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 1 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - h2 =exc(2,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) - p1 =exc(1,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - p2 =exc(2,2) - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) - if(alpha_alpha.or.spin_trace)then - do istate = 1, N_st - big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase - big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate) * phase - - big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate) * phase - big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate) * phase - enddo - endif - end - - subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 2 or 4 will do something - END_DOC - implicit none - - integer, intent(in) :: dim1,N_st,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1(N_st) - - integer :: i,j,h1,h2,p1,p2,istate - integer :: exc(0:2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - h2 =exc(2,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) - p1 =exc(1,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - p2 =exc(2,2) - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) - do istate = 1, N_st - if(beta_beta.or.spin_trace)then - big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate)* phase - big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate)* phase - - big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate)* phase - big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate)* phase - endif - enddo - end - diff --git a/src/two_body_rdm/compute_orb_range.irp.f b/src/two_body_rdm/compute_orb_range.irp.f deleted file mode 100644 index 52cccbf3..00000000 --- a/src/two_body_rdm/compute_orb_range.irp.f +++ /dev/null @@ -1,670 +0,0 @@ - - subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals -! c_1 is supposed to be a scalar quantity, such as state averaged coef - END_DOC - implicit none - integer, intent(in) :: dim1 - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - double precision, intent(in) :: c_1 - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2 - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - do i = 1, n_occ_ab(1) - h1 = occ(i,1) - do j = 1, n_occ_ab(2) - h2 = occ(j,2) - big_array(h1,h2,h1,h2) += c_1 - enddo - enddo - end - - - subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm - END_DOC - implicit none - integer, intent(in) :: dim1,ispin - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - double precision, intent(in) :: c_1 - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2 - integer(bit_kind) :: det_1_act(N_int,2) - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - do i = 1, N_int - det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) - det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) - enddo - -!print*,'ahah' -!call debug_det(det_1_act,N_int) -!pause - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - BEGIN_DOC -! no factor 1/2 have to be taken into account as the permutations are already taken into account - END_DOC - call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) - logical :: is_integer_in_string - integer :: i1,i2 - if(alpha_beta)then - do i = 1, n_occ_ab(1) - i1 = occ(i,1) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(2) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - i2 = occ(j,2) - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += c_1 - enddo - enddo - else if (alpha_alpha)then - do i = 1, n_occ_ab(1) - i1 = occ(i,1) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(1) - i2 = occ(j,1) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += 0.5d0 * c_1 - big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 - enddo - enddo - else if (beta_beta)then - do i = 1, n_occ_ab(2) - i1 = occ(i,2) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(2) - i2 = occ(j,2) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += 0.5d0 * c_1 - big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 - enddo - enddo - else if(spin_trace)then - ! 0.5 * (alpha beta + beta alpha) - do i = 1, n_occ_ab(1) - i1 = occ(i,1) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(2) - i2 = occ(j,2) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) - big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) - enddo - enddo - !stop - do i = 1, n_occ_ab(1) - i1 = occ(i,1) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(1) - i2 = occ(j,1) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += 0.5d0 * c_1 - big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 - enddo - enddo - do i = 1, n_occ_ab(2) - i1 = occ(i,2) -! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle - do j = 1, n_occ_ab(2) - i2 = occ(j,2) -! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle - h1 = list_orb_reverse(i1) - h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2) += 0.5d0 * c_1 - big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 - enddo - enddo - endif - end - - - subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 3 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - integer :: i,j,h1,h2,p1,p2 - integer :: exc(0:2,2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif -!print*,'' -!do i = 1, mo_num -! print*,'list_orb',i,list_orb_reverse(i) -!enddo - call get_double_excitation(det_1,det_2,exc,phase,N_int) - h1 = exc(1,1,1) -!print*,'h1',h1 - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) -!print*,'passed h1 = ',h1 - h2 = exc(1,1,2) -!print*,'h2',h2 - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) -!print*,'passed h2 = ',h2 - p1 = exc(1,2,1) -!print*,'p1',p1 - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) -!print*,'passed p1 = ',p1 - p2 = exc(1,2,2) -!print*,'p2',p2 - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) -!print*,'passed p2 = ',p2 - if(alpha_beta)then - big_array(h1,h2,p1,p2) += c_1 * phase - else if(spin_trace)then - big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase - big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase - !print*,'h1,h2,p1,p2',h1,h2,p1,p2 - !print*,'',big_array(h1,h2,p1,p2) - endif - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 3 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,p1 - integer :: exc(0:2,2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(alpha_beta)then - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += c_1 * phase - enddo - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h2,h1,h2,p1) += c_1 * phase - enddo - endif - else if(spin_trace)then - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase - big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase - enddo - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase - big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase - enddo - endif - endif - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 1 or 4 will do something - END_DOC - use bitmasks - implicit none - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,p1 - integer :: exc(0:2,2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(alpha_alpha.or.spin_trace)then - if (exc(0,1,1) == 1) then - ! Mono alpha - h1 = exc(1,1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(1) - h2 = occ(i,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase - big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase - - big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase - big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase - enddo - else - return - endif - endif - end - - subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 2 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - - - integer :: occ(N_int*bit_kind_size,2) - integer :: n_occ_ab(2) - integer :: i,j,h1,h2,p1 - integer :: exc(0:2,2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) - call get_single_excitation(det_1,det_2,exc,phase,N_int) - if(beta_beta.or.spin_trace)then - if (exc(0,1,1) == 1) then - return - else - ! Mono beta - h1 = exc(1,1,2) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase - big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase - - big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase - big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase - enddo - endif - endif - end - - - subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 1 or 4 will do something - END_DOC - implicit none - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - - integer :: i,j,h1,h2,p1,p2 - integer :: exc(0:2,2) - double precision :: phase - - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - h2 =exc(2,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) - p1 =exc(1,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - p2 =exc(2,2) - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) - if(alpha_alpha.or.spin_trace)then - big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase - big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase - - big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase - big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase - endif - end - - subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) - use bitmasks - BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -! -! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another -! -! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -! -! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -! -! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -! -! ispin determines which spin-spin component of the two-rdm you will update -! -! ispin == 1 :: alpha/ alpha -! ispin == 2 :: beta / beta -! ispin == 3 :: alpha/ beta -! ispin == 4 :: spin traced <=> total two-rdm -! -! here, only ispin == 2 or 4 will do something - END_DOC - implicit none - - integer, intent(in) :: dim1,ispin - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) - integer(bit_kind), intent(in) :: orb_bitmask(N_int) - integer, intent(in) :: list_orb_reverse(mo_num) - double precision, intent(in) :: c_1 - - integer :: i,j,h1,h2,p1,p2 - integer :: exc(0:2,2) - double precision :: phase - logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace - logical :: is_integer_in_string - alpha_alpha = .False. - beta_beta = .False. - alpha_beta = .False. - spin_trace = .False. - if( ispin == 1)then - alpha_alpha = .True. - else if(ispin == 2)then - beta_beta = .True. - else if(ispin == 3)then - alpha_beta = .True. - else if(ispin == 4)then - spin_trace = .True. - endif - - call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) - h1 =exc(1,1) - if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return - h1 = list_orb_reverse(h1) - h2 =exc(2,1) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return - h2 = list_orb_reverse(h2) - p1 =exc(1,2) - if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return - p1 = list_orb_reverse(p1) - p2 =exc(2,2) - if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return - p2 = list_orb_reverse(p2) - if(beta_beta.or.spin_trace)then - big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase - big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase - - big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase - big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase - endif - end - diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f new file mode 100644 index 00000000..4400613c --- /dev/null +++ b/src/two_body_rdm/example.irp.f @@ -0,0 +1,286 @@ + +subroutine routine_active_only + implicit none + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! This routine computes the two electron repulsion within the active space using various providers +! + END_DOC + + double precision :: vijkl,get_two_e_integral + double precision :: wee_ab(N_states),rdmab + double precision :: wee_bb(N_states),rdmbb + double precision :: wee_aa(N_states),rdmaa + double precision :: wee_tot(N_states),rdmtot + double precision :: wee_aa_st_av, rdm_aa_st_av + double precision :: wee_bb_st_av, rdm_bb_st_av + double precision :: wee_ab_st_av, rdm_ab_st_av + double precision :: wee_tot_st_av, rdm_tot_st_av + double precision :: wee_aa_st_av_2,wee_ab_st_av_2,wee_bb_st_av_2,wee_tot_st_av_2,wee_tot_st_av_3 + + wee_ab = 0.d0 + wee_bb = 0.d0 + wee_aa = 0.d0 + wee_tot = 0.d0 + + wee_aa_st_av_2 = 0.d0 + wee_bb_st_av_2 = 0.d0 + wee_ab_st_av_2 = 0.d0 + wee_tot_st_av_2 = 0.d0 + wee_tot_st_av_3 = 0.d0 + + + iorb = 1 + jorb = 1 + korb = 1 + lorb = 1 + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + provide act_2_rdm_ab_mo act_2_rdm_aa_mo act_2_rdm_bb_mo act_2_rdm_spin_trace_mo + provide state_av_act_2_rdm_ab_mo state_av_act_2_rdm_aa_mo + provide state_av_act_2_rdm_bb_mo state_av_act_2_rdm_spin_trace_mo + print*,'**************************' + print*,'**************************' + do istate = 1, N_states + !! PURE ACTIVE PART + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + + + rdmab = act_2_rdm_ab_mo(l,k,j,i,istate) + rdmaa = act_2_rdm_aa_mo(l,k,j,i,istate) + rdmbb = act_2_rdm_bb_mo(l,k,j,i,istate) + rdmtot = act_2_rdm_spin_trace_mo(l,k,j,i,istate) + + + wee_ab(istate) += vijkl * rdmab + wee_aa(istate) += vijkl * rdmaa + wee_bb(istate) += vijkl * rdmbb + wee_tot(istate) += vijkl * rdmtot + + enddo + enddo + enddo + enddo + wee_aa_st_av_2 += wee_aa(istate) * state_average_weight(istate) + wee_bb_st_av_2 += wee_aa(istate) * state_average_weight(istate) + wee_ab_st_av_2 += wee_aa(istate) * state_average_weight(istate) + wee_tot_st_av_2 += wee_tot(istate) * state_average_weight(istate) + wee_tot_st_av_3 += psi_energy_two_e(istate) * state_average_weight(istate) + print*,'' + print*,'' + print*,'Active space only energy for state ',istate + print*,'wee_aa(istate) = ',wee_aa(istate) + print*,'wee_bb(istate) = ',wee_bb(istate) + print*,'wee_ab(istate) = ',wee_ab(istate) + print*,'' + print*,'sum (istate) = ',wee_aa(istate) + wee_bb(istate) + wee_ab(istate) + print*,'wee_tot = ',wee_tot(istate) + print*,'Full energy ' + print*,'psi_energy_two_e(istate)= ',psi_energy_two_e(istate) + enddo + + wee_aa_st_av = 0.d0 + wee_bb_st_av = 0.d0 + wee_ab_st_av = 0.d0 + wee_tot_st_av = 0.d0 + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + + rdm_aa_st_av = state_av_act_2_rdm_aa_mo(l,k,j,i) + rdm_bb_st_av = state_av_act_2_rdm_bb_mo(l,k,j,i) + rdm_ab_st_av = state_av_act_2_rdm_ab_mo(l,k,j,i) + rdm_tot_st_av = state_av_act_2_rdm_spin_trace_mo(l,k,j,i) + + wee_aa_st_av += vijkl * rdm_aa_st_av + wee_bb_st_av += vijkl * rdm_bb_st_av + wee_ab_st_av += vijkl * rdm_ab_st_av + wee_tot_st_av += vijkl * rdm_tot_st_av + enddo + enddo + enddo + enddo + print*,'' + print*,'' + print*,'' + print*,'STATE AVERAGE ENERGY ' + print*,'Active space only energy for state ',istate + print*,'wee_aa_st_av = ',wee_aa_st_av + print*,'wee_aa_st_av_2 = ',wee_aa_st_av_2 + print*,'wee_bb_st_av = ',wee_bb_st_av + print*,'wee_bb_st_av_2 = ',wee_bb_st_av_2 + print*,'wee_ab_st_av = ',wee_ab_st_av + print*,'wee_ab_st_av_2 = ',wee_ab_st_av_2 + print*,'Sum of components = ',wee_aa_st_av+wee_bb_st_av+wee_ab_st_av + print*,'Sum of components_2 = ',wee_aa_st_av_2+wee_bb_st_av_2+wee_ab_st_av_2 + print*,'' + print*,'Full energy ' + print*,'wee_tot_st_av = ',wee_tot_st_av + print*,'wee_tot_st_av_2 = ',wee_tot_st_av_2 + print*,'wee_tot_st_av_3 = ',wee_tot_st_av_3 + +end + +subroutine routine_full_mos + implicit none + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! This routine computes the two electron repulsion using various providers +! + END_DOC + + double precision :: vijkl,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot + double precision :: wee_aa(N_states),wee_bb(N_states),wee_ab(N_states),wee_tot(N_states) + double precision :: wee_aa_st_av, rdm_aa_st_av + double precision :: wee_bb_st_av, rdm_bb_st_av + double precision :: wee_ab_st_av, rdm_ab_st_av + double precision :: wee_tot_st_av, rdm_tot_st_av + double precision :: wee_aa_st_av_2,wee_ab_st_av_2,wee_bb_st_av_2,wee_tot_st_av_2,wee_tot_st_av_3 + double precision :: aa_norm(N_states),bb_norm(N_states),ab_norm(N_states),tot_norm(N_states) + + aa_norm = 0.d0 + bb_norm = 0.d0 + ab_norm = 0.d0 + tot_norm = 0.d0 + + wee_aa = 0.d0 + wee_ab = 0.d0 + wee_bb = 0.d0 + wee_tot = 0.d0 + + wee_aa_st_av_2 = 0.d0 + wee_bb_st_av_2 = 0.d0 + wee_ab_st_av_2 = 0.d0 + wee_tot_st_av_2 = 0.d0 + wee_tot_st_av_3 = 0.d0 + + + iorb = 1 + jorb = 1 + korb = 1 + lorb = 1 + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + provide full_occ_2_rdm_ab_mo full_occ_2_rdm_aa_mo full_occ_2_rdm_bb_mo full_occ_2_rdm_spin_trace_mo + print*,'**************************' + print*,'**************************' + do istate = 1, N_states + do i = 1, n_core_inact_act_orb + iorb = list_core_inact_act(i) + do j = 1, n_core_inact_act_orb + jorb = list_core_inact_act(j) + do k = 1, n_core_inact_act_orb + korb = list_core_inact_act(k) + do l = 1, n_core_inact_act_orb + lorb = list_core_inact_act(l) + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + + rdmaa = full_occ_2_rdm_aa_mo(l,k,j,i,istate) + rdmab = full_occ_2_rdm_ab_mo(l,k,j,i,istate) + rdmbb = full_occ_2_rdm_bb_mo(l,k,j,i,istate) + rdmtot = full_occ_2_rdm_spin_trace_mo(l,k,j,i,istate) + + wee_ab(istate) += vijkl * rdmab + wee_aa(istate) += vijkl * rdmaa + wee_bb(istate) += vijkl * rdmbb + wee_tot(istate)+= vijkl * rdmtot + enddo + enddo + aa_norm(istate) += full_occ_2_rdm_aa_mo(j,i,j,i,istate) + bb_norm(istate) += full_occ_2_rdm_bb_mo(j,i,j,i,istate) + ab_norm(istate) += full_occ_2_rdm_ab_mo(j,i,j,i,istate) + tot_norm(istate)+= full_occ_2_rdm_spin_trace_mo(j,i,j,i,istate) + enddo + enddo + wee_aa_st_av_2 += wee_aa(istate) * state_average_weight(istate) + wee_bb_st_av_2 += wee_bb(istate) * state_average_weight(istate) + wee_ab_st_av_2 += wee_ab(istate) * state_average_weight(istate) + wee_tot_st_av_2 += wee_tot(istate) * state_average_weight(istate) + wee_tot_st_av_3 += psi_energy_two_e(istate) * state_average_weight(istate) + print*,'' + print*,'' + print*,'Full energy for state ',istate + print*,'wee_aa(istate) = ',wee_aa(istate) + print*,'wee_bb(istate) = ',wee_bb(istate) + print*,'wee_ab(istate) = ',wee_ab(istate) + print*,'' + print*,'sum (istate) = ',wee_aa(istate) + wee_bb(istate) + wee_ab(istate) + print*,'wee_tot(istate) = ',wee_tot(istate) + print*,'psi_energy_two_e(istate)= ',psi_energy_two_e(istate) + print*,'' + print*,'Normalization of two-rdms ' + print*,'' + print*,'aa_norm(istate) = ',aa_norm(istate) + print*,'N_alpha(N_alpha-1)/2 = ',elec_num_tab(1) * (elec_num_tab(1) - 1)/2 + print*,'' + print*,'bb_norm(istate) = ',bb_norm(istate) + print*,'N_alpha(N_alpha-1)/2 = ',elec_num_tab(2) * (elec_num_tab(2) - 1)/2 + print*,'' + print*,'ab_norm(istate) = ',ab_norm(istate) + print*,'N_alpha * N_beta = ',elec_num_tab(1) * elec_num_tab(2) + print*,'' + print*,'tot_norm(istate) = ',tot_norm(istate) + print*,'N(N-1)/2 = ',elec_num*(elec_num - 1)/2 + enddo + + wee_aa_st_av = 0.d0 + wee_bb_st_av = 0.d0 + wee_ab_st_av = 0.d0 + wee_tot_st_av = 0.d0 + do i = 1, n_core_inact_act_orb + iorb = list_core_inact_act(i) + do j = 1, n_core_inact_act_orb + jorb = list_core_inact_act(j) + do k = 1, n_core_inact_act_orb + korb = list_core_inact_act(k) + do l = 1, n_core_inact_act_orb + lorb = list_core_inact_act(l) + vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + + rdm_aa_st_av = state_av_full_occ_2_rdm_aa_mo(l,k,j,i) + rdm_bb_st_av = state_av_full_occ_2_rdm_bb_mo(l,k,j,i) + rdm_ab_st_av = state_av_full_occ_2_rdm_ab_mo(l,k,j,i) + rdm_tot_st_av = state_av_full_occ_2_rdm_spin_trace_mo(l,k,j,i) + + wee_aa_st_av += vijkl * rdm_aa_st_av + wee_bb_st_av += vijkl * rdm_bb_st_av + wee_ab_st_av += vijkl * rdm_ab_st_av + wee_tot_st_av += vijkl * rdm_tot_st_av + enddo + enddo + enddo + enddo + print*,'' + print*,'' + print*,'' + print*,'STATE AVERAGE ENERGY ' + print*,'wee_aa_st_av = ',wee_aa_st_av + print*,'wee_aa_st_av_2 = ',wee_aa_st_av_2 + print*,'wee_bb_st_av = ',wee_bb_st_av + print*,'wee_bb_st_av_2 = ',wee_bb_st_av_2 + print*,'wee_ab_st_av = ',wee_ab_st_av + print*,'wee_ab_st_av_2 = ',wee_ab_st_av_2 + print*,'Sum of components = ',wee_aa_st_av + wee_bb_st_av + wee_ab_st_av + print*,'Sum of components_2 = ',wee_aa_st_av_2 + wee_bb_st_av_2 + wee_ab_st_av_2 + print*,'' + print*,'Full energy ' + print*,'wee_tot_st_av = ',wee_tot_st_av + print*,'wee_tot_st_av_2 = ',wee_tot_st_av_2 + print*,'wee_tot_st_av_3 = ',wee_tot_st_av_3 + +end diff --git a/src/two_body_rdm/full_orb_2_rdm.irp.f b/src/two_body_rdm/full_orb_2_rdm.irp.f new file mode 100644 index 00000000..fba88172 --- /dev/null +++ b/src/two_body_rdm/full_orb_2_rdm.irp.f @@ -0,0 +1,551 @@ + + BEGIN_PROVIDER [double precision, full_occ_2_rdm_ab_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + implicit none + full_occ_2_rdm_ab_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! full_occ_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta} +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA +! +! full_occ_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessary have symmetry between electron 1 and 2 +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO ARE SET TO ZERO + END_DOC + full_occ_2_rdm_ab_mo = 0.d0 + do istate = 1, N_states + !! PURE ACTIVE PART ALPHA-BETA + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_ab_mo(l,k,j,i,istate) + enddo + enddo + enddo + enddo + !! BETA ACTIVE - ALPHA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + + !! ALPHA ACTIVE - BETA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + + !! ALPHA INACTIVE - BETA INACTIVE + !! + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! BETA ACTIVE - ALPHA CORE + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + + !! ALPHA ACTIVE - BETA CORE + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + + !! ALPHA CORE - BETA CORE + !! + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 + enddo + enddo + endif + + enddo + END_PROVIDER + + + BEGIN_PROVIDER [double precision, full_occ_2_rdm_aa_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + implicit none + full_occ_2_rdm_aa_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! full_occ_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + + do istate = 1, N_states + !! PURE ACTIVE PART ALPHA-ALPHA + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + full_occ_2_rdm_aa_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_aa_mo(l,k,j,i,istate) + enddo + enddo + enddo + enddo + !! ALPHA ACTIVE - ALPHA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + + !! ALPHA INACTIVE - ALPHA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + +!!!!!!!!!! +!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! ALPHA ACTIVE - ALPHA CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + !! ALPHA CORE - ALPHA CORE + + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, full_occ_2_rdm_bb_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + implicit none + full_occ_2_rdm_bb_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + + do istate = 1, N_states + !! PURE ACTIVE PART beta-beta + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + full_occ_2_rdm_bb_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_bb_mo(l,k,j,i,istate) + enddo + enddo + enddo + enddo + !! beta ACTIVE - beta inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + + !! beta INACTIVE - beta INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! beta ACTIVE - beta CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + !! beta CORE - beta CORE + + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, full_occ_2_rdm_spin_trace_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + implicit none + full_occ_2_rdm_spin_trace_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero +! The two-electron energy of each state can be computed as: +! +! \sum_{i,j,k,l = 1, n_core_inact_act_orb} full_occ_2_rdm_spin_trace_mo(i,j,k,l,istate) * < ii jj | kk ll > +! +! with ii = list_core_inact_act(i), jj = list_core_inact_act(j), kk = list_core_inact_act(k), ll = list_core_inact_act(l) + END_DOC + + do istate = 1, N_states + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !! PURE ACTIVE PART SPIN-TRACE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + full_occ_2_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += & + act_2_rdm_spin_trace_mo(l,k,j,i,istate) + enddo + enddo + enddo + enddo + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! BETA-BETA !!!!! + !! beta ACTIVE - beta inactive + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + !! beta INACTIVE - beta INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + if (.not.no_core_density)then + !! beta ACTIVE - beta CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + enddo + enddo + enddo + !! beta CORE - beta CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! ALPHA-ALPHA !!!!! + !! ALPHA ACTIVE - ALPHA inactive + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + !! ALPHA INACTIVE - ALPHA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + if (.not.no_core_density)then + !! ALPHA ACTIVE - ALPHA CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + !! ALPHA CORE - ALPHA CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! ALPHA-BETA + BETA-ALPHA !!!!! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! ALPHA INACTIVE - BETA ACTIVE + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! beta alph beta alph + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! BETA INACTIVE - ALPHA ACTIVE + ! beta alph beta alpha + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + !! ALPHA INACTIVE - BETA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + !! BETA ACTIVE - ALPHA CORE + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! beta alph beta alph + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) + !! ALPHA ACTIVE - BETA CORE + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! beta alph beta alph + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) + enddo + enddo + enddo + !! ALPHA CORE - BETA CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + enddo + enddo + + endif + enddo + + END_PROVIDER diff --git a/src/two_body_rdm/orb_range.irp.f b/src/two_body_rdm/orb_range.irp.f deleted file mode 100644 index 2bcd04dc..00000000 --- a/src/two_body_rdm/orb_range.irp.f +++ /dev/null @@ -1,89 +0,0 @@ - - - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 1 - state_av_act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 2 - state_av_act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_two_rdm_state_av(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - print*,'' - print*,'' - print*,'' - print*,'providint state_av_act_two_rdm_alpha_beta_mo ' - ispin = 3 - print*,'ispin = ',ispin - state_av_act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - BEGIN_DOC -! state_av_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices -! The active part of the two-electron energy can be computed as: -! -! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > -! -! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) - END_DOC - double precision, allocatable :: state_weights(:) - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 4 - state_av_act_two_rdm_spin_trace_mo = 0.d0 - integer :: i - double precision :: wall_0,wall_1 - call wall_time(wall_0) - print*,'providing the state average TWO-RDM ...' - print*,'psi_det_size = ',psi_det_size - print*,'N_det = ',N_det - call orb_range_two_rdm_state_av(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,N_states,size(psi_coef,1)) - - call wall_time(wall_1) - print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 - END_PROVIDER - diff --git a/src/two_body_rdm/orb_range_omp.irp.f b/src/two_body_rdm/orb_range_omp.irp.f deleted file mode 100644 index baa26ced..00000000 --- a/src/two_body_rdm/orb_range_omp.irp.f +++ /dev/null @@ -1,85 +0,0 @@ - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 1 - state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 2 - state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - double precision, allocatable :: state_weights(:) - BEGIN_DOC -! state_av_act_two_rdm_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs -! = - END_DOC - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - print*,'' - print*,'' - print*,'' - print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo ' - ispin = 3 - print*,'ispin = ',ispin - state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - END_PROVIDER - - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - BEGIN_DOC -! state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices -! The active part of the two-electron energy can be computed as: -! -! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > -! -! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) - END_DOC - double precision, allocatable :: state_weights(:) - allocate(state_weights(N_states)) - state_weights = state_average_weight - integer :: ispin - ! condition for alpha/beta spin - ispin = 4 - state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0 - integer :: i - double precision :: wall_0,wall_1 - call wall_time(wall_0) - print*,'providing the state average TWO-RDM ...' - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) - - call wall_time(wall_1) - print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 - END_PROVIDER - diff --git a/src/two_body_rdm/state_av_act_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f new file mode 100644 index 00000000..d85c3cdb --- /dev/null +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -0,0 +1,127 @@ + BEGIN_PROVIDER [double precision, state_av_act_2_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_2_rdm_ab_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * N_{\beta}^{act} +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta +! +! state_av_act_2_rdm_ab_mo(i,j,k,l) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessary have symmetry between electron 1 and 2 + END_DOC + allocate(state_weights(N_states)) + state_weights = state_average_weight + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint state_av_act_2_rdm_ab_mo ' + ispin = 3 + print*,'ispin = ',ispin + state_av_act_2_rdm_ab_mo = 0.d0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 + call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_ab_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_2_rdm_ab_mo',wall_2 - wall_1 + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, state_av_act_2_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_2_rdm_aa_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha}^{act} * (N_{\alpha}^{act} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + allocate(state_weights(N_states)) + state_weights = state_average_weight + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + state_av_act_2_rdm_aa_mo = 0.D0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 + call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_aa_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_2_rdm_aa_mo',wall_2 - wall_1 + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_act_2_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_2_rdm_bb_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta}^{act} * (N_{\beta}^{act} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + allocate(state_weights(N_states)) + state_weights = state_average_weight + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + state_av_act_2_rdm_bb_mo = 0.d0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 + call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_bb_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_2_rdm_bb_mo',wall_2 - wall_1 + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, state_av_act_2_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC +! state_av_act_2_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! +! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" + END_DOC + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = state_average_weight + integer :: ispin + ! condition for alpha/beta spin + ispin = 4 + state_av_act_2_rdm_spin_trace_mo = 0.d0 + integer :: i + call wall_time(wall_1) + double precision :: wall_1, wall_2 + print*,'providing state_av_act_2_rdm_spin_trace_mo ' + call orb_range_2_rdm_state_av_openmp(state_av_act_2_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_2) + print*,'Time to provide state_av_act_2_rdm_spin_trace_mo',wall_2 - wall_1 + END_PROVIDER + diff --git a/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f new file mode 100644 index 00000000..b3a5fe65 --- /dev/null +++ b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f @@ -0,0 +1,537 @@ + + BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_ab_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + implicit none + state_av_full_occ_2_rdm_ab_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_2_rdm_ab_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta} +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA +! +! state_av_full_occ_2_rdm_ab_mo(i,j,k,l) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessary have symmetry between electron 1 and 2 +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + state_av_full_occ_2_rdm_ab_mo = 0.d0 + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(lorb,korb,jorb,iorb) = & + state_av_act_2_rdm_ab_mo(l,k,j,i) + enddo + enddo + enddo + enddo + !! BETA ACTIVE - ALPHA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + + !! ALPHA ACTIVE - BETA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + + !! ALPHA INACTIVE - BETA INACTIVE + !! + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! BETA ACTIVE - ALPHA CORE + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + + !! ALPHA ACTIVE - BETA CORE + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + + !! ALPHA CORE - BETA CORE + !! + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 + enddo + enddo + endif + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_aa_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + implicit none + state_av_full_occ_2_rdm_aa_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_2_rdm_aa_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/alpha electrons +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * (N_{\alpha} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + + !! PURE ACTIVE PART ALPHA-ALPHA + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + state_av_full_occ_2_rdm_aa_mo(lorb,korb,jorb,iorb) = & + state_av_act_2_rdm_aa_mo(l,k,j,i) + enddo + enddo + enddo + enddo + !! ALPHA ACTIVE - ALPHA inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + + !! ALPHA INACTIVE - ALPHA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + +!!!!!!!!!! +!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! ALPHA ACTIVE - ALPHA CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + !! ALPHA CORE - ALPHA CORE + + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + state_av_full_occ_2_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_bb_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + implicit none + state_av_full_occ_2_rdm_bb_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! +! = \sum_{istate} w(istate) * +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\beta} * (N_{\beta} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + + !! PURE ACTIVE PART beta-beta + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + state_av_full_occ_2_rdm_bb_mo(lorb,korb,jorb,iorb) = & + state_av_act_2_rdm_bb_mo(l,k,j,i) + enddo + enddo + enddo + enddo + !! beta ACTIVE - beta inactive + !! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + + !! beta INACTIVE - beta INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + !! beta ACTIVE - beta CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + !! beta CORE - beta CORE + + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + state_av_full_occ_2_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_full_occ_2_rdm_spin_trace_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + implicit none + state_av_full_occ_2_rdm_spin_trace_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! +! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} +! +! +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active +! +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{elec} * (N_{elec} - 1)/2 +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero + END_DOC + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !! PURE ACTIVE PART SPIN-TRACE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_act_orb + korb = list_act(k) + do l = 1, n_act_orb + lorb = list_act(l) + state_av_full_occ_2_rdm_spin_trace_mo(lorb,korb,jorb,iorb) += & + state_av_act_2_rdm_spin_trace_mo(l,k,j,i) + enddo + enddo + enddo + enddo + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! BETA-BETA !!!!! + !! beta ACTIVE - beta inactive + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + !! beta INACTIVE - beta INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + if (.not.no_core_density)then + !! beta ACTIVE - beta CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + enddo + enddo + enddo + !! beta CORE - beta CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! ALPHA-ALPHA !!!!! + !! ALPHA ACTIVE - ALPHA inactive + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + !! ALPHA INACTIVE - ALPHA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + if (.not.no_core_density)then + !! ALPHA ACTIVE - ALPHA CORE + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + ! 1 2 1 2 : DIRECT TERM + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! 1 2 1 2 : EXCHANGE TERM + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + !! ALPHA CORE - ALPHA CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + !!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!! + !!!!! ALPHA-BETA + BETA-ALPHA !!!!! + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! ALPHA INACTIVE - BETA ACTIVE + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! beta alph beta alph + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + ! BETA INACTIVE - ALPHA ACTIVE + ! beta alph beta alpha + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + !! ALPHA INACTIVE - BETA INACTIVE + do j = 1, n_inact_orb + jorb = list_inact(j) + do k = 1, n_inact_orb + korb = list_inact(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0 + enddo + enddo + +!!!!!!!!!!!! +!!!!!!!!!!!! if "no_core_density" then you don't put the core part +!!!!!!!!!!!! CAN BE USED + if (.not.no_core_density)then + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_act_orb + jorb = list_act(j) + do k = 1, n_core_orb + korb = list_core(k) + !! BETA ACTIVE - ALPHA CORE + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_beta_average(jorb,iorb) + ! beta alph beta alph + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5D0 * one_e_dm_mo_beta_average(jorb,iorb) + !! ALPHA ACTIVE - BETA CORE + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5D0 * one_e_dm_mo_alpha_average(jorb,iorb) + ! beta alph beta alph + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_alpha_average(jorb,iorb) + enddo + enddo + enddo + !! ALPHA CORE - BETA CORE + do j = 1, n_core_orb + jorb = list_core(j) + do k = 1, n_core_orb + korb = list_core(k) + ! alph beta alph beta + state_av_full_occ_2_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 + state_av_full_occ_2_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0 + enddo + enddo + + endif + + END_PROVIDER diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f new file mode 100644 index 00000000..123261d8 --- /dev/null +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -0,0 +1,8 @@ +program test_2_rdm + implicit none + read_wf = .True. + touch read_wf + call routine_active_only + call routine_full_mos +end + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f deleted file mode 100644 index c162f365..00000000 --- a/src/two_body_rdm/two_rdm.irp.f +++ /dev/null @@ -1,62 +0,0 @@ - BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] -&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] -&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! two_rdm_alpha_beta(i,j,k,l) = - ! 1 1 2 2 = chemist notations - ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry - ! - END_DOC - integer :: dim1,dim2,dim3,dim4 - double precision :: cpu_0,cpu_1 - dim1 = mo_num - dim2 = mo_num - dim3 = mo_num - dim4 = mo_num - two_rdm_alpha_beta_mo = 0.d0 - two_rdm_alpha_alpha_mo= 0.d0 - two_rdm_beta_beta_mo = 0.d0 - print*,'providing two_rdm_alpha_beta ...' - call wall_time(cpu_0) - call all_two_rdm_dm_nstates(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] -&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] -&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = - ! 1 2 1 2 = physicist notations - ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry - ! - END_DOC - integer :: i,j,k,l,istate - double precision :: cpu_0,cpu_1 - two_rdm_alpha_beta_mo_physicist = 0.d0 - print*,'providing two_rdm_alpha_beta_mo_physicist ...' - call wall_time(cpu_0) - do istate = 1, N_states - do i = 1, mo_num - do j = 1, mo_num - do k = 1, mo_num - do l = 1, mo_num - ! 1 2 1 2 1 1 2 2 - two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) - two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) - two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) - enddo - enddo - enddo - enddo - enddo - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) - -END_PROVIDER - diff --git a/src/two_rdm_routines/NEED b/src/two_rdm_routines/NEED new file mode 100644 index 00000000..711fbf96 --- /dev/null +++ b/src/two_rdm_routines/NEED @@ -0,0 +1 @@ +davidson_undressed diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_rdm_routines/davidson_like_2rdm.irp.f similarity index 60% rename from src/two_body_rdm/orb_range_routines.irp.f rename to src/two_rdm_routines/davidson_like_2rdm.irp.f index 058ed1c5..3ad218e0 100644 --- a/src/two_body_rdm/orb_range_routines.irp.f +++ b/src/two_rdm_routines/davidson_like_2rdm.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_2_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -13,9 +13,8 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve END_DOC integer, intent(in) :: N_st,sze integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st) + double precision, intent(in) :: u_0(sze,N_st) integer :: k double precision, allocatable :: u_t(:,:) @@ -30,9 +29,8 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve u_t, & size(u_t, 1), & N_det, N_st) - - call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -41,7 +39,7 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve end -subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_2_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -51,9 +49,8 @@ subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb END_DOC integer, intent(in) :: N_st,sze,istart,iend,ishift,istep integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + double precision, intent(in) :: u_t(N_st,N_det) integer :: k @@ -61,15 +58,15 @@ subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb select case (N_int) case (1) - call orb_range_two_rdm_state_av_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_openmp_work_1(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_two_rdm_state_av_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_openmp_work_2(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_two_rdm_state_av_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_openmp_work_3(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_two_rdm_state_av_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_openmp_work_4(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_two_rdm_state_av_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -77,8 +74,9 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks + use omp_lib implicit none BEGIN_DOC ! Computes the two rdm for the N_st vectors |u_t> @@ -87,21 +85,18 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l ! == 3 :: alpha/beta 2rdm ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb - ! In any cases, the state average weights will be used with an array state_weights ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep END_DOC integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + double precision, intent(in) :: u_t(N_st,N_det) integer, intent(in) :: dim1,norb,list_orb(norb),ispin - integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(omp_lock_kind) :: lock_2rdm integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b + integer :: k_a, k_b, l_a, l_b + integer :: krow, kcol integer :: lrow, lcol - integer :: mrow, mcol integer(bit_kind) :: spindet($N_int) integer(bit_kind) :: tmp_det($N_int,2) integer(bit_kind) :: tmp_det2($N_int,2) @@ -113,11 +108,13 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l integer, allocatable :: singles_b(:) integer, allocatable :: idx(:), idx0(:) integer :: maxab, n_singles_a, n_singles_b, kcol_prev - integer*8 :: k8 - double precision :: c_average logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace integer(bit_kind) :: orb_bitmask($N_int) + integer :: list_orb_reverse(mo_num) + integer, allocatable :: keys(:,:) + double precision, allocatable :: values(:,:) + integer :: nkeys,sze_buff alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -131,51 +128,56 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_state_av_work' + print*,'Wrong parameter for ispin in general_2_rdm_state_av_openmp_work' print*,'ispin = ',ispin stop endif + - PROVIDE N_int call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) - + sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60 + list_orb_reverse = -1000 + do i = 1, norb + list_orb_reverse(list_orb(i)) = i + enddo maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 allocate(idx0(maxab)) do i=1,maxab idx0(i) = i enddo - + call omp_init_lock(lock_2rdm) ! Prepare the array of all alpha single excitations ! ------------------------------------------------- - PROVIDE N_int nthreads_davidson - !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & - ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & - ! !$OMP psi_bilinear_matrix_columns, & - ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& - ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& - ! !$OMP psi_bilinear_matrix_transp_rows, & - ! !$OMP psi_bilinear_matrix_transp_columns, & - ! !$OMP psi_bilinear_matrix_transp_order, N_st, & - ! !$OMP psi_bilinear_matrix_order_transp_reverse, & - ! !$OMP psi_bilinear_matrix_columns_loc, & - ! !$OMP psi_bilinear_matrix_transp_rows_loc, & - ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab) & - ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& - ! !$OMP lcol, lrow, l_a, l_b, & - ! !$OMP buffer, doubles, n_doubles, & - ! !$OMP tmp_det2, idx, l, kcol_prev, & - ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, k8) + PROVIDE N_int nthreads_davidson elec_alpha_num + !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,& + !$OMP psi_bilinear_matrix_columns, & + !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + !$OMP psi_bilinear_matrix_transp_rows, & + !$OMP psi_bilinear_matrix_transp_columns, & + !$OMP psi_bilinear_matrix_transp_order, N_st, & + !$OMP psi_bilinear_matrix_order_transp_reverse, & + !$OMP psi_bilinear_matrix_columns_loc, & + !$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, & + !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, dim1, & + !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, & + !$OMP lcol, lrow, l_a, l_b, & + !$OMP buffer, doubles, n_doubles, & + !$OMP tmp_det2, idx, l, kcol_prev, & + !$OMP singles_a, n_singles_a, singles_b, & + !$OMP n_singles_b, nkeys, keys, values) ! Alpha/Beta double excitations ! ============================= - + nkeys = 0 + allocate( keys(4,sze_buff), values(n_st,sze_buff)) allocate( buffer($N_int,maxab), & singles_a(maxab), & singles_b(maxab), & @@ -188,7 +190,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l ASSERT (istart > 0) ASSERT (istep > 0) - !!$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) @@ -247,22 +249,36 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l ASSERT (lrow <= N_det_alpha_unique) tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - c_average = 0.d0 +! print*,'nkeys before = ',nkeys do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_average += c_1(l) * c_2(l) * state_weights(l) + c_1(l) = u_t(l,l_a) * u_t(l,k_a) enddo - call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if(alpha_beta)then + ! only ONE contribution + if (nkeys+1 .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + else if (spin_trace)then + ! TWO contributions + if (nkeys+2 .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + endif + call orb_range_off_diag_double_to_all_states_ab_dm_buffer(tmp_det,tmp_det2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + enddo endif + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 enddo enddo - ! !$OMP END DO + !$OMP END DO - ! !$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep @@ -322,21 +338,28 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l ASSERT (lrow <= N_det_alpha_unique) tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - c_average = 0.d0 do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_average += c_1(l) * c_2(l) * state_weights(l) + c_1(l) = u_t(l,l_a) * u_t(l,k_a) enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_all_states_aa_dm_buffer(tmp_det,tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 ! Compute Hij for all alpha doubles ! ---------------------------------- @@ -349,15 +372,18 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l lrow = psi_bilinear_matrix_rows(l_a) ASSERT (lrow <= N_det_alpha_unique) - c_average = 0.d0 do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_average += c_1(l) * c_2(l) * state_weights(l) + c_1(l) = u_t(l,l_a) * u_t(l,k_a) enddo - call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_double_to_all_states_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) enddo endif + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 ! Single and double beta excitations @@ -414,19 +440,26 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) l_a = psi_bilinear_matrix_transp_order(l_b) - c_average = 0.d0 do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_average += c_1(l) * c_2(l) * state_weights(l) + c_1(l) = u_t(l,l_a) * u_t(l,k_a) enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_all_states_ab_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 * elec_alpha_num .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_single_to_all_states_bb_dm_buffer(tmp_det, tmp_det2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 ! Compute Hij for all beta doubles ! ---------------------------------- @@ -440,17 +473,21 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l ASSERT (lcol <= N_det_beta_unique) l_a = psi_bilinear_matrix_transp_order(l_b) - c_average = 0.d0 do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - c_average += c_1(l) * c_2(l) * state_weights(l) + c_1(l) = u_t(l,l_a) * u_t(l,k_a) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 .ge. sze_buff) then + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + endif + call orb_range_off_diag_double_to_all_states_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) +! print*,'to do orb_range_off_diag_double_to_2_rdm_bb_dm_buffer' ASSERT (l_a <= N_det) enddo endif + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 ! Diagonal contribution @@ -471,19 +508,21 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l double precision, external :: diag_wee_mat_elem, diag_S_mat_elem - double precision :: c_1(N_states),c_2(N_states) - c_average = 0.d0 + double precision :: c_1(N_states) do l = 1, N_states - c_1(l) = u_t(l,k_a) - c_average += c_1(l) * c_1(l) * state_weights(l) + c_1(l) = u_t(l,k_a) * u_t(l,k_a) enddo - call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 + call orb_range_diag_to_all_states_2_rdm_dm_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + nkeys = 0 end do - !!$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx) - !!$OMP END PARALLEL + !$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) + !$OMP END PARALLEL end @@ -497,3 +536,35 @@ end END_TEMPLATE + +subroutine update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) + use omp_lib + implicit none + integer, intent(in) :: n_st,nkeys,dim1 + integer, intent(in) :: keys(4,nkeys) + double precision, intent(in) :: values(n_st,nkeys) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,n_st) + + integer(omp_lock_kind),intent(inout):: lock_2rdm + + integer :: istate + integer :: i,h1,h2,p1,p2 + call omp_set_lock(lock_2rdm) + +! print*,'*************' +! print*,'updating' +! print*,'nkeys',nkeys + do i = 1, nkeys + h1 = keys(1,i) + h2 = keys(2,i) + p1 = keys(3,i) + p2 = keys(4,i) + do istate = 1, N_st +! print*,h1,h2,p1,p2,values(istate,i) + big_array(h1,h2,p1,p2,istate) += values(istate,i) + enddo + enddo + call omp_unset_lock(lock_2rdm) + +end + diff --git a/src/two_body_rdm/orb_range_routines_omp.irp.f b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f similarity index 86% rename from src/two_body_rdm/orb_range_routines_omp.irp.f rename to src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f index b6e59540..eb247dea 100644 --- a/src/two_body_rdm/orb_range_routines_omp.irp.f +++ b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_2_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -30,7 +30,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_ size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_2_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -39,7 +39,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_ end -subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_2_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -58,15 +58,15 @@ subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,s select case (N_int) case (1) - call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_2_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -74,7 +74,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks use omp_lib implicit none @@ -130,7 +130,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work' + print*,'Wrong parameter for ispin in general_2_rdm_state_av_openmp_work' print*,'ispin = ',ispin stop endif @@ -139,7 +139,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis PROVIDE N_int call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) - sze_buff = norb ** 3 + 6 * norb + sze_buff = 6 * norb + elec_alpha_num * elec_alpha_num * 60 list_orb_reverse = -1000 do i = 1, norb list_orb_reverse(list_orb(i)) = i @@ -270,11 +270,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis nkeys = 0 endif endif - call orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) - + call orb_range_off_diag_double_to_2_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + enddo endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 enddo enddo @@ -352,17 +354,19 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_single_to_2_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 ! Compute Hij for all alpha doubles ! ---------------------------------- @@ -385,9 +389,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_double_to_2_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) enddo endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 ! Single and double beta excitations @@ -456,15 +462,17 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations if (nkeys+4 * elec_alpha_num .ge. sze_buff) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_single_to_2_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 ! Compute Hij for all beta doubles ! ---------------------------------- @@ -488,7 +496,8 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif - call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_double_to_2_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) +! print*,'to do orb_range_off_diag_double_to_2_rdm_bb_dm_buffer' ASSERT (l_a <= N_det) enddo @@ -522,7 +531,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 - call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_diag_to_all_2_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 diff --git a/src/two_rdm_routines/update_rdm.irp.f b/src/two_rdm_routines/update_rdm.irp.f new file mode 100644 index 00000000..4d74280e --- /dev/null +++ b/src/two_rdm_routines/update_rdm.irp.f @@ -0,0 +1,881 @@ + subroutine orb_range_diag_to_all_states_2_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 + ! + ! c_1 is the array of the contributions to the rdm for all states + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2 + integer(bit_kind) :: det_1_act(N_int,2) + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + do i = 1, N_int + det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + enddo + + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) + logical :: is_integer_in_string + integer :: i1,i2,istate + if(alpha_beta)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + ! If alpha/beta, electron 1 is alpha, electron 2 is beta + ! Therefore you don't necessayr have symmetry between electron 1 and 2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = -0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + else if (beta_beta)then + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = -0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = -0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = -0.5d0 * c_1(istate) + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + endif + end + + + subroutine orb_range_off_diag_double_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another +! +! c_1 is the array of the contributions to the rdm for all states +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 = exc(1,1,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 = exc(1,2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(alpha_beta)then + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + else if(spin_trace)then + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = p1 + keys(2,nkeys) = p2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + endif + end + + subroutine orb_range_off_diag_single_to_all_states_ab_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,p1,istate + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_beta)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + endif + endif + end + + subroutine orb_range_off_diag_single_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 1 or 4 will do something + END_DOC + use bitmasks + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,p1,istate + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_alpha.or.spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diag_single_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,p1,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(beta_beta.or.spin_trace)then + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + endif + end + + + subroutine orb_range_off_diag_double_to_all_states_aa_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 1 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(alpha_alpha.or.spin_trace)then + nkeys += 1 + + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + + subroutine orb_range_off_diag_double_to_all_states_bb_dm_buffer(det_1,det_2,c_1,N_st,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + + integer, intent(in) :: ispin,sze_buff,N_st + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + double precision, intent(out) :: values(N_st,sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(beta_beta.or.spin_trace)then + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = - 0.5d0 * c_1(istate) * phase + enddo + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + diff --git a/src/two_body_rdm/compute_orb_range_omp.irp.f b/src/two_rdm_routines/update_state_av_rdm.irp.f similarity index 90% rename from src/two_body_rdm/compute_orb_range_omp.irp.f rename to src/two_rdm_routines/update_state_av_rdm.irp.f index 0ba934d7..35024331 100644 --- a/src/two_body_rdm/compute_orb_range_omp.irp.f +++ b/src/two_rdm_routines/update_state_av_rdm.irp.f @@ -1,4 +1,4 @@ - subroutine orb_range_diag_to_all_two_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_diag_to_all_2_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 @@ -57,6 +57,8 @@ i2 = occ(j,2) h1 = list_orb_reverse(i1) h2 = list_orb_reverse(i2) + ! If alpha/beta, electron 1 is alpha, electron 2 is beta + ! Therefore you don't necessayr have symmetry between electron 1 and 2 nkeys += 1 values(nkeys) = c_1 keys(1,nkeys) = h1 @@ -173,7 +175,7 @@ end - subroutine orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_double_to_2_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for @@ -255,7 +257,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_single_to_2_rdm_ab_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for @@ -281,6 +283,7 @@ integer, intent(in) :: ispin,sze_buff integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1 double precision, intent(out) :: values(sze_buff) integer , intent(out) :: keys(4,sze_buff) @@ -314,14 +317,14 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) nkeys += 1 values(nkeys) = c_1 * phase @@ -333,14 +336,14 @@ else ! Mono beta h1 = exc(1,1,2) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(1) h2 = occ(i,1) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) nkeys += 1 values(nkeys) = c_1 * phase @@ -354,14 +357,14 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) nkeys += 1 values(nkeys) = 0.5d0 * c_1 * phase @@ -379,19 +382,15 @@ else ! Mono beta h1 = exc(1,1,2) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) - !print*,'****************' - !print*,'****************' - !print*,'h1,p1',h1,p1 do i = 1, n_occ_ab(1) h2 = occ(i,1) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) - ! print*,'h2 = ',h2 nkeys += 1 values(nkeys) = 0.5d0 * c_1 * phase keys(1,nkeys) = h1 @@ -409,7 +408,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_single_to_2_rdm_aa_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for ! @@ -435,6 +434,7 @@ integer, intent(in) :: ispin,sze_buff integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1 double precision, intent(out) :: values(sze_buff) integer , intent(out) :: keys(4,sze_buff) @@ -468,14 +468,14 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(1) h2 = occ(i,1) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) nkeys += 1 @@ -512,7 +512,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_single_to_2_rdm_bb_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for @@ -538,6 +538,7 @@ integer, intent(in) :: ispin,sze_buff integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1 double precision, intent(out) :: values(sze_buff) integer , intent(out) :: keys(4,sze_buff) @@ -573,14 +574,14 @@ else ! Mono beta h1 = exc(1,1,2) - if(list_orb_reverse(h1).lt.0)return + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return h1 = list_orb_reverse(h1) p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)return + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - if(list_orb_reverse(h2).lt.0)return + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle h2 = list_orb_reverse(h2) nkeys += 1 values(nkeys) = 0.5d0 * c_1 * phase @@ -615,7 +616,7 @@ end - subroutine orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_double_to_2_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for @@ -710,7 +711,7 @@ endif end - subroutine orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + subroutine orb_range_off_diag_double_to_2_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for