From 3e0ada95387d4c606087e9494349d33528314c83 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 18 Mar 2020 15:13:49 +0100 Subject: [PATCH 01/29] beginning the cleaning of two_body_rdm --- src/density_for_dft/EZFIO.cfg | 6 +- src/density_for_dft/density_for_dft.irp.f | 4 +- src/two_body_rdm/README.rst | 1 + src/two_body_rdm/ab_only_routines.irp.f | 402 --------- src/two_body_rdm/all_2rdm_routines.irp.f | 442 ---------- ...> all_states_act_2_rdm_dav_routines.irp.f} | 0 ....irp.f => all_states_act_2_rdm_prov.irp.f} | 34 +- ...ll_states_act_2_rdm_update_routines.irp.f} | 0 src/two_body_rdm/compute.irp.f | 269 ------ src/two_body_rdm/compute_orb_range_omp.irp.f | 807 ------------------ src/two_body_rdm/orb_range_omp.irp.f | 85 -- src/two_body_rdm/orb_range_routines_omp.irp.f | 568 ------------ ... => state_av_act_2_rdm_dav_routines.irp.f} | 0 ...ge.irp.f => state_av_act_2_rdm_prov.irp.f} | 32 +- ... state_av_act_2_rdm_update_routines.irp.f} | 0 src/two_body_rdm/two_rdm.irp.f | 62 -- 16 files changed, 50 insertions(+), 2662 deletions(-) delete mode 100644 src/two_body_rdm/ab_only_routines.irp.f delete mode 100644 src/two_body_rdm/all_2rdm_routines.irp.f rename src/two_body_rdm/{all_states_routines.irp.f => all_states_act_2_rdm_dav_routines.irp.f} (100%) rename src/two_body_rdm/{all_states_2_rdm.irp.f => all_states_act_2_rdm_prov.irp.f} (64%) rename src/two_body_rdm/{compute_all_states.irp.f => all_states_act_2_rdm_update_routines.irp.f} (100%) delete mode 100644 src/two_body_rdm/compute.irp.f delete mode 100644 src/two_body_rdm/compute_orb_range_omp.irp.f delete mode 100644 src/two_body_rdm/orb_range_omp.irp.f delete mode 100644 src/two_body_rdm/orb_range_routines_omp.irp.f rename src/two_body_rdm/{orb_range_routines.irp.f => state_av_act_2_rdm_dav_routines.irp.f} (100%) rename src/two_body_rdm/{orb_range.irp.f => state_av_act_2_rdm_prov.irp.f} (68%) rename src/two_body_rdm/{compute_orb_range.irp.f => state_av_act_2_rdm_update_routines.irp.f} (100%) delete mode 100644 src/two_body_rdm/two_rdm.irp.f 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/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index 978240c9..69f1f2a4 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -6,3 +6,4 @@ 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. + 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/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_routines.irp.f b/src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f similarity index 100% rename from src/two_body_rdm/all_states_routines.irp.f rename to src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f similarity index 64% rename from src/two_body_rdm/all_states_2_rdm.irp.f rename to src/two_body_rdm/all_states_act_2_rdm_prov.irp.f index bc503223..fc6e4224 100644 --- a/src/two_body_rdm/all_states_2_rdm.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f @@ -5,8 +5,11 @@ 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 -! = +! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha electrons +! +! +! +! !!!!! 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 = 1.d0/dble(N_states) @@ -20,11 +23,14 @@ 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 -! = +! all_states_act_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta electrons +! +! +! +! !!!!! 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 = 1.d0/dble(N_states) integer :: ispin @@ -39,8 +45,11 @@ 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 -! = +! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! 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 = 1.d0/dble(N_states) @@ -61,10 +70,15 @@ 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: +! all_states_act_two_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM +! +! \sum_{\sigma, \sigma'} ! -! \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 > +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! The active part of the two-electron energy for the state istate 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,istate) * < ii jj | kk ll > ! ! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) END_DOC diff --git a/src/two_body_rdm/compute_all_states.irp.f b/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f similarity index 100% rename from src/two_body_rdm/compute_all_states.irp.f rename to src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f 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_orb_range_omp.irp.f b/src/two_body_rdm/compute_orb_range_omp.irp.f deleted file mode 100644 index 0ba934d7..00000000 --- a/src/two_body_rdm/compute_orb_range_omp.irp.f +++ /dev/null @@ -1,807 +0,0 @@ - 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) - 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 - ! - ! 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 - 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 - double precision, intent(out) :: values(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 - 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) - nkeys += 1 - values(nkeys) = c_1 - 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 - values(nkeys) = 0.5d0 * c_1 - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = -0.5d0 * c_1 - 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 - values(nkeys) = 0.5d0 * c_1 - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = -0.5d0 * c_1 - 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 - values(nkeys) = 0.5d0 * c_1 - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 - 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 - values(nkeys) = 0.5d0 * c_1 - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = -0.5d0 * c_1 - 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 - values(nkeys) = 0.5d0 * c_1 - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = -0.5d0 * c_1 - 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_two_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 -! -! 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 -! -! 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 - 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 - double precision, intent(out) :: values(sze_buff) - integer , intent(out) :: keys(4,sze_buff) - integer , intent(inout):: nkeys - 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 - 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 - values(nkeys) = c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = p2 - else if(spin_trace)then - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = p2 - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - 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_two_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 - ! - ! 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 - 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 - double precision, intent(out) :: values(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 - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - nkeys += 1 - values(nkeys) = c_1 * phase - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - nkeys += 1 - values(nkeys) = c_1 * phase - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - ! print*,'h2 = ',h2 - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = h2 - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - 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_two_rdm_aa_dm_buffer(det_1,det_2,c_1,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 - 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 - double precision, intent(out) :: values(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 - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,1) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = h2 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h2 - keys(2,nkeys) = h1 - keys(3,nkeys) = h2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - 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_two_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 - ! - ! 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 - 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 - double precision, intent(out) :: values(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 - 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(list_orb_reverse(h1).lt.0)return - h1 = list_orb_reverse(h1) - p1 = exc(1,2,2) - if(list_orb_reverse(p1).lt.0)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 - h2 = list_orb_reverse(h2) - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = h2 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = h2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h2 - keys(2,nkeys) = h1 - keys(3,nkeys) = h2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - 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_two_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 - ! - ! 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 - 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 - double precision, intent(out) :: values(sze_buff) - integer , intent(out) :: keys(4,sze_buff) - integer , intent(inout):: nkeys - - - 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(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 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = p2 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h2 - keys(2,nkeys) = h1 - keys(3,nkeys) = p2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - 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_two_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 - ! - ! 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 - 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 - double precision, intent(out) :: values(sze_buff) - integer , intent(out) :: keys(4,sze_buff) - integer , intent(inout):: nkeys - - 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(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 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p1 - keys(4,nkeys) = p2 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - keys(1,nkeys) = h1 - keys(2,nkeys) = h2 - keys(3,nkeys) = p2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase - keys(1,nkeys) = h2 - keys(2,nkeys) = h1 - keys(3,nkeys) = p2 - keys(4,nkeys) = p1 - - nkeys += 1 - values(nkeys) = - 0.5d0 * c_1 * phase - 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/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/orb_range_routines_omp.irp.f b/src/two_body_rdm/orb_range_routines_omp.irp.f deleted file mode 100644 index b6e59540..00000000 --- a/src/two_body_rdm/orb_range_routines_omp.irp.f +++ /dev/null @@ -1,568 +0,0 @@ -subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,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 - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - double precision, intent(in) :: u_0(sze,N_st),state_weights(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_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) - 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_two_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 - ! 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 - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) - - integer :: k - - PROVIDE N_int - - 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) - 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) - 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) - 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) - 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) - end select -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) - use bitmasks - use omp_lib - 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 - ! 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) - integer, intent(in) :: dim1,norb,list_orb(norb),ispin - 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 - integer :: krow, kcol - integer :: lrow, lcol - integer(bit_kind) :: spindet($N_int) - integer(bit_kind) :: tmp_det($N_int,2) - integer(bit_kind) :: tmp_det2($N_int,2) - integer(bit_kind) :: tmp_det3($N_int,2) - integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_doubles - integer, allocatable :: doubles(:) - integer, allocatable :: singles_a(:) - integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), idx0(:) - integer :: maxab, n_singles_a, n_singles_b, kcol_prev - 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. - 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_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 = norb ** 3 + 6 * norb - 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 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, state_weights, 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, c_2, & - !$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, c_average) - - ! Alpha/Beta double excitations - ! ============================= - nkeys = 0 - allocate( keys(4,sze_buff), values(sze_buff)) - allocate( buffer($N_int,maxab), & - singles_a(maxab), & - singles_b(maxab), & - doubles(maxab), & - idx(maxab)) - - kcol_prev=-1 - - ASSERT (iend <= N_det) - ASSERT (istart > 0) - ASSERT (istep > 0) - - !$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - if (kcol /= kcol_prev) then - call get_all_spin_singles_$N_int( & - psi_det_beta_unique, idx0, & - tmp_det(1,2), N_det_beta_unique, & - singles_b, n_singles_b) - endif - kcol_prev = kcol - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles_b - lcol = singles_b(i) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - ASSERT (l_a <= N_det) - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) - - ASSERT (l_a <= N_det) - idx(j) = l_a - l_a = l_a+1 - enddo - j = j-1 - - call get_all_spin_singles_$N_int( & - buffer, idx, tmp_det(1,1), j, & - singles_a, n_singles_a ) - - ! Loop over alpha singles - ! ----------------------- - - if(alpha_beta.or.spin_trace)then - do k = 1,n_singles_a - l_a = singles_a(k) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - 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) - enddo - if(alpha_beta)then - ! only ONE contribution - if (nkeys+1 .ge. size(values)) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - nkeys = 0 - endif - else if (spin_trace)then - ! TWO contributions - if (nkeys+2 .ge. size(values)) then - call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - 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) - - 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_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) - enddo - if(alpha_beta.or.spin_trace.or.alpha_alpha)then - ! increment the alpha/beta part for single excitations - if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then - call update_keys_values(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) - ! 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) - 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_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) - enddo - if (nkeys+4 .ge. sze_buff) then - 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) - 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_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) - enddo - if(alpha_beta.or.spin_trace.or.beta_beta)then - ! increment the alpha/beta part for single excitations - if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then - call update_keys_values(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) - ! 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) - 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_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) - enddo - if (nkeys+4 .ge. sze_buff) then - 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) - 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_average = 0.d0 - do l = 1, N_states - c_1(l) = u_t(l,k_a) - c_average += c_1(l) * c_1(l) * state_weights(l) - enddo - - 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 update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - nkeys = 0 - - end do - !$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) - !$OMP END PARALLEL - -end - - SUBST [ N_int ] - - 1;; - 2;; - 3;; - 4;; - N_int;; - - END_TEMPLATE - - -subroutine update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) - use omp_lib - implicit none - integer, intent(in) :: nkeys,dim1 - integer, intent(in) :: keys(4,nkeys) - double precision, intent(in) :: values(nkeys) - double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) - - integer(omp_lock_kind),intent(inout):: lock_2rdm - integer :: i,h1,h2,p1,p2 - call omp_set_lock(lock_2rdm) - do i = 1, nkeys - h1 = keys(1,i) - h2 = keys(2,i) - p1 = keys(3,i) - p2 = keys(4,i) - big_array(h1,h2,p1,p2) += values(i) - enddo - call omp_unset_lock(lock_2rdm) - -end - diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f similarity index 100% rename from src/two_body_rdm/orb_range_routines.irp.f rename to src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f diff --git a/src/two_body_rdm/orb_range.irp.f b/src/two_body_rdm/state_av_act_2_rdm_prov.irp.f similarity index 68% rename from src/two_body_rdm/orb_range.irp.f rename to src/two_body_rdm/state_av_act_2_rdm_prov.irp.f index 2bcd04dc..420a0264 100644 --- a/src/two_body_rdm/orb_range.irp.f +++ b/src/two_body_rdm/state_av_act_2_rdm_prov.irp.f @@ -5,8 +5,11 @@ 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 -! = +! state_av_act_two_rdm_alpha_alpha_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha electrons +! +! +! +! !!!!! 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 @@ -22,8 +25,11 @@ 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 -! = +! state_av_act_two_rdm_beta_beta_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta electrons +! +! +! +! !!!!! 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 @@ -39,8 +45,11 @@ 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 -! = +! state_av_act_two_rdm_alpha_beta_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! 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 @@ -61,13 +70,12 @@ 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: +! state_av_act_two_rdm_spin_trace_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM +! +! \sum_{\sigma, \sigma'} ! -! \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 +! !!!!! 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 diff --git a/src/two_body_rdm/compute_orb_range.irp.f b/src/two_body_rdm/state_av_act_2_rdm_update_routines.irp.f similarity index 100% rename from src/two_body_rdm/compute_orb_range.irp.f rename to src/two_body_rdm/state_av_act_2_rdm_update_routines.irp.f 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 - From c3f181c454c45839a8e0c6dc603174650bf006aa Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 19 Mar 2020 15:57:49 +0100 Subject: [PATCH 02/29] only active and full 2 rdms are ok --- src/determinants/cas_one_e_rdm.irp.f | 37 + src/two_body_rdm/NEED | 1 + .../all_states_act_2_rdm_dav_routines.irp.f | 1 + .../all_states_act_2_rdm_prov.irp.f | 25 +- ...all_states_act_2_rdm_update_routines.irp.f | 8 +- .../all_states_full_2_rdm_prov.irp.f | 538 ++++++++++++ src/two_body_rdm/compute_orb_range_omp.irp.f | 807 ++++++++++++++++++ src/two_body_rdm/orb_range_omp.irp.f | 85 ++ src/two_body_rdm/orb_range_routines_omp.irp.f | 568 ++++++++++++ src/two_body_rdm/test_2_rdm.irp.f | 111 +++ 10 files changed, 2163 insertions(+), 18 deletions(-) create mode 100644 src/determinants/cas_one_e_rdm.irp.f create mode 100644 src/two_body_rdm/all_states_full_2_rdm_prov.irp.f create mode 100644 src/two_body_rdm/compute_orb_range_omp.irp.f create mode 100644 src/two_body_rdm/orb_range_omp.irp.f create mode 100644 src/two_body_rdm/orb_range_routines_omp.irp.f create mode 100644 src/two_body_rdm/test_2_rdm.irp.f diff --git a/src/determinants/cas_one_e_rdm.irp.f b/src/determinants/cas_one_e_rdm.irp.f new file mode 100644 index 00000000..0471bde6 --- /dev/null +++ b/src/determinants/cas_one_e_rdm.irp.f @@ -0,0 +1,37 @@ + + BEGIN_PROVIDER [double precision, one_e_act_dm_beta_mo_for_dft, (n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC + ! one_e_act_dm_beta_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the BETA ELECTRONS + END_DOC + integer :: i,j,ii,jj,istate + do istate = 1, N_states + do ii = 1, n_act_orb + i = list_act(ii) + do jj = 1, n_act_orb + j = list_act(jj) + one_e_act_dm_beta_mo_for_dft(jj,ii,istate) = one_e_dm_mo_beta(j,i,istate) + enddo + enddo + enddo + +END_PROVIDER + + BEGIN_PROVIDER [double precision, one_e_act_dm_alpha_mo_for_dft, (n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC + ! one_e_act_dm_alpha_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the ALPHA ELECTRONS + END_DOC + integer :: i,j,ii,jj,istate + do istate = 1, N_states + do ii = 1, n_act_orb + i = list_act(ii) + do jj = 1, n_act_orb + j = list_act(jj) + one_e_act_dm_alpha_mo_for_dft(jj,ii,istate) = one_e_dm_mo_alpha(j,i,istate) + enddo + enddo + enddo + +END_PROVIDER + diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED index 711fbf96..ca42c679 100644 --- a/src/two_body_rdm/NEED +++ b/src/two_body_rdm/NEED @@ -1 +1,2 @@ davidson_undressed +density_for_dft diff --git a/src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f b/src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f index 8f40f32a..9d29332e 100644 --- a/src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f @@ -474,6 +474,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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 diff --git a/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f index fc6e4224..37a7d3fb 100644 --- a/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f @@ -3,22 +3,20 @@ 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,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha electrons ! -! +! 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 = 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)] @@ -30,9 +28,6 @@ ! ! !!!!! 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 = 1.d0/dble(N_states) integer :: ispin ! condition for alpha/beta spin ispin = 2 @@ -43,16 +38,19 @@ 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,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons ! ! ! ! !!!!! 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 +! +! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC - allocate(state_weights(N_states)) - state_weights = 1.d0/dble(N_states) integer :: ispin ! condition for alpha/beta spin print*,'' @@ -82,16 +80,11 @@ ! ! 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 + integer :: ispin,i,j,k,l,istate ! 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_act_2_rdm_update_routines.irp.f b/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f index 7606e353..a42f2d79 100644 --- a/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f @@ -59,7 +59,7 @@ 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. @@ -73,6 +73,7 @@ else if(ispin == 4)then spin_trace = .True. endif +! call debug_det(det_1_act,N_int) call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) logical :: is_integer_in_string integer :: i1,i2 @@ -84,7 +85,9 @@ i2 = occ(j,2) h1 = list_orb_reverse(i1) h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += c_1(istate) + ! If alpha/beta, electron 1 is alpha, electron 2 is beta + ! Therefore you don't necessayr have symmetry between electron 1 and 2 + big_array(h1,h2,h1,h2,istate) += 1.0d0 * c_1(istate) enddo enddo enddo @@ -101,6 +104,7 @@ enddo enddo enddo +! pause else if (beta_beta)then do istate = 1, N_st do i = 1, n_occ_ab(2) diff --git a/src/two_body_rdm/all_states_full_2_rdm_prov.irp.f b/src/two_body_rdm/all_states_full_2_rdm_prov.irp.f new file mode 100644 index 00000000..55fa78ca --- /dev/null +++ b/src/two_body_rdm/all_states_full_2_rdm_prov.irp.f @@ -0,0 +1,538 @@ + + BEGIN_PROVIDER [double precision, all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! all_states_full_two_rdm_alpha_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE RANGE OF OCCUPIED MOS (CORE+INACT+ACT) BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA +! +! all_states_act_two_rdm_alpha_beta_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 is set to zero + END_DOC + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_mo(lorb,korb,jorb,iorb,istate) = & + all_states_act_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_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 + all_states_full_two_rdm_alpha_beta_mo(korb,jorb,korb,jorb,istate) = 1.D0 + enddo + enddo + endif + + enddo + END_PROVIDER + + + BEGIN_PROVIDER [double precision, all_states_full_two_rdm_alpha_alpha_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 + all_states_full_two_rdm_alpha_alpha_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! all_states_full_two_rdm_alpha_alpha_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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) + all_states_full_two_rdm_alpha_alpha_mo(lorb,korb,jorb,iorb,istate) = & + all_states_act_two_rdm_alpha_alpha_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 + all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_rdm_alpha_alpha_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) + all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_rdm_alpha_alpha_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 + all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_rdm_alpha_alpha_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) + all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, all_states_full_two_rdm_beta_beta_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 + all_states_full_two_rdm_beta_beta_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! all_states_full_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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) + all_states_full_two_rdm_beta_beta_mo(lorb,korb,jorb,iorb,istate) = & + all_states_act_two_rdm_beta_beta_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 + all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_rdm_beta_beta_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + all_states_full_two_rdm_beta_beta_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_rdm_beta_beta_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) + all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_rdm_beta_beta_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 + all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_rdm_beta_beta_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! 1 2 1 2 : EXCHANGE TERM + all_states_full_two_rdm_beta_beta_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_rdm_beta_beta_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) + all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_rdm_beta_beta_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + enddo + enddo + endif + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb,istate + BEGIN_DOC +! all_states_full_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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 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) + all_states_full_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += & + all_states_act_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_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) + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + all_states_full_two_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) + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_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) + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + all_states_full_two_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) + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! beta alph beta alph + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! alph beta alph beta + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) + ! beta alph beta alph + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) + ! beta alph beta alph + all_states_full_two_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 + all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + all_states_full_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + enddo + enddo + + endif + enddo + + END_PROVIDER diff --git a/src/two_body_rdm/compute_orb_range_omp.irp.f b/src/two_body_rdm/compute_orb_range_omp.irp.f new file mode 100644 index 00000000..0ba934d7 --- /dev/null +++ b/src/two_body_rdm/compute_orb_range_omp.irp.f @@ -0,0 +1,807 @@ + 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) + 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 + ! + ! 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 + 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 + double precision, intent(out) :: values(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 + 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) + nkeys += 1 + values(nkeys) = c_1 + 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 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + 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 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + 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 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + 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 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + 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 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + 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_two_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 +! +! 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 +! +! 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 + 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 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + 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 + 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 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + else if(spin_trace)then + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + 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_two_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 + ! + ! 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 + 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 + double precision, intent(out) :: values(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 + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + ! print*,'h2 = ',h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + 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_two_rdm_aa_dm_buffer(det_1,det_2,c_1,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 + 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 + double precision, intent(out) :: values(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 + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + 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_two_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 + ! + ! 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 + 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 + double precision, intent(out) :: values(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 + 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(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)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 + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + 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_two_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 + ! + ! 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 + 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 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + + 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(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 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + 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_two_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 + ! + ! 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 + 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 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + 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(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 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + 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/orb_range_omp.irp.f b/src/two_body_rdm/orb_range_omp.irp.f new file mode 100644 index 00000000..baa26ced --- /dev/null +++ b/src/two_body_rdm/orb_range_omp.irp.f @@ -0,0 +1,85 @@ + + 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/orb_range_routines_omp.irp.f b/src/two_body_rdm/orb_range_routines_omp.irp.f new file mode 100644 index 00000000..b6e59540 --- /dev/null +++ b/src/two_body_rdm/orb_range_routines_omp.irp.f @@ -0,0 +1,568 @@ +subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,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 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_0(sze,N_st),state_weights(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_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) + 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_two_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 + ! 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 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + + integer :: k + + PROVIDE N_int + + 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) + 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) + 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) + 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) + 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) + end select +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) + use bitmasks + use omp_lib + 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 + ! 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) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + 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 + integer :: krow, kcol + integer :: lrow, lcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + 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. + 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_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 = norb ** 3 + 6 * norb + 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 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, state_weights, 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, c_2, & + !$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, c_average) + + ! Alpha/Beta double excitations + ! ============================= + nkeys = 0 + allocate( keys(4,sze_buff), values(sze_buff)) + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + 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) + enddo + if(alpha_beta)then + ! only ONE contribution + if (nkeys+1 .ge. size(values)) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + endif + else if (spin_trace)then + ! TWO contributions + if (nkeys+2 .ge. size(values)) then + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + 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) + + 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_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) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then + call update_keys_values(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) + ! 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) + 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_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) + enddo + if (nkeys+4 .ge. sze_buff) then + 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) + 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_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) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations + if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values(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) + ! 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) + 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_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) + enddo + if (nkeys+4 .ge. sze_buff) then + 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) + 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_average = 0.d0 + do l = 1, N_states + c_1(l) = u_t(l,k_a) + c_average += c_1(l) * c_1(l) * state_weights(l) + enddo + + 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 update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 + + end do + !$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) + !$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + +subroutine update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + use omp_lib + implicit none + integer, intent(in) :: nkeys,dim1 + integer, intent(in) :: keys(4,nkeys) + double precision, intent(in) :: values(nkeys) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer(omp_lock_kind),intent(inout):: lock_2rdm + integer :: i,h1,h2,p1,p2 + call omp_set_lock(lock_2rdm) + do i = 1, nkeys + h1 = keys(1,i) + h2 = keys(2,i) + p1 = keys(3,i) + p2 = keys(4,i) + big_array(h1,h2,p1,p2) += values(i) + enddo + call omp_unset_lock(lock_2rdm) + +end + 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..e993da24 --- /dev/null +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -0,0 +1,111 @@ +program test_2_rdm + implicit none + read_wf = .True. + touch read_wf + call routine_full_mos + call routine_active_only +end + +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,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot + double precision :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) + accu_aa = 0.d0 + accu_ab = 0.d0 + accu_bb = 0.d0 + accu_tot = 0.d0 + 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) + + rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) + rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) + rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) + + accu_ab(istate) += vijkl * rdmab + accu_aa(istate) += vijkl * rdmaa + accu_bb(istate) += vijkl * rdmbb + accu_tot(istate)+= vijkl * rdmtot + enddo + enddo + enddo + enddo + print*,'' + print*,'Active space only energy ' + print*,'accu_aa(istate) = ',accu_aa(istate) + print*,'accu_bb(istate) = ',accu_bb(istate) + print*,'accu_ab(istate) = ',accu_ab(istate) + print*,'' + print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) + print*,'accu_tot(istate) = ',accu_tot(istate) + print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) + enddo + +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 :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) + accu_aa = 0.d0 + accu_ab = 0.d0 + accu_bb = 0.d0 + accu_tot = 0.d0 + 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 = all_states_full_two_rdm_alpha_alpha_mo(l,k,j,i,istate) + rdmab = all_states_full_two_rdm_alpha_beta_mo(l,k,j,i,istate) + rdmbb = all_states_full_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmtot = all_states_full_two_rdm_spin_trace_mo(l,k,j,i,istate) + + accu_ab(istate) += vijkl * rdmab + accu_aa(istate) += vijkl * rdmaa + accu_bb(istate) += vijkl * rdmbb + accu_tot(istate)+= vijkl * rdmtot + enddo + enddo + enddo + enddo + print*,'Full energy ' + print*,'accu_aa(istate) = ',accu_aa(istate) + print*,'accu_bb(istate) = ',accu_bb(istate) + print*,'accu_ab(istate) = ',accu_ab(istate) + print*,'' + print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) + print*,'accu_tot(istate) = ',accu_tot(istate) + print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) + enddo + +end From cac0146fe99ea8979f6983fb12c9202fb9cb1664 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 10:41:03 +0100 Subject: [PATCH 03/29] orb range routines omp seem to work --- ...all_states_act_2_rdm_update_routines.irp.f | 1 - src/two_body_rdm/compute_orb_range_omp.irp.f | 51 ++++++++++--------- src/two_body_rdm/orb_range_routines_omp.irp.f | 10 ++-- src/two_body_rdm/test_2_rdm.irp.f | 17 ++++++- 4 files changed, 48 insertions(+), 31 deletions(-) diff --git a/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f b/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f index a42f2d79..3e4a070c 100644 --- a/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f @@ -73,7 +73,6 @@ else if(ispin == 4)then spin_trace = .True. endif -! call debug_det(det_1_act,N_int) call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) logical :: is_integer_in_string integer :: i1,i2 diff --git a/src/two_body_rdm/compute_orb_range_omp.irp.f b/src/two_body_rdm/compute_orb_range_omp.irp.f index 0ba934d7..9d0f3fe8 100644 --- a/src/two_body_rdm/compute_orb_range_omp.irp.f +++ b/src/two_body_rdm/compute_orb_range_omp.irp.f @@ -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 @@ -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_two_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_two_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_two_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 diff --git a/src/two_body_rdm/orb_range_routines_omp.irp.f b/src/two_body_rdm/orb_range_routines_omp.irp.f index b6e59540..bb195454 100644 --- a/src/two_body_rdm/orb_range_routines_omp.irp.f +++ b/src/two_body_rdm/orb_range_routines_omp.irp.f @@ -271,6 +271,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis 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) +! print*,'todo orb_range_off_diag_double_to_two_rdm_ab_dm_buffer' enddo endif @@ -352,13 +353,13 @@ 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_two_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_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo @@ -456,13 +457,13 @@ 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_two_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_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo @@ -489,6 +490,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis 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) +! print*,'to do orb_range_off_diag_double_to_two_rdm_bb_dm_buffer' ASSERT (l_a <= N_det) enddo diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index e993da24..27a25024 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -2,7 +2,7 @@ program test_2_rdm implicit none read_wf = .True. touch read_wf - call routine_full_mos +! call routine_full_mos call routine_active_only end @@ -16,6 +16,12 @@ subroutine routine_active_only double precision :: vijkl,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot double precision :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) + double precision :: accu_ab_omp,rdmab_omp + double precision :: accu_bb_omp,rdmbb_omp + double precision :: accu_aa_omp,rdmaa_omp + accu_ab_omp = 0.d0 + accu_bb_omp = 0.d0 + accu_aa_omp = 0.d0 accu_aa = 0.d0 accu_ab = 0.d0 accu_bb = 0.d0 @@ -34,11 +40,17 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) + rdmab_omp = state_av_act_two_rdm_openmp_alpha_beta_mo(l,k,j,i) + rdmbb_omp = state_av_act_two_rdm_openmp_beta_beta_mo(l,k,j,i) + rdmaa_omp = state_av_act_two_rdm_openmp_alpha_alpha_mo(l,k,j,i) rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) + accu_ab_omp += vijkl * rdmab_omp + accu_bb_omp += vijkl * rdmbb_omp + accu_aa_omp += vijkl * rdmaa_omp accu_ab(istate) += vijkl * rdmab accu_aa(istate) += vijkl * rdmaa accu_bb(istate) += vijkl * rdmbb @@ -50,8 +62,11 @@ subroutine routine_active_only print*,'' print*,'Active space only energy ' print*,'accu_aa(istate) = ',accu_aa(istate) + print*,'accu_aa_omp = ',accu_aa_omp print*,'accu_bb(istate) = ',accu_bb(istate) + print*,'accu_bb_omp = ',accu_bb_omp print*,'accu_ab(istate) = ',accu_ab(istate) + print*,'accu_ab_omp = ',accu_ab_omp print*,'' print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) print*,'accu_tot(istate) = ',accu_tot(istate) From 244831673d54272a3dfc029f5ae2425619892e70 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 11:04:36 +0100 Subject: [PATCH 04/29] openmp version of state average dm work --- .../all_states_act_2_rdm_prov.irp.f | 4 +++ src/two_body_rdm/orb_range_omp.irp.f | 22 +++++++++--- src/two_body_rdm/test_2_rdm.irp.f | 35 +++++++++++-------- 3 files changed, 42 insertions(+), 19 deletions(-) diff --git a/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f index 37a7d3fb..ca3ded6b 100644 --- a/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f +++ b/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f @@ -52,6 +52,7 @@ ! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC integer :: ispin + double precision :: wall_1, wall_2 ! condition for alpha/beta spin print*,'' print*,'' @@ -60,8 +61,11 @@ ispin = 3 print*,'ispin = ',ispin all_states_act_two_rdm_alpha_beta_mo = 0.d0 + call wall_time(wall_1) 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)) + call wall_time(wall_2) + print*,'Wall time to provide all_states_act_two_rdm_alpha_beta_mo',wall_2 - wall_1 END_PROVIDER diff --git a/src/two_body_rdm/orb_range_omp.irp.f b/src/two_body_rdm/orb_range_omp.irp.f index baa26ced..e4a34abd 100644 --- a/src/two_body_rdm/orb_range_omp.irp.f +++ b/src/two_body_rdm/orb_range_omp.irp.f @@ -12,7 +12,11 @@ ! condition for alpha/beta spin ispin = 1 state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 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)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_two_rdm_openmp_alpha_alpha_mo',wall_2 - wall_1 END_PROVIDER @@ -29,7 +33,11 @@ ! condition for alpha/beta spin ispin = 2 state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 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)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_two_rdm_openmp_beta_beta_mo',wall_2 - wall_1 END_PROVIDER @@ -51,7 +59,11 @@ ispin = 3 print*,'ispin = ',ispin state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0 + call wall_time(wall_1) + double precision :: wall_1, wall_2 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)) + call wall_time(wall_2) + print*,'Wall time to provide state_av_act_two_rdm_openmp_alpha_beta_mo',wall_2 - wall_1 END_PROVIDER @@ -74,12 +86,12 @@ 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 wall_time(wall_1) + double precision :: wall_1, wall_2 + print*,'providing state_av_act_two_rdm_openmp_spin_trace_mo ' 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 + call wall_time(wall_2) + print*,'Time to provide state_av_act_two_rdm_openmp_spin_trace_mo',wall_2 - wall_1 END_PROVIDER diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index 27a25024..fe010abe 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -19,9 +19,11 @@ subroutine routine_active_only double precision :: accu_ab_omp,rdmab_omp double precision :: accu_bb_omp,rdmbb_omp double precision :: accu_aa_omp,rdmaa_omp + double precision :: accu_tot_omp,rdmtot_omp accu_ab_omp = 0.d0 accu_bb_omp = 0.d0 accu_aa_omp = 0.d0 + accu_tot_omp = 0.d0 accu_aa = 0.d0 accu_ab = 0.d0 accu_bb = 0.d0 @@ -40,21 +42,25 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdmab_omp = state_av_act_two_rdm_openmp_alpha_beta_mo(l,k,j,i) - rdmbb_omp = state_av_act_two_rdm_openmp_beta_beta_mo(l,k,j,i) - rdmaa_omp = state_av_act_two_rdm_openmp_alpha_alpha_mo(l,k,j,i) - rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) - rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) - rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) - rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) + rdmab_omp = state_av_act_two_rdm_openmp_alpha_beta_mo(l,k,j,i) + rdmbb_omp = state_av_act_two_rdm_openmp_beta_beta_mo(l,k,j,i) + rdmaa_omp = state_av_act_two_rdm_openmp_alpha_alpha_mo(l,k,j,i) + rdmtot_omp = state_av_act_two_rdm_openmp_spin_trace_mo(l,k,j,i) - accu_ab_omp += vijkl * rdmab_omp - accu_bb_omp += vijkl * rdmbb_omp - accu_aa_omp += vijkl * rdmaa_omp - accu_ab(istate) += vijkl * rdmab - accu_aa(istate) += vijkl * rdmaa - accu_bb(istate) += vijkl * rdmbb - accu_tot(istate)+= vijkl * rdmtot + rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) + rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) + rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) + + accu_ab_omp += vijkl * rdmab_omp + accu_bb_omp += vijkl * rdmbb_omp + accu_aa_omp += vijkl * rdmaa_omp + accu_tot_omp += vijkl * rdmtot_omp + + accu_ab(istate) += vijkl * rdmab + accu_aa(istate) += vijkl * rdmaa + accu_bb(istate) += vijkl * rdmbb + accu_tot(istate) += vijkl * rdmtot enddo enddo enddo @@ -70,6 +76,7 @@ subroutine routine_active_only print*,'' print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) print*,'accu_tot(istate) = ',accu_tot(istate) + print*,'accu_tot_omp = ',accu_tot_omp print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) enddo From d04774c435e35bb3177cd6a851ee0a033cfd454d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 14:30:46 +0100 Subject: [PATCH 05/29] still cleaning in two_body_rdm --- src/two_body_rdm/NEED | 2 +- ...2_rdm_prov.irp.f => all_states_prov.irp.f} | 0 ...rb_range_omp.irp.f => state_av_2rdm.irp.f} | 0 .../state_av_act_2_rdm_dav_routines.irp.f | 499 ------------- .../state_av_act_2_rdm_prov.irp.f | 97 --- .../state_av_act_2_rdm_update_routines.irp.f | 670 ------------------ .../all_states_david.irp.f} | 0 .../all_states_update.irp.f} | 0 .../state_av_david_omp.irp.f} | 0 .../state_av_update_omp.irp.f} | 0 10 files changed, 1 insertion(+), 1267 deletions(-) rename src/two_body_rdm/{all_states_act_2_rdm_prov.irp.f => all_states_prov.irp.f} (100%) rename src/two_body_rdm/{orb_range_omp.irp.f => state_av_2rdm.irp.f} (100%) delete mode 100644 src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f delete mode 100644 src/two_body_rdm/state_av_act_2_rdm_prov.irp.f delete mode 100644 src/two_body_rdm/state_av_act_2_rdm_update_routines.irp.f rename src/{two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f => two_rdm_routines/all_states_david.irp.f} (100%) rename src/{two_body_rdm/all_states_act_2_rdm_update_routines.irp.f => two_rdm_routines/all_states_update.irp.f} (100%) rename src/{two_body_rdm/orb_range_routines_omp.irp.f => two_rdm_routines/state_av_david_omp.irp.f} (100%) rename src/{two_body_rdm/compute_orb_range_omp.irp.f => two_rdm_routines/state_av_update_omp.irp.f} (100%) diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED index ca42c679..221550d2 100644 --- a/src/two_body_rdm/NEED +++ b/src/two_body_rdm/NEED @@ -1,2 +1,2 @@ -davidson_undressed +two_rdm_routines density_for_dft diff --git a/src/two_body_rdm/all_states_act_2_rdm_prov.irp.f b/src/two_body_rdm/all_states_prov.irp.f similarity index 100% rename from src/two_body_rdm/all_states_act_2_rdm_prov.irp.f rename to src/two_body_rdm/all_states_prov.irp.f diff --git a/src/two_body_rdm/orb_range_omp.irp.f b/src/two_body_rdm/state_av_2rdm.irp.f similarity index 100% rename from src/two_body_rdm/orb_range_omp.irp.f rename to src/two_body_rdm/state_av_2rdm.irp.f diff --git a/src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f b/src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f deleted file mode 100644 index 058ed1c5..00000000 --- a/src/two_body_rdm/state_av_act_2_rdm_dav_routines.irp.f +++ /dev/null @@ -1,499 +0,0 @@ -subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,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) - double precision, intent(in) :: u_0(sze,N_st),state_weights(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_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) - 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_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) - 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) - double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) - - integer :: k - - PROVIDE N_int - - 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) - 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) - 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) - 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) - 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) - end select -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) - 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 - ! 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) - 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 :: 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 :: c_average - - 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_state_av_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)) - - 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_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) - 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) - 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_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) - 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) - ! 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) - 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_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) - 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) - 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_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) - 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) - ! 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) - 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_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) - 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) - 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_average = 0.d0 - do l = 1, N_states - c_1(l) = u_t(l,k_a) - c_average += c_1(l) * c_1(l) * state_weights(l) - enddo - - call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,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/state_av_act_2_rdm_prov.irp.f b/src/two_body_rdm/state_av_act_2_rdm_prov.irp.f deleted file mode 100644 index 420a0264..00000000 --- a/src/two_body_rdm/state_av_act_2_rdm_prov.irp.f +++ /dev/null @@ -1,97 +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 notation for 2RDM of alpha electrons -! -! -! -! !!!!! 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_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 notation for 2RDM of beta electrons -! -! -! -! !!!!! 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_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 notation for 2RDM of alpha/beta electrons -! -! -! -! !!!!! 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 - 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 notation for 2RDM -! -! \sum_{\sigma, \sigma'} -! -! !!!!! 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_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/state_av_act_2_rdm_update_routines.irp.f b/src/two_body_rdm/state_av_act_2_rdm_update_routines.irp.f deleted file mode 100644 index 52cccbf3..00000000 --- a/src/two_body_rdm/state_av_act_2_rdm_update_routines.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/all_states_act_2_rdm_dav_routines.irp.f b/src/two_rdm_routines/all_states_david.irp.f similarity index 100% rename from src/two_body_rdm/all_states_act_2_rdm_dav_routines.irp.f rename to src/two_rdm_routines/all_states_david.irp.f diff --git a/src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f b/src/two_rdm_routines/all_states_update.irp.f similarity index 100% rename from src/two_body_rdm/all_states_act_2_rdm_update_routines.irp.f rename to src/two_rdm_routines/all_states_update.irp.f diff --git a/src/two_body_rdm/orb_range_routines_omp.irp.f b/src/two_rdm_routines/state_av_david_omp.irp.f similarity index 100% rename from src/two_body_rdm/orb_range_routines_omp.irp.f rename to src/two_rdm_routines/state_av_david_omp.irp.f diff --git a/src/two_body_rdm/compute_orb_range_omp.irp.f b/src/two_rdm_routines/state_av_update_omp.irp.f similarity index 100% rename from src/two_body_rdm/compute_orb_range_omp.irp.f rename to src/two_rdm_routines/state_av_update_omp.irp.f From 068c3fa027176a13f550405d677c8081f24b7b32 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 14:36:52 +0100 Subject: [PATCH 06/29] beginning to put openmp in all_states 2rdm --- ...v.irp.f => all_states_full_orb_prov.irp.f} | 0 src/two_body_rdm/state_av_2rdm.irp.f | 46 +++++++++---------- src/two_body_rdm/test_2_rdm.irp.f | 8 ++-- 3 files changed, 27 insertions(+), 27 deletions(-) rename src/two_body_rdm/{all_states_full_2_rdm_prov.irp.f => all_states_full_orb_prov.irp.f} (100%) diff --git a/src/two_body_rdm/all_states_full_2_rdm_prov.irp.f b/src/two_body_rdm/all_states_full_orb_prov.irp.f similarity index 100% rename from src/two_body_rdm/all_states_full_2_rdm_prov.irp.f rename to src/two_body_rdm/all_states_full_orb_prov.irp.f diff --git a/src/two_body_rdm/state_av_2rdm.irp.f b/src/two_body_rdm/state_av_2rdm.irp.f index e4a34abd..c8c625bc 100644 --- a/src/two_body_rdm/state_av_2rdm.irp.f +++ b/src/two_body_rdm/state_av_2rdm.irp.f @@ -1,9 +1,9 @@ - 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)] + 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_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! 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)) @@ -11,20 +11,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 1 - state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0 + state_av_act_two_rdm_alpha_alpha_mo = 0.D0 call wall_time(wall_1) double precision :: wall_1, wall_2 - 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)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_alpha_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_two_rdm_openmp_alpha_alpha_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_alpha_alpha_mo',wall_2 - wall_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)] + 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_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! 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)) @@ -32,20 +32,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 2 - state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0 + state_av_act_two_rdm_beta_beta_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - 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)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_beta_beta_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_two_rdm_openmp_beta_beta_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_beta_beta_mo',wall_2 - wall_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)] + 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_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! 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)) @@ -55,26 +55,26 @@ print*,'' print*,'' print*,'' - print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo ' + print*,'providint state_av_act_two_rdm_alpha_beta_mo ' ispin = 3 print*,'ispin = ',ispin - state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0 + state_av_act_two_rdm_alpha_beta_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - 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)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_beta_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_two_rdm_openmp_alpha_beta_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_alpha_beta_mo',wall_2 - wall_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)] + 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_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! 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_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! \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 @@ -84,14 +84,14 @@ integer :: ispin ! condition for alpha/beta spin ispin = 4 - state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0 + state_av_act_two_rdm_spin_trace_mo = 0.d0 integer :: i call wall_time(wall_1) double precision :: wall_1, wall_2 - print*,'providing state_av_act_two_rdm_openmp_spin_trace_mo ' - 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)) + print*,'providing state_av_act_two_rdm_spin_trace_mo ' + call orb_range_two_rdm_state_av_openmp(state_av_act_two_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_two_rdm_openmp_spin_trace_mo',wall_2 - wall_1 + print*,'Time to provide state_av_act_two_rdm_spin_trace_mo',wall_2 - wall_1 END_PROVIDER diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index fe010abe..620bb03d 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -42,10 +42,10 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdmab_omp = state_av_act_two_rdm_openmp_alpha_beta_mo(l,k,j,i) - rdmbb_omp = state_av_act_two_rdm_openmp_beta_beta_mo(l,k,j,i) - rdmaa_omp = state_av_act_two_rdm_openmp_alpha_alpha_mo(l,k,j,i) - rdmtot_omp = state_av_act_two_rdm_openmp_spin_trace_mo(l,k,j,i) + rdmab_omp = state_av_act_two_rdm_alpha_beta_mo(l,k,j,i) + rdmbb_omp = state_av_act_two_rdm_beta_beta_mo(l,k,j,i) + rdmaa_omp = state_av_act_two_rdm_alpha_alpha_mo(l,k,j,i) + rdmtot_omp = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) From 27ab9ed2d7dc2cd6aeb8d0c7d258fb73a5eec3e7 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 20:22:48 +0100 Subject: [PATCH 07/29] alpha alpha 2rdm work for openmp --- src/two_body_rdm/test_2_rdm.irp.f | 33 +- src/two_rdm_routines/NEED | 1 + .../all_states_david_openmp.irp.f | 575 ++++++++++++ src/two_rdm_routines/all_states_update.irp.f | 28 - .../all_states_update_openmp.irp.f | 867 ++++++++++++++++++ 5 files changed, 1461 insertions(+), 43 deletions(-) create mode 100644 src/two_rdm_routines/NEED create mode 100644 src/two_rdm_routines/all_states_david_openmp.irp.f create mode 100644 src/two_rdm_routines/all_states_update_openmp.irp.f diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index 620bb03d..7a5bfec5 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -42,25 +42,28 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdmab_omp = state_av_act_two_rdm_alpha_beta_mo(l,k,j,i) - rdmbb_omp = state_av_act_two_rdm_beta_beta_mo(l,k,j,i) - rdmaa_omp = state_av_act_two_rdm_alpha_alpha_mo(l,k,j,i) - rdmtot_omp = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) +! rdmab_omp = state_av_act_two_rdm_alpha_beta_mo(l,k,j,i) +! rdmbb_omp = state_av_act_two_rdm_beta_beta_mo(l,k,j,i) +! rdmaa_omp = state_av_act_two_rdm_alpha_alpha_mo(l,k,j,i) +! rdmtot_omp = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) + + + rdmab_omp = all_states_openmp_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) + rdmaa_omp = all_states_openmp_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) - rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) +! rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) - rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) +! rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) accu_ab_omp += vijkl * rdmab_omp - accu_bb_omp += vijkl * rdmbb_omp accu_aa_omp += vijkl * rdmaa_omp - accu_tot_omp += vijkl * rdmtot_omp +! accu_tot_omp += vijkl * rdmtot_omp accu_ab(istate) += vijkl * rdmab accu_aa(istate) += vijkl * rdmaa - accu_bb(istate) += vijkl * rdmbb - accu_tot(istate) += vijkl * rdmtot +! accu_bb(istate) += vijkl * rdmbb +! accu_tot(istate) += vijkl * rdmtot enddo enddo enddo @@ -69,14 +72,14 @@ subroutine routine_active_only print*,'Active space only energy ' print*,'accu_aa(istate) = ',accu_aa(istate) print*,'accu_aa_omp = ',accu_aa_omp - print*,'accu_bb(istate) = ',accu_bb(istate) - print*,'accu_bb_omp = ',accu_bb_omp +! print*,'accu_bb(istate) = ',accu_bb(istate) +! print*,'accu_bb_omp = ',accu_bb_omp print*,'accu_ab(istate) = ',accu_ab(istate) print*,'accu_ab_omp = ',accu_ab_omp print*,'' - print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) - print*,'accu_tot(istate) = ',accu_tot(istate) - print*,'accu_tot_omp = ',accu_tot_omp +! print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) +! print*,'accu_tot(istate) = ',accu_tot(istate) +! print*,'accu_tot_omp = ',accu_tot_omp print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) enddo 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_rdm_routines/all_states_david_openmp.irp.f b/src/two_rdm_routines/all_states_david_openmp.irp.f new file mode 100644 index 00000000..bdcafd6c --- /dev/null +++ b/src/two_rdm_routines/all_states_david_openmp.irp.f @@ -0,0 +1,575 @@ +subroutine orb_range_two_rdm_all_states_openmp_openmp(big_array,dim1,norb,list_orb,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 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + 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_two_rdm_all_states_openmp_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine orb_range_two_rdm_all_states_openmp_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_t(N_st,N_det) + + integer :: k + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_two_rdm_all_states_openmp_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_all_states_openmp_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_all_states_openmp_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_all_states_openmp_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_all_states_openmp_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + + + + BEGIN_TEMPLATE +subroutine orb_range_two_rdm_all_states_openmp_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> + ! 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 + 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 + integer :: krow, kcol + integer :: lrow, lcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) + integer :: list_orb_reverse(mo_num) + integer, allocatable :: keys(:,:) + double precision, allocatable :: values(:,:) + integer :: nkeys,sze_buff + 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_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 + 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 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), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) +! print*,'nkeys before = ',nkeys + do l= 1, N_states + c_1(l) = u_t(l,l_a) * u_t(l,k_a) + enddo + 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) +! print*,'coucou' + 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 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) * u_t(l,k_a) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then + call update_keys_values_n_states(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 + 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_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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) +! print*,'to do orb_range_off_diag_single_to_two_rdm_aa_dm_buffer' + 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 + ! ---------------------------------- + + if(alpha_alpha.or.spin_trace)then + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + do l= 1, N_states + c_1(l) = u_t(l,l_a) * u_t(l,k_a) + enddo + 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) +! print*,'to do orb_range_off_diag_double_to_two_rdm_aa_dm_buffer' + 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 + ! ================================== + + + ! 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) * u_t(l,k_a) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations + if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then + call update_keys_values_n_states(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) +! print*,'to do orb_range_off_diag_single_to_two_rdm_ab_dm_buffer' + ! increment the beta /beta part for single excitations + 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_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) +! print*,'to do orb_range_off_diag_single_to_two_rdm_bb_dm_buffer' + 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 + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) * u_t(l,k_a) + enddo + 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_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) +! print*,'to do orb_range_off_diag_double_to_two_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 + ! ===================== + + + ! 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) + do l = 1, N_states + c_1(l) = u_t(l,k_a) * u_t(l,k_a) + enddo + + 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_two_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, keys, values) + !$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + 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_rdm_routines/all_states_update.irp.f b/src/two_rdm_routines/all_states_update.irp.f index 3e4a070c..6d5c62fa 100644 --- a/src/two_rdm_routines/all_states_update.irp.f +++ b/src/two_rdm_routines/all_states_update.irp.f @@ -1,31 +1,3 @@ - - 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 diff --git a/src/two_rdm_routines/all_states_update_openmp.irp.f b/src/two_rdm_routines/all_states_update_openmp.irp.f new file mode 100644 index 00000000..99b1df53 --- /dev/null +++ b/src/two_rdm_routines/all_states_update_openmp.irp.f @@ -0,0 +1,867 @@ + subroutine orb_range_diag_to_all_states_two_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 +! print*,'coucou' + nkeys += 1 + do istate = 1, N_st + values(istate,nkeys) = c_1(istate) * phase +! print*,'values',values(istate,nkeys),nkeys + 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_two_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 + ! + ! 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 + 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) + integer , intent(inout):: nkeys + + 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) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + 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_two_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 + ! + ! 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 + 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 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + 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(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 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + From d7b2714521795562f4b69908ae63cd35c0052595 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 20:32:16 +0100 Subject: [PATCH 08/29] alpha beta 2rdm work for openmp --- src/two_body_rdm/test_2_rdm.irp.f | 10 ++-- .../all_states_david_openmp.irp.f | 5 +- .../all_states_update_openmp.irp.f | 52 ++++++++++++------- 3 files changed, 42 insertions(+), 25 deletions(-) diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index 7a5bfec5..cbe1c1e3 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -50,19 +50,21 @@ subroutine routine_active_only rdmab_omp = all_states_openmp_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) rdmaa_omp = all_states_openmp_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) + rdmbb_omp = all_states_openmp_act_two_rdm_beta_beta_mo(l,k,j,i,istate) rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) -! rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) ! rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) accu_ab_omp += vijkl * rdmab_omp accu_aa_omp += vijkl * rdmaa_omp + accu_bb_omp += vijkl * rdmbb_omp ! accu_tot_omp += vijkl * rdmtot_omp accu_ab(istate) += vijkl * rdmab accu_aa(istate) += vijkl * rdmaa -! accu_bb(istate) += vijkl * rdmbb + accu_bb(istate) += vijkl * rdmbb ! accu_tot(istate) += vijkl * rdmtot enddo enddo @@ -72,8 +74,8 @@ subroutine routine_active_only print*,'Active space only energy ' print*,'accu_aa(istate) = ',accu_aa(istate) print*,'accu_aa_omp = ',accu_aa_omp -! print*,'accu_bb(istate) = ',accu_bb(istate) -! print*,'accu_bb_omp = ',accu_bb_omp + print*,'accu_bb(istate) = ',accu_bb(istate) + print*,'accu_bb_omp = ',accu_bb_omp print*,'accu_ab(istate) = ',accu_ab(istate) print*,'accu_ab_omp = ',accu_ab_omp print*,'' diff --git a/src/two_rdm_routines/all_states_david_openmp.irp.f b/src/two_rdm_routines/all_states_david_openmp.irp.f index bdcafd6c..0da7e205 100644 --- a/src/two_rdm_routines/all_states_david_openmp.irp.f +++ b/src/two_rdm_routines/all_states_david_openmp.irp.f @@ -459,8 +459,7 @@ subroutine orb_range_two_rdm_all_states_openmp_openmp_work_$N_int(big_array,dim1 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_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) -! print*,'to do orb_range_off_diag_single_to_two_rdm_bb_dm_buffer' + 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) @@ -485,7 +484,7 @@ subroutine orb_range_two_rdm_all_states_openmp_openmp_work_$N_int(big_array,dim1 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_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_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_two_rdm_bb_dm_buffer' ASSERT (l_a <= N_det) diff --git a/src/two_rdm_routines/all_states_update_openmp.irp.f b/src/two_rdm_routines/all_states_update_openmp.irp.f index 99b1df53..41cb94bc 100644 --- a/src/two_rdm_routines/all_states_update_openmp.irp.f +++ b/src/two_rdm_routines/all_states_update_openmp.irp.f @@ -562,7 +562,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 @@ -585,18 +585,18 @@ ! here, only ispin == 2 or 4 will do something END_DOC implicit none - integer, intent(in) :: ispin,sze_buff + 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 - double precision, intent(out) :: values(sze_buff) + 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 + 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 @@ -634,28 +634,36 @@ 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 + 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 - values(nkeys) = - 0.5d0 * c_1 * phase + 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 - values(nkeys) = 0.5d0 * c_1 * phase + 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 - values(nkeys) = - 0.5d0 * c_1 * phase + 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 @@ -770,7 +778,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_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 @@ -794,15 +802,15 @@ END_DOC implicit none - integer, intent(in) :: ispin,sze_buff + 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 - double precision, intent(out) :: values(sze_buff) + 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 + 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 @@ -836,28 +844,36 @@ p2 = list_orb_reverse(p2) if(beta_beta.or.spin_trace)then nkeys += 1 - values(nkeys) = 0.5d0 * c_1 * phase + 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 - values(nkeys) = - 0.5d0 * c_1 * phase + 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 - values(nkeys) = 0.5d0 * c_1 * phase + 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 - values(nkeys) = - 0.5d0 * c_1 * phase + 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 From d96108f77223ae675270a8e505488dbc491399e7 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 20 Mar 2020 22:20:12 +0100 Subject: [PATCH 09/29] openmp for multi state 2rdm work --- src/two_body_rdm/all_states_prov.irp.f | 24 ++++++++--- src/two_body_rdm/test_2_rdm.irp.f | 55 +++++++++++++------------- 2 files changed, 46 insertions(+), 33 deletions(-) diff --git a/src/two_body_rdm/all_states_prov.irp.f b/src/two_body_rdm/all_states_prov.irp.f index ca3ded6b..5523faa2 100644 --- a/src/two_body_rdm/all_states_prov.irp.f +++ b/src/two_body_rdm/all_states_prov.irp.f @@ -14,8 +14,12 @@ ! condition for alpha/beta spin ispin = 1 all_states_act_two_rdm_alpha_alpha_mo = 0.D0 + double precision :: wall_1,wall_2 + call wall_time(wall_1) + print*,'providing all_states_act_two_rdm_alpha_alpha_mo ...' 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)) - + call wall_time(wall_2) + print*,'time to provide all_states_act_two_rdm_alpha_alpha_mo',wall_2 - wall_1 END_PROVIDER @@ -32,7 +36,12 @@ ! condition for alpha/beta spin ispin = 2 all_states_act_two_rdm_beta_beta_mo = 0.d0 + double precision :: wall_1,wall_2 + call wall_time(wall_1) + print*,'providing all_states_act_two_rdm_beta_beta_mo ...' 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)) + call wall_time(wall_2) + print*,'time to provide all_states_act_two_rdm_beta_beta_mo',wall_2 - wall_1 END_PROVIDER @@ -54,10 +63,8 @@ integer :: ispin double precision :: wall_1, wall_2 ! condition for alpha/beta spin - print*,'' - print*,'' - print*,'' - print*,'providint all_states_act_two_rdm_alpha_beta_mo ' + call wall_time(wall_1) + print*,'providing all_states_act_two_rdm_alpha_beta_mo ...' ispin = 3 print*,'ispin = ',ispin all_states_act_two_rdm_alpha_beta_mo = 0.d0 @@ -65,7 +72,7 @@ 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)) call wall_time(wall_2) - print*,'Wall time to provide all_states_act_two_rdm_alpha_beta_mo',wall_2 - wall_1 + print*,'time to provide all_states_act_two_rdm_alpha_beta_mo',wall_2 - wall_1 END_PROVIDER @@ -89,6 +96,11 @@ ispin = 4 all_states_act_two_rdm_spin_trace_mo = 0.d0 + double precision :: wall_1,wall_2 + call wall_time(wall_1) + print*,'providing all_states_act_two_rdm_spin_trace_mo ...' 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)) + call wall_time(wall_2) + print*,'time to provide all_states_act_two_rdm_spin_trace_mo',wall_2 - wall_1 END_PROVIDER diff --git a/src/two_body_rdm/test_2_rdm.irp.f b/src/two_body_rdm/test_2_rdm.irp.f index cbe1c1e3..9ba57e37 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -16,10 +16,10 @@ subroutine routine_active_only double precision :: vijkl,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot double precision :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) - double precision :: accu_ab_omp,rdmab_omp - double precision :: accu_bb_omp,rdmbb_omp - double precision :: accu_aa_omp,rdmaa_omp - double precision :: accu_tot_omp,rdmtot_omp + double precision :: accu_ab_omp(N_states),rdmab_omp + double precision :: accu_bb_omp(N_states),rdmbb_omp + double precision :: accu_aa_omp(N_states),rdmaa_omp + double precision :: accu_tot_omp(N_states),rdmtot_omp accu_ab_omp = 0.d0 accu_bb_omp = 0.d0 accu_aa_omp = 0.d0 @@ -48,40 +48,41 @@ subroutine routine_active_only ! rdmtot_omp = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) - rdmab_omp = all_states_openmp_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) - rdmaa_omp = all_states_openmp_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) - rdmbb_omp = all_states_openmp_act_two_rdm_beta_beta_mo(l,k,j,i,istate) +! rdmab_omp = all_states_openmp_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) +! rdmaa_omp = all_states_openmp_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) +! rdmbb_omp = all_states_openmp_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmtot_omp = all_states_openmp_act_two_rdm_spin_trace_mo(l,k,j,i,istate) - rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) - rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) - rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) -! rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) +! rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) +! rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) +! rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) - accu_ab_omp += vijkl * rdmab_omp - accu_aa_omp += vijkl * rdmaa_omp - accu_bb_omp += vijkl * rdmbb_omp -! accu_tot_omp += vijkl * rdmtot_omp +! accu_ab_omp(istate) += vijkl * rdmab_omp +! accu_aa_omp(istate) += vijkl * rdmaa_omp +! accu_bb_omp(istate) += vijkl * rdmbb_omp + accu_tot_omp(istate) += vijkl * rdmtot_omp - accu_ab(istate) += vijkl * rdmab - accu_aa(istate) += vijkl * rdmaa - accu_bb(istate) += vijkl * rdmbb -! accu_tot(istate) += vijkl * rdmtot +! accu_ab(istate) += vijkl * rdmab +! accu_aa(istate) += vijkl * rdmaa +! accu_bb(istate) += vijkl * rdmbb + accu_tot(istate) += vijkl * rdmtot enddo enddo enddo enddo print*,'' print*,'Active space only energy ' - print*,'accu_aa(istate) = ',accu_aa(istate) - print*,'accu_aa_omp = ',accu_aa_omp - print*,'accu_bb(istate) = ',accu_bb(istate) - print*,'accu_bb_omp = ',accu_bb_omp - print*,'accu_ab(istate) = ',accu_ab(istate) - print*,'accu_ab_omp = ',accu_ab_omp +! print*,'accu_aa(istate) = ',accu_aa(istate) +! print*,'accu_aa_omp = ',accu_aa_omp(istate) +! print*,'accu_bb(istate) = ',accu_bb(istate) +! print*,'accu_bb_omp = ',accu_bb_omp(istate) +! print*,'accu_ab(istate) = ',accu_ab(istate) +! print*,'accu_ab_omp = ',accu_ab_omp(istate) print*,'' ! print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) -! print*,'accu_tot(istate) = ',accu_tot(istate) -! print*,'accu_tot_omp = ',accu_tot_omp + print*,'accu_tot(istate) = ',accu_tot(istate) + print*,'accu_tot_omp = ',accu_tot_omp(istate) print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) enddo From 6b282c042ce14126ab822ad7209626ba7b54e85c Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 17:15:39 +0100 Subject: [PATCH 10/29] all 2rdm clean and work with openmp --- src/two_body_rdm/act_2_rdm.irp.f | 130 +++++ src/two_body_rdm/all_states_prov.irp.f | 106 ---- src/two_body_rdm/example.irp.f | 261 +++++++++ ...ll_orb_prov.irp.f => full_orb_2_rdm.irp.f} | 176 +++--- ..._av_2rdm.irp.f => state_av_act_2rdm.irp.f} | 32 +- .../state_av_full_orb_2_rdm.irp.f | 528 ++++++++++++++++++ src/two_body_rdm/test_2_rdm.irp.f | 133 +---- .../all_states_david_openmp.irp.f | 18 +- 8 files changed, 1033 insertions(+), 351 deletions(-) create mode 100644 src/two_body_rdm/act_2_rdm.irp.f delete mode 100644 src/two_body_rdm/all_states_prov.irp.f create mode 100644 src/two_body_rdm/example.irp.f rename src/two_body_rdm/{all_states_full_orb_prov.irp.f => full_orb_2_rdm.irp.f} (57%) rename src/two_body_rdm/{state_av_2rdm.irp.f => state_av_act_2rdm.irp.f} (59%) create mode 100644 src/two_body_rdm/state_av_full_orb_2_rdm.irp.f 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..af22946f --- /dev/null +++ b/src/two_body_rdm/act_2_rdm.irp.f @@ -0,0 +1,130 @@ + + BEGIN_PROVIDER [double precision, act_two_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_two_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! 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_two_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessayr have symmetry between electron 1 and 2 + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'Providing act_two_rdm_ab_mo ' + ispin = 3 + print*,'ispin = ',ispin + act_two_rdm_ab_mo = 0.d0 + call wall_time(wall_1) + call orb_range_two_rdm_openmp(act_two_rdm_ab_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_2) + print*,'Wall time to provide act_two_rdm_ab_mo',wall_2 - wall_1 + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_two_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_two_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! 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_two_rdm_aa_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! +! Therefore you don't necessayr have symmetry between electron 1 and 2 + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'Providing act_two_rdm_aa_mo ' + ispin = 1 + print*,'ispin = ',ispin + act_two_rdm_aa_mo = 0.d0 + call wall_time(wall_1) + call orb_range_two_rdm_openmp(act_two_rdm_aa_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_2) + print*,'Wall time to provide act_two_rdm_aa_mo',wall_2 - wall_1 + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_two_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta +! +! act_two_rdm_bb_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta +! +! Therefore you don't necessayr have symmetry between electron 1 and 2 + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for beta/beta spin + print*,'' + print*,'' + print*,'' + print*,'Providing act_two_rdm_bb_mo ' + ispin = 2 + print*,'ispin = ',ispin + act_two_rdm_bb_mo = 0.d0 + call wall_time(wall_1) + call orb_range_two_rdm_openmp(act_two_rdm_bb_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_2) + print*,'Wall time to provide act_two_rdm_bb_mo',wall_2 - wall_1 + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! act_two_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta +! +! act_two_rdm_spin_trace_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta +! +! Therefore you don't necessayr have symmetry between electron 1 and 2 + END_DOC + integer :: ispin + double precision :: wall_1, wall_2 + ! condition for beta/beta spin + print*,'' + print*,'' + print*,'' + print*,'Providing act_two_rdm_spin_trace_mo ' + ispin = 4 + print*,'ispin = ',ispin + act_two_rdm_spin_trace_mo = 0.d0 + call wall_time(wall_1) + call orb_range_two_rdm_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_2) + print*,'Wall time to provide act_two_rdm_spin_trace_mo',wall_2 - wall_1 + END_PROVIDER diff --git a/src/two_body_rdm/all_states_prov.irp.f b/src/two_body_rdm/all_states_prov.irp.f deleted file mode 100644 index 5523faa2..00000000 --- a/src/two_body_rdm/all_states_prov.irp.f +++ /dev/null @@ -1,106 +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 - BEGIN_DOC -! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha electrons -! -! 1/2 * -! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" - END_DOC - integer :: ispin - ! condition for alpha/beta spin - ispin = 1 - all_states_act_two_rdm_alpha_alpha_mo = 0.D0 - double precision :: wall_1,wall_2 - call wall_time(wall_1) - print*,'providing all_states_act_two_rdm_alpha_alpha_mo ...' - 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)) - call wall_time(wall_2) - print*,'time to provide all_states_act_two_rdm_alpha_alpha_mo',wall_2 - wall_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 - BEGIN_DOC -! all_states_act_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta electrons -! -! -! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" - END_DOC - integer :: ispin - ! condition for alpha/beta spin - ispin = 2 - all_states_act_two_rdm_beta_beta_mo = 0.d0 - double precision :: wall_1,wall_2 - call wall_time(wall_1) - print*,'providing all_states_act_two_rdm_beta_beta_mo ...' - 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)) - call wall_time(wall_2) - print*,'time to provide all_states_act_two_rdm_beta_beta_mo',wall_2 - wall_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 - BEGIN_DOC -! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons -! -! -! -! !!!!! 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 -! -! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta -! -! Therefore you don't necessayr have symmetry between electron 1 and 2 - END_DOC - integer :: ispin - double precision :: wall_1, wall_2 - ! condition for alpha/beta spin - call wall_time(wall_1) - print*,'providing all_states_act_two_rdm_alpha_beta_mo ...' - ispin = 3 - print*,'ispin = ',ispin - all_states_act_two_rdm_alpha_beta_mo = 0.d0 - call wall_time(wall_1) - 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)) - - call wall_time(wall_2) - print*,'time to provide all_states_act_two_rdm_alpha_beta_mo',wall_2 - wall_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,istate) = STATE SPECIFIC physicist notation for 2RDM -! -! \sum_{\sigma, \sigma'} -! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" -! -! The active part of the two-electron energy for the state istate 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,istate) * < ii jj | kk ll > -! -! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) - END_DOC - integer :: ispin,i,j,k,l,istate - ! condition for alpha/beta spin - ispin = 4 - all_states_act_two_rdm_spin_trace_mo = 0.d0 - - double precision :: wall_1,wall_2 - call wall_time(wall_1) - print*,'providing all_states_act_two_rdm_spin_trace_mo ...' - 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)) - call wall_time(wall_2) - print*,'time to provide all_states_act_two_rdm_spin_trace_mo',wall_2 - wall_1 - END_PROVIDER - diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f new file mode 100644 index 00000000..92e24af2 --- /dev/null +++ b/src/two_body_rdm/example.irp.f @@ -0,0 +1,261 @@ + +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_two_rdm_ab_mo act_two_rdm_aa_mo act_two_rdm_bb_mo act_two_rdm_spin_trace_mo + provide state_av_act_two_rdm_ab_mo state_av_act_two_rdm_aa_mo + provide state_av_act_two_rdm_bb_mo state_av_act_two_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_two_rdm_ab_mo(l,k,j,i,istate) + rdmaa = act_two_rdm_aa_mo(l,k,j,i,istate) + rdmbb = act_two_rdm_bb_mo(l,k,j,i,istate) + rdmtot = act_two_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_two_rdm_aa_mo(l,k,j,i) + rdm_bb_st_av = state_av_act_two_rdm_bb_mo(l,k,j,i) + rdm_ab_st_av = state_av_act_two_rdm_ab_mo(l,k,j,i) + rdm_tot_st_av = state_av_act_two_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 + 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_two_rdm_ab_mo full_occ_two_rdm_aa_mo full_occ_two_rdm_bb_mo full_occ_two_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_two_rdm_aa_mo(l,k,j,i,istate) + rdmab = full_occ_two_rdm_ab_mo(l,k,j,i,istate) + rdmbb = full_occ_two_rdm_bb_mo(l,k,j,i,istate) + rdmtot = full_occ_two_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_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) + 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_two_rdm_aa_mo(l,k,j,i) + rdm_bb_st_av = state_av_full_occ_two_rdm_bb_mo(l,k,j,i) + rdm_ab_st_av = state_av_full_occ_two_rdm_ab_mo(l,k,j,i) + rdm_tot_st_av = state_av_full_occ_two_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/all_states_full_orb_prov.irp.f b/src/two_body_rdm/full_orb_2_rdm.irp.f similarity index 57% rename from src/two_body_rdm/all_states_full_orb_prov.irp.f rename to src/two_body_rdm/full_orb_2_rdm.irp.f index 55fa78ca..1843cd3c 100644 --- a/src/two_body_rdm/all_states_full_orb_prov.irp.f +++ b/src/two_body_rdm/full_orb_2_rdm.irp.f @@ -1,10 +1,10 @@ - BEGIN_PROVIDER [double precision, all_states_full_two_rdm_alpha_beta_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + BEGIN_PROVIDER [double precision, full_occ_two_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 - all_states_full_two_rdm_alpha_beta_mo = 0.d0 + full_occ_two_rdm_ab_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! all_states_full_two_rdm_alpha_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! full_occ_two_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons ! ! ! @@ -14,13 +14,13 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA ! -! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! act_two_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 is set to zero END_DOC - all_states_full_two_rdm_alpha_beta_mo = 0.d0 + full_occ_two_rdm_ab_mo = 0.d0 do istate = 1, N_states !! PURE ACTIVE PART ALPHA-BETA !! @@ -33,8 +33,8 @@ do l = 1, n_act_orb lorb = list_act(l) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(lorb,korb,jorb,iorb,istate) = & - all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) + full_occ_two_rdm_ab_mo(lorb,korb,jorb,iorb,istate) = & + act_two_rdm_ab_mo(l,k,j,i,istate) enddo enddo enddo @@ -48,7 +48,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -62,7 +62,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -74,7 +74,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(korb,jorb,korb,jorb,istate) = 1.D0 + full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 enddo enddo @@ -91,7 +91,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -105,7 +105,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -117,7 +117,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - all_states_full_two_rdm_alpha_beta_mo(korb,jorb,korb,jorb,istate) = 1.D0 + full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 enddo enddo endif @@ -126,12 +126,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, all_states_full_two_rdm_alpha_alpha_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + BEGIN_PROVIDER [double precision, full_occ_two_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 - all_states_full_two_rdm_alpha_alpha_mo = 0.d0 + full_occ_two_rdm_aa_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! all_states_full_two_rdm_alpha_alpha_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons +! full_occ_two_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons ! ! ! @@ -153,8 +153,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - all_states_full_two_rdm_alpha_alpha_mo(lorb,korb,jorb,iorb,istate) = & - all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) + full_occ_two_rdm_aa_mo(lorb,korb,jorb,iorb,istate) = & + act_two_rdm_aa_mo(l,k,j,i,istate) enddo enddo enddo @@ -168,11 +168,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) ! 1 2 1 2 : EXCHANGE TERM - all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -182,8 +182,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo @@ -199,11 +199,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) ! 1 2 1 2 : EXCHANGE TERM - all_states_full_two_rdm_alpha_alpha_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -213,8 +213,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_alpha_alpha_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo endif @@ -222,12 +222,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, all_states_full_two_rdm_beta_beta_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,N_states)] + BEGIN_PROVIDER [double precision, full_occ_two_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 - all_states_full_two_rdm_beta_beta_mo = 0.d0 + full_occ_two_rdm_bb_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! all_states_full_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! full_occ_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -249,8 +249,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - all_states_full_two_rdm_beta_beta_mo(lorb,korb,jorb,iorb,istate) = & - all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) + full_occ_two_rdm_bb_mo(lorb,korb,jorb,iorb,istate) = & + act_two_rdm_bb_mo(l,k,j,i,istate) enddo enddo enddo @@ -264,11 +264,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_beta_beta_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) ! 1 2 1 2 : EXCHANGE TERM - all_states_full_two_rdm_beta_beta_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_beta_beta_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -278,8 +278,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_beta_beta_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo @@ -295,11 +295,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_beta_beta_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) ! 1 2 1 2 : EXCHANGE TERM - all_states_full_two_rdm_beta_beta_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_beta_beta_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -309,8 +309,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - all_states_full_two_rdm_beta_beta_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_beta_beta_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo endif @@ -318,12 +318,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, all_states_full_two_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)] + BEGIN_PROVIDER [double precision, full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo = 0.d0 + full_occ_two_rdm_spin_trace_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! all_states_full_two_rdm_beta_beta_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! full_occ_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -346,8 +346,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - all_states_full_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += & - all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) + full_occ_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += & + act_two_rdm_spin_trace_mo(l,k,j,i,istate) enddo enddo enddo @@ -364,11 +364,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -377,8 +377,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo if (.not.no_core_density)then @@ -390,11 +390,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -403,8 +403,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo endif @@ -420,11 +420,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -433,8 +433,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo if (.not.no_core_density)then @@ -446,11 +446,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -459,8 +459,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - all_states_full_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 enddo enddo endif @@ -476,14 +476,14 @@ korb = list_inact(k) ! ALPHA INACTIVE - BETA ACTIVE ! alph beta alph beta - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) ! beta alph beta alph - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) ! alph beta alph beta - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -493,8 +493,8 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 enddo enddo @@ -510,14 +510,14 @@ korb = list_core(k) !! BETA ACTIVE - ALPHA CORE ! alph beta alph beta - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) ! beta alph beta alph - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_two_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 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) ! beta alph beta alph - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -527,8 +527,8 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - all_states_full_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 - all_states_full_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 + full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 enddo enddo diff --git a/src/two_body_rdm/state_av_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f similarity index 59% rename from src/two_body_rdm/state_av_2rdm.irp.f rename to src/two_body_rdm/state_av_act_2rdm.irp.f index c8c625bc..640137b5 100644 --- a/src/two_body_rdm/state_av_2rdm.irp.f +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -1,9 +1,9 @@ - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, state_av_act_two_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_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 +! state_av_act_two_rdm_aa_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)) @@ -11,20 +11,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 1 - state_av_act_two_rdm_alpha_alpha_mo = 0.D0 + state_av_act_two_rdm_aa_mo = 0.D0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_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_two_rdm_alpha_alpha_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_aa_mo',wall_2 - wall_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)] + BEGIN_PROVIDER [double precision, state_av_act_two_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_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 +! state_av_act_two_rdm_bb_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)) @@ -32,20 +32,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 2 - state_av_act_two_rdm_beta_beta_mo = 0.d0 + state_av_act_two_rdm_bb_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_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_two_rdm_beta_beta_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_bb_mo',wall_2 - wall_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)] + BEGIN_PROVIDER [double precision, state_av_act_two_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_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 +! state_av_act_two_rdm_ab_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)) @@ -55,15 +55,15 @@ print*,'' print*,'' print*,'' - print*,'providint state_av_act_two_rdm_alpha_beta_mo ' + print*,'providint state_av_act_two_rdm_ab_mo ' ispin = 3 print*,'ispin = ',ispin - state_av_act_two_rdm_alpha_beta_mo = 0.d0 + state_av_act_two_rdm_ab_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_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_two_rdm_alpha_beta_mo',wall_2 - wall_1 + print*,'Wall time to provide state_av_act_two_rdm_ab_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..f5b3e18c --- /dev/null +++ b/src/two_body_rdm/state_av_full_orb_2_rdm.irp.f @@ -0,0 +1,528 @@ + + BEGIN_PROVIDER [double precision, state_av_full_occ_two_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_two_rdm_ab_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_two_rdm_ab_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE RANGE OF OCCUPIED MOS (CORE+INACT+ACT) BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA +! +! state_av_full_occ_two_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_two_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_two_rdm_ab_mo(lorb,korb,jorb,iorb) = & + state_av_act_two_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_two_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_two_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_two_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_two_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_two_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_two_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 + enddo + enddo + endif + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, state_av_full_occ_two_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_two_rdm_aa_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_two_rdm_aa_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/alpha electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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_two_rdm_aa_mo(lorb,korb,jorb,iorb) = & + state_av_act_two_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_two_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_full_occ_two_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_two_rdm_bb_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_two_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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_two_rdm_bb_mo(lorb,korb,jorb,iorb) = & + state_av_act_two_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_two_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0 + enddo + enddo + endif + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_full_occ_two_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_two_rdm_spin_trace_mo = 0.d0 + integer :: i,j,k,l,iorb,jorb,korb,lorb + BEGIN_DOC +! state_av_full_occ_two_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! +! +! +! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! +! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! +! !!!!! 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_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb) += & + state_av_act_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 + state_av_full_occ_two_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_two_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_two_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_two_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_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 + state_av_full_occ_two_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_two_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_two_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_two_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_two_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_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 + state_av_full_occ_two_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 index 9ba57e37..123261d8 100644 --- a/src/two_body_rdm/test_2_rdm.irp.f +++ b/src/two_body_rdm/test_2_rdm.irp.f @@ -2,138 +2,7 @@ program test_2_rdm implicit none read_wf = .True. touch read_wf -! call routine_full_mos call routine_active_only + call routine_full_mos end -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,rdmaa,get_two_e_integral,rdmab,rdmbb,rdmtot - double precision :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) - double precision :: accu_ab_omp(N_states),rdmab_omp - double precision :: accu_bb_omp(N_states),rdmbb_omp - double precision :: accu_aa_omp(N_states),rdmaa_omp - double precision :: accu_tot_omp(N_states),rdmtot_omp - accu_ab_omp = 0.d0 - accu_bb_omp = 0.d0 - accu_aa_omp = 0.d0 - accu_tot_omp = 0.d0 - accu_aa = 0.d0 - accu_ab = 0.d0 - accu_bb = 0.d0 - accu_tot = 0.d0 - 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_omp = state_av_act_two_rdm_alpha_beta_mo(l,k,j,i) -! rdmbb_omp = state_av_act_two_rdm_beta_beta_mo(l,k,j,i) -! rdmaa_omp = state_av_act_two_rdm_alpha_alpha_mo(l,k,j,i) -! rdmtot_omp = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) - - -! rdmab_omp = all_states_openmp_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) -! rdmaa_omp = all_states_openmp_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) -! rdmbb_omp = all_states_openmp_act_two_rdm_beta_beta_mo(l,k,j,i,istate) - rdmtot_omp = all_states_openmp_act_two_rdm_spin_trace_mo(l,k,j,i,istate) - -! rdmab = all_states_act_two_rdm_alpha_beta_mo(l,k,j,i,istate) -! rdmaa = all_states_act_two_rdm_alpha_alpha_mo(l,k,j,i,istate) -! rdmbb = all_states_act_two_rdm_beta_beta_mo(l,k,j,i,istate) - rdmtot = all_states_act_two_rdm_spin_trace_mo(l,k,j,i,istate) - -! accu_ab_omp(istate) += vijkl * rdmab_omp -! accu_aa_omp(istate) += vijkl * rdmaa_omp -! accu_bb_omp(istate) += vijkl * rdmbb_omp - accu_tot_omp(istate) += vijkl * rdmtot_omp - -! accu_ab(istate) += vijkl * rdmab -! accu_aa(istate) += vijkl * rdmaa -! accu_bb(istate) += vijkl * rdmbb - accu_tot(istate) += vijkl * rdmtot - enddo - enddo - enddo - enddo - print*,'' - print*,'Active space only energy ' -! print*,'accu_aa(istate) = ',accu_aa(istate) -! print*,'accu_aa_omp = ',accu_aa_omp(istate) -! print*,'accu_bb(istate) = ',accu_bb(istate) -! print*,'accu_bb_omp = ',accu_bb_omp(istate) -! print*,'accu_ab(istate) = ',accu_ab(istate) -! print*,'accu_ab_omp = ',accu_ab_omp(istate) - print*,'' -! print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) - print*,'accu_tot(istate) = ',accu_tot(istate) - print*,'accu_tot_omp = ',accu_tot_omp(istate) - print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) - enddo - -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 :: accu_aa(N_states),accu_bb(N_states),accu_ab(N_states),accu_tot(N_states) - accu_aa = 0.d0 - accu_ab = 0.d0 - accu_bb = 0.d0 - accu_tot = 0.d0 - 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 = all_states_full_two_rdm_alpha_alpha_mo(l,k,j,i,istate) - rdmab = all_states_full_two_rdm_alpha_beta_mo(l,k,j,i,istate) - rdmbb = all_states_full_two_rdm_beta_beta_mo(l,k,j,i,istate) - rdmtot = all_states_full_two_rdm_spin_trace_mo(l,k,j,i,istate) - - accu_ab(istate) += vijkl * rdmab - accu_aa(istate) += vijkl * rdmaa - accu_bb(istate) += vijkl * rdmbb - accu_tot(istate)+= vijkl * rdmtot - enddo - enddo - enddo - enddo - print*,'Full energy ' - print*,'accu_aa(istate) = ',accu_aa(istate) - print*,'accu_bb(istate) = ',accu_bb(istate) - print*,'accu_ab(istate) = ',accu_ab(istate) - print*,'' - print*,'sum (istate) = ',accu_aa(istate) + accu_bb(istate) + accu_ab(istate) - print*,'accu_tot(istate) = ',accu_tot(istate) - print*,'psi_energy_two_e(istate) = ',psi_energy_two_e(istate) - enddo - -end diff --git a/src/two_rdm_routines/all_states_david_openmp.irp.f b/src/two_rdm_routines/all_states_david_openmp.irp.f index 0da7e205..412c2f12 100644 --- a/src/two_rdm_routines/all_states_david_openmp.irp.f +++ b/src/two_rdm_routines/all_states_david_openmp.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_all_states_openmp_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze) +subroutine orb_range_two_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -30,7 +30,7 @@ subroutine orb_range_two_rdm_all_states_openmp_openmp(big_array,dim1,norb,list_o size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_all_states_openmp_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_two_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 @@ -39,7 +39,7 @@ subroutine orb_range_two_rdm_all_states_openmp_openmp(big_array,dim1,norb,list_o end -subroutine orb_range_two_rdm_all_states_openmp_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_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 @@ -58,15 +58,15 @@ subroutine orb_range_two_rdm_all_states_openmp_openmp_work(big_array,dim1,norb,l select case (N_int) case (1) - call orb_range_two_rdm_all_states_openmp_openmp_work_1(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_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_all_states_openmp_openmp_work_2(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_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_all_states_openmp_openmp_work_3(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_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_all_states_openmp_openmp_work_4(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_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_all_states_openmp_openmp_work_N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,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_all_states_openmp_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_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 From 570a710de5c3bb2fbf21e55f8d7580943ad86570 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 17:21:49 +0100 Subject: [PATCH 11/29] renamed two rdm --- src/two_body_rdm/act_2_rdm.irp.f | 56 +++--- src/two_body_rdm/example.irp.f | 40 ++-- src/two_body_rdm/full_orb_2_rdm.irp.f | 176 +++++++++--------- src/two_body_rdm/state_av_act_2rdm.irp.f | 46 ++--- .../state_av_full_orb_2_rdm.irp.f | 176 +++++++++--------- src/two_rdm_routines/all_states_david.irp.f | 36 ++-- .../all_states_david_openmp.irp.f | 32 ++-- src/two_rdm_routines/all_states_update.irp.f | 14 +- .../all_states_update_openmp.irp.f | 2 +- src/two_rdm_routines/state_av_david_omp.irp.f | 40 ++-- .../state_av_update_omp.irp.f | 14 +- 11 files changed, 316 insertions(+), 316 deletions(-) diff --git a/src/two_body_rdm/act_2_rdm.irp.f b/src/two_body_rdm/act_2_rdm.irp.f index af22946f..4a8a64d2 100644 --- a/src/two_body_rdm/act_2_rdm.irp.f +++ b/src/two_body_rdm/act_2_rdm.irp.f @@ -1,8 +1,8 @@ - BEGIN_PROVIDER [double precision, act_two_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + 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_two_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! act_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons ! ! ! @@ -10,7 +10,7 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta ! -! act_two_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! act_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta ! ! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC @@ -20,22 +20,22 @@ print*,'' print*,'' print*,'' - print*,'Providing act_two_rdm_ab_mo ' + print*,'Providing act_2_rdm_ab_mo ' ispin = 3 print*,'ispin = ',ispin - act_two_rdm_ab_mo = 0.d0 + act_2_rdm_ab_mo = 0.d0 call wall_time(wall_1) - call orb_range_two_rdm_openmp(act_two_rdm_ab_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + 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)) call wall_time(wall_2) - print*,'Wall time to provide act_two_rdm_ab_mo',wall_2 - wall_1 + print*,'Wall time to provide act_2_rdm_ab_mo',wall_2 - wall_1 END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + 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_two_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! act_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons ! ! ! @@ -43,7 +43,7 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta ! -! act_two_rdm_aa_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta +! act_2_rdm_aa_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta ! ! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC @@ -53,22 +53,22 @@ print*,'' print*,'' print*,'' - print*,'Providing act_two_rdm_aa_mo ' + print*,'Providing act_2_rdm_aa_mo ' ispin = 1 print*,'ispin = ',ispin - act_two_rdm_aa_mo = 0.d0 + act_2_rdm_aa_mo = 0.d0 call wall_time(wall_1) - call orb_range_two_rdm_openmp(act_two_rdm_aa_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + 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)) call wall_time(wall_2) - print*,'Wall time to provide act_two_rdm_aa_mo',wall_2 - wall_1 + print*,'Wall time to provide act_2_rdm_aa_mo',wall_2 - wall_1 END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + 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_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! act_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -76,7 +76,7 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta ! -! act_two_rdm_bb_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta +! act_2_rdm_bb_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta ! ! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC @@ -86,21 +86,21 @@ print*,'' print*,'' print*,'' - print*,'Providing act_two_rdm_bb_mo ' + print*,'Providing act_2_rdm_bb_mo ' ispin = 2 print*,'ispin = ',ispin - act_two_rdm_bb_mo = 0.d0 + act_2_rdm_bb_mo = 0.d0 call wall_time(wall_1) - call orb_range_two_rdm_openmp(act_two_rdm_bb_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + 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)) call wall_time(wall_2) - print*,'Wall time to provide act_two_rdm_bb_mo',wall_2 - wall_1 + print*,'Wall time to provide act_2_rdm_bb_mo',wall_2 - wall_1 END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + 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_two_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! act_2_rdm_spin_trace_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -108,7 +108,7 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta ! -! act_two_rdm_spin_trace_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta +! act_2_rdm_spin_trace_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta ! ! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC @@ -118,13 +118,13 @@ print*,'' print*,'' print*,'' - print*,'Providing act_two_rdm_spin_trace_mo ' + print*,'Providing act_2_rdm_spin_trace_mo ' ispin = 4 print*,'ispin = ',ispin - act_two_rdm_spin_trace_mo = 0.d0 + act_2_rdm_spin_trace_mo = 0.d0 call wall_time(wall_1) - call orb_range_two_rdm_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + 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)) call wall_time(wall_2) - print*,'Wall time to provide act_two_rdm_spin_trace_mo',wall_2 - wall_1 + print*,'Wall time to provide act_2_rdm_spin_trace_mo',wall_2 - wall_1 END_PROVIDER diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f index 92e24af2..fb4ac8ed 100644 --- a/src/two_body_rdm/example.irp.f +++ b/src/two_body_rdm/example.irp.f @@ -35,9 +35,9 @@ subroutine routine_active_only korb = 1 lorb = 1 vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - provide act_two_rdm_ab_mo act_two_rdm_aa_mo act_two_rdm_bb_mo act_two_rdm_spin_trace_mo - provide state_av_act_two_rdm_ab_mo state_av_act_two_rdm_aa_mo - provide state_av_act_two_rdm_bb_mo state_av_act_two_rdm_spin_trace_mo + 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 @@ -55,10 +55,10 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdmab = act_two_rdm_ab_mo(l,k,j,i,istate) - rdmaa = act_two_rdm_aa_mo(l,k,j,i,istate) - rdmbb = act_two_rdm_bb_mo(l,k,j,i,istate) - rdmtot = act_two_rdm_spin_trace_mo(l,k,j,i,istate) + 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 @@ -103,10 +103,10 @@ subroutine routine_active_only vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdm_aa_st_av = state_av_act_two_rdm_aa_mo(l,k,j,i) - rdm_bb_st_av = state_av_act_two_rdm_bb_mo(l,k,j,i) - rdm_ab_st_av = state_av_act_two_rdm_ab_mo(l,k,j,i) - rdm_tot_st_av = state_av_act_two_rdm_spin_trace_mo(l,k,j,i) + 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 @@ -169,7 +169,7 @@ subroutine routine_full_mos korb = 1 lorb = 1 vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - provide full_occ_two_rdm_ab_mo full_occ_two_rdm_aa_mo full_occ_two_rdm_bb_mo full_occ_two_rdm_spin_trace_mo + 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 @@ -183,10 +183,10 @@ subroutine routine_full_mos lorb = list_core_inact_act(l) vijkl = get_two_e_integral(lorb,korb,jorb,iorb,mo_integrals_map) - rdmaa = full_occ_two_rdm_aa_mo(l,k,j,i,istate) - rdmab = full_occ_two_rdm_ab_mo(l,k,j,i,istate) - rdmbb = full_occ_two_rdm_bb_mo(l,k,j,i,istate) - rdmtot = full_occ_two_rdm_spin_trace_mo(l,k,j,i,istate) + 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 @@ -227,10 +227,10 @@ subroutine routine_full_mos 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_two_rdm_aa_mo(l,k,j,i) - rdm_bb_st_av = state_av_full_occ_two_rdm_bb_mo(l,k,j,i) - rdm_ab_st_av = state_av_full_occ_two_rdm_ab_mo(l,k,j,i) - rdm_tot_st_av = state_av_full_occ_two_rdm_spin_trace_mo(l,k,j,i) + 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 diff --git a/src/two_body_rdm/full_orb_2_rdm.irp.f b/src/two_body_rdm/full_orb_2_rdm.irp.f index 1843cd3c..bc0350e2 100644 --- a/src/two_body_rdm/full_orb_2_rdm.irp.f +++ b/src/two_body_rdm/full_orb_2_rdm.irp.f @@ -1,10 +1,10 @@ - BEGIN_PROVIDER [double precision, full_occ_two_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)] + 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_two_rdm_ab_mo = 0.d0 + full_occ_2_rdm_ab_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! full_occ_two_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons +! full_occ_2_rdm_ab_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/beta electrons ! ! ! @@ -14,13 +14,13 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA ! -! act_two_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l: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 ! ! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero END_DOC - full_occ_two_rdm_ab_mo = 0.d0 + full_occ_2_rdm_ab_mo = 0.d0 do istate = 1, N_states !! PURE ACTIVE PART ALPHA-BETA !! @@ -33,8 +33,8 @@ do l = 1, n_act_orb lorb = list_act(l) ! alph beta alph beta - full_occ_two_rdm_ab_mo(lorb,korb,jorb,iorb,istate) = & - act_two_rdm_ab_mo(l,k,j,i,istate) + full_occ_2_rdm_ab_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_ab_mo(l,k,j,i,istate) enddo enddo enddo @@ -48,7 +48,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -62,7 +62,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -74,7 +74,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 + full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 enddo enddo @@ -91,7 +91,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) + full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb,istate) = one_e_dm_mo_beta(jorb,iorb,istate) enddo enddo enddo @@ -105,7 +105,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) + full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb,istate) = one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -117,7 +117,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 + full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb,istate) = 1.D0 enddo enddo endif @@ -126,12 +126,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, full_occ_two_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)] + 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_two_rdm_aa_mo = 0.d0 + full_occ_2_rdm_aa_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! full_occ_two_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons +! full_occ_2_rdm_aa_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of alpha/alpha electrons ! ! ! @@ -153,8 +153,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - full_occ_two_rdm_aa_mo(lorb,korb,jorb,iorb,istate) = & - act_two_rdm_aa_mo(l,k,j,i,istate) + full_occ_2_rdm_aa_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_aa_mo(l,k,j,i,istate) enddo enddo enddo @@ -168,11 +168,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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_two_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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 @@ -182,8 +182,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -199,11 +199,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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_two_rdm_aa_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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 @@ -213,8 +213,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -222,12 +222,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, full_occ_two_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)] + 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_two_rdm_bb_mo = 0.d0 + full_occ_2_rdm_bb_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! full_occ_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -249,8 +249,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - full_occ_two_rdm_bb_mo(lorb,korb,jorb,iorb,istate) = & - act_two_rdm_bb_mo(l,k,j,i,istate) + full_occ_2_rdm_bb_mo(lorb,korb,jorb,iorb,istate) = & + act_2_rdm_bb_mo(l,k,j,i,istate) enddo enddo enddo @@ -264,11 +264,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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_two_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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 @@ -278,8 +278,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -295,11 +295,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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_two_rdm_bb_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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 @@ -309,8 +309,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -318,12 +318,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, full_occ_two_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)] + 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_two_rdm_spin_trace_mo = 0.d0 + full_occ_2_rdm_spin_trace_mo = 0.d0 integer :: i,j,k,l,iorb,jorb,korb,lorb,istate BEGIN_DOC -! full_occ_two_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons +! full_occ_2_rdm_bb_mo(i,j,k,l,istate) = STATE SPECIFIC physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -346,8 +346,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - full_occ_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb,istate) += & - act_two_rdm_spin_trace_mo(l,k,j,i,istate) + 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 @@ -364,11 +364,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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 @@ -377,8 +377,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -390,11 +390,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) + 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 @@ -403,8 +403,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -420,11 +420,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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 @@ -433,8 +433,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -446,11 +446,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) - full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb,istate) += -0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) + 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 @@ -459,8 +459,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5d0 - full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb,istate) -= 0.5d0 + 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 @@ -476,14 +476,14 @@ korb = list_inact(k) ! ALPHA INACTIVE - BETA ACTIVE ! alph beta alph beta - full_occ_two_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(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_beta(jorb,iorb,istate) ! beta alph beta alph - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,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) ! BETA INACTIVE - ALPHA ACTIVE ! beta alph beta alpha - full_occ_two_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(korb,jorb,korb,iorb,istate) += 0.5d0 * one_e_dm_mo_alpha(jorb,iorb,istate) ! alph beta alph beta - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,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) enddo enddo enddo @@ -493,8 +493,8 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 - full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + 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 @@ -510,14 +510,14 @@ korb = list_core(k) !! BETA ACTIVE - ALPHA CORE ! alph beta alph beta - full_occ_two_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(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_beta(jorb,iorb,istate) ! beta alph beta alph - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,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) !! ALPHA ACTIVE - BETA CORE ! alph beta alph beta - full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb,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) ! beta alph beta alph - full_occ_two_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(korb,jorb,korb,iorb,istate) += 0.5D0 * one_e_dm_mo_alpha(jorb,iorb,istate) enddo enddo enddo @@ -527,8 +527,8 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb,istate) += 0.5D0 - full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb,istate) += 0.5D0 + 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 diff --git a/src/two_body_rdm/state_av_act_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f index 640137b5..064ecc33 100644 --- a/src/two_body_rdm/state_av_act_2rdm.irp.f +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -1,9 +1,9 @@ - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_aa_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + 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_two_rdm_aa_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! 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 ! = END_DOC allocate(state_weights(N_states)) @@ -11,20 +11,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 1 - state_av_act_two_rdm_aa_mo = 0.D0 + state_av_act_2_rdm_aa_mo = 0.D0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_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 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_two_rdm_aa_mo',wall_2 - wall_1 + 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_two_rdm_bb_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + 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_two_rdm_bb_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! 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 ! = END_DOC allocate(state_weights(N_states)) @@ -32,20 +32,20 @@ integer :: ispin ! condition for alpha/beta spin ispin = 2 - state_av_act_two_rdm_bb_mo = 0.d0 + state_av_act_2_rdm_bb_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_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 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_two_rdm_bb_mo',wall_2 - wall_1 + 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_two_rdm_ab_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + 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_two_rdm_ab_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! 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 ! = END_DOC allocate(state_weights(N_states)) @@ -55,26 +55,26 @@ print*,'' print*,'' print*,'' - print*,'providint state_av_act_two_rdm_ab_mo ' + print*,'providint state_av_act_2_rdm_ab_mo ' ispin = 3 print*,'ispin = ',ispin - state_av_act_two_rdm_ab_mo = 0.d0 + state_av_act_2_rdm_ab_mo = 0.d0 call wall_time(wall_1) double precision :: wall_1, wall_2 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_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 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_two_rdm_ab_mo',wall_2 - wall_1 + 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_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + 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_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! 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 ! 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 > +! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_2_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 @@ -84,14 +84,14 @@ integer :: ispin ! condition for alpha/beta spin ispin = 4 - state_av_act_two_rdm_spin_trace_mo = 0.d0 + 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_two_rdm_spin_trace_mo ' - call orb_range_two_rdm_state_av_openmp(state_av_act_two_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)) + 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_two_rdm_spin_trace_mo',wall_2 - wall_1 + 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 index f5b3e18c..9229d146 100644 --- 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 @@ -1,10 +1,10 @@ - BEGIN_PROVIDER [double precision, state_av_full_occ_two_rdm_ab_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + 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_two_rdm_ab_mo = 0.d0 + 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_two_rdm_ab_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons +! state_av_full_occ_2_rdm_ab_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/beta electrons ! ! ! @@ -14,13 +14,13 @@ ! ! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is BETA ! -! state_av_full_occ_two_rdm_ab_mo(i,j,k,l) = i:alpha, j:beta, j:alpha, l: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_two_rdm_ab_mo = 0.d0 + 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 @@ -30,8 +30,8 @@ do l = 1, n_act_orb lorb = list_act(l) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(lorb,korb,jorb,iorb) = & - state_av_act_two_rdm_ab_mo(l,k,j,i) + 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 @@ -45,7 +45,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) enddo enddo enddo @@ -59,7 +59,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) enddo enddo enddo @@ -71,7 +71,7 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 enddo enddo @@ -88,7 +88,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,iorb) = one_e_dm_mo_beta_average(jorb,iorb) enddo enddo enddo @@ -102,7 +102,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) + state_av_full_occ_2_rdm_ab_mo(jorb,korb,iorb,korb) = one_e_dm_mo_alpha_average(jorb,iorb) enddo enddo enddo @@ -114,7 +114,7 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - state_av_full_occ_two_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 + state_av_full_occ_2_rdm_ab_mo(korb,jorb,korb,jorb) = 1.D0 enddo enddo endif @@ -122,12 +122,12 @@ END_PROVIDER - BEGIN_PROVIDER [double precision, state_av_full_occ_two_rdm_aa_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + 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_two_rdm_aa_mo = 0.d0 + 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_two_rdm_aa_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/alpha electrons +! state_av_full_occ_2_rdm_aa_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of alpha/alpha electrons ! ! ! @@ -148,8 +148,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - state_av_full_occ_two_rdm_aa_mo(lorb,korb,jorb,iorb) = & - state_av_act_two_rdm_aa_mo(l,k,j,i) + 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 @@ -163,11 +163,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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_two_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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 @@ -177,8 +177,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - state_av_full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -194,11 +194,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_aa_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_aa_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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_two_rdm_aa_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_aa_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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 @@ -208,20 +208,20 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - state_av_full_occ_two_rdm_aa_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_aa_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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_two_rdm_bb_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + 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_two_rdm_bb_mo = 0.d0 + 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_two_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -242,8 +242,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - state_av_full_occ_two_rdm_bb_mo(lorb,korb,jorb,iorb) = & - state_av_act_two_rdm_bb_mo(l,k,j,i) + 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 @@ -257,11 +257,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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_two_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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 @@ -271,8 +271,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - state_av_full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -288,11 +288,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_bb_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_bb_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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_two_rdm_bb_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_bb_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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 @@ -302,20 +302,20 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - state_av_full_occ_two_rdm_bb_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_bb_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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_two_rdm_spin_trace_mo, (n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)] + 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_two_rdm_spin_trace_mo = 0.d0 + 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_two_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons +! state_av_full_occ_2_rdm_bb_mo(i,j,k,l) = STATE AVERAGE physicist notation for 2RDM of beta/beta electrons ! ! ! @@ -337,8 +337,8 @@ korb = list_act(k) do l = 1, n_act_orb lorb = list_act(l) - state_av_full_occ_two_rdm_spin_trace_mo(lorb,korb,jorb,iorb) += & - state_av_act_two_rdm_spin_trace_mo(l,k,j,i) + 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 @@ -355,11 +355,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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 @@ -368,8 +368,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -381,11 +381,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) + 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 @@ -394,8 +394,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -411,11 +411,11 @@ do k = 1, n_inact_orb korb = list_inact(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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 @@ -424,8 +424,8 @@ jorb = list_inact(j) do k = 1, n_inact_orb korb = list_inact(k) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -437,11 +437,11 @@ do k = 1, n_core_orb korb = list_core(k) ! 1 2 1 2 : DIRECT TERM - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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_two_rdm_spin_trace_mo(jorb,korb,korb,iorb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,iorb,korb) += -0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) + 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 @@ -450,8 +450,8 @@ jorb = list_core(j) do k = 1, n_core_orb korb = list_core(k) - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5d0 - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,jorb,korb) -= 0.5d0 + 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 @@ -467,14 +467,14 @@ korb = list_inact(k) ! ALPHA INACTIVE - BETA ACTIVE ! alph beta alph beta - state_av_full_occ_two_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(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_beta_average(jorb,iorb) ! beta alph beta alph - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 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) ! BETA INACTIVE - ALPHA ACTIVE ! beta alph beta alpha - state_av_full_occ_two_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(korb,jorb,korb,iorb) += 0.5d0 * one_e_dm_mo_alpha_average(jorb,iorb) ! alph beta alph beta - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 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) enddo enddo enddo @@ -484,8 +484,8 @@ do k = 1, n_inact_orb korb = list_inact(k) ! alph beta alph beta - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0 + 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 @@ -501,14 +501,14 @@ korb = list_core(k) !! BETA ACTIVE - ALPHA CORE ! alph beta alph beta - state_av_full_occ_two_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(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_beta_average(jorb,iorb) ! beta alph beta alph - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 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) !! ALPHA ACTIVE - BETA CORE ! alph beta alph beta - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,iorb,korb) += 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) ! beta alph beta alph - state_av_full_occ_two_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(korb,jorb,korb,iorb) += 0.5D0 * one_e_dm_mo_alpha_average(jorb,iorb) enddo enddo enddo @@ -518,8 +518,8 @@ do k = 1, n_core_orb korb = list_core(k) ! alph beta alph beta - state_av_full_occ_two_rdm_spin_trace_mo(korb,jorb,korb,jorb) += 0.5D0 - state_av_full_occ_two_rdm_spin_trace_mo(jorb,korb,jorb,korb) += 0.5D0 + 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 diff --git a/src/two_rdm_routines/all_states_david.irp.f b/src/two_rdm_routines/all_states_david.irp.f index 9d29332e..b455d54a 100644 --- a/src/two_rdm_routines/all_states_david.irp.f +++ b/src/two_rdm_routines/all_states_david.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) +subroutine orb_range_all_states_2_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -31,7 +31,7 @@ subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_re 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) + call orb_range_all_states_2_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 @@ -40,7 +40,7 @@ subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_re 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) +subroutine orb_range_all_states_2_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 @@ -60,15 +60,15 @@ subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_o 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) + call orb_range_all_states_2_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) + call orb_range_all_states_2_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) + call orb_range_all_states_2_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) + call orb_range_all_states_2_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) + call orb_range_all_states_2_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 @@ -76,7 +76,7 @@ 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) +subroutine orb_range_all_states_2_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 @@ -129,7 +129,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work' + print*,'Wrong parameter for ispin in general_2_rdm_dm_nstates_work' print*,'ispin = ',ispin stop endif @@ -249,7 +249,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_off_diagonal_double_to_2_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) enddo endif @@ -326,9 +326,9 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_off_diagonal_single_to_2_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) + call orb_range_off_diagonal_single_to_2_rdm_aa_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -351,7 +351,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_off_diagonal_double_to_2_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 @@ -418,9 +418,9 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_off_diagonal_single_to_2_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) + call orb_range_off_diagonal_single_to_2_rdm_bb_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -442,7 +442,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_off_diagonal_double_to_2_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 @@ -475,7 +475,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb 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) + call orb_range_diagonal_contrib_to_all_2_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) end do !!$OMP END DO diff --git a/src/two_rdm_routines/all_states_david_openmp.irp.f b/src/two_rdm_routines/all_states_david_openmp.irp.f index 412c2f12..2b1e2cfa 100644 --- a/src/two_rdm_routines/all_states_david_openmp.irp.f +++ b/src/two_rdm_routines/all_states_david_openmp.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_openmp(big_array,dim1,norb,list_orb,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 @@ -30,7 +30,7 @@ subroutine orb_range_two_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st, size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_openmp_work(big_array,dim1,norb,list_orb,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 @@ -39,7 +39,7 @@ subroutine orb_range_two_rdm_openmp(big_array,dim1,norb,list_orb,ispin,u_0,N_st, end -subroutine orb_range_two_rdm_openmp_work(big_array,dim1,norb,list_orb,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 @@ -58,15 +58,15 @@ subroutine orb_range_two_rdm_openmp_work(big_array,dim1,norb,list_orb,ispin,u_t, select case (N_int) case (1) - call orb_range_two_rdm_openmp_work_1(big_array,dim1,norb,list_orb,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_openmp_work_2(big_array,dim1,norb,list_orb,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_openmp_work_3(big_array,dim1,norb,list_orb,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_openmp_work_4(big_array,dim1,norb,list_orb,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_openmp_work_N_int(big_array,dim1,norb,list_orb,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 @@ -74,7 +74,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,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 @@ -128,7 +128,7 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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 @@ -353,9 +353,9 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,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) 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) -! print*,'to do orb_range_off_diag_single_to_two_rdm_aa_dm_buffer' +! print*,'to do orb_range_off_diag_single_to_2_rdm_aa_dm_buffer' endif enddo @@ -382,7 +382,7 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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) -! print*,'to do orb_range_off_diag_double_to_two_rdm_aa_dm_buffer' +! print*,'to do orb_range_off_diag_double_to_2_rdm_aa_dm_buffer' enddo endif call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) @@ -453,7 +453,7 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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) -! print*,'to do orb_range_off_diag_single_to_two_rdm_ab_dm_buffer' +! print*,'to do orb_range_off_diag_single_to_2_rdm_ab_dm_buffer' ! increment the beta /beta part for single excitations 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) @@ -485,7 +485,7 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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_two_rdm_bb_dm_buffer' +! print*,'to do orb_range_off_diag_double_to_2_rdm_bb_dm_buffer' ASSERT (l_a <= N_det) enddo @@ -519,7 +519,7 @@ subroutine orb_range_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,isp 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_two_rdm_dm_buffer(tmp_det,c_1,N_states,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 diff --git a/src/two_rdm_routines/all_states_update.irp.f b/src/two_rdm_routines/all_states_update.irp.f index 6d5c62fa..00507448 100644 --- a/src/two_rdm_routines/all_states_update.irp.f +++ b/src/two_rdm_routines/all_states_update.irp.f @@ -1,4 +1,4 @@ - 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) + subroutine orb_range_diagonal_contrib_to_all_2_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 @@ -127,7 +127,7 @@ 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) + subroutine orb_range_off_diagonal_double_to_2_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 @@ -197,7 +197,7 @@ 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) + subroutine orb_range_off_diagonal_single_to_2_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 @@ -322,7 +322,7 @@ 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) + subroutine orb_range_off_diagonal_single_to_2_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 ! @@ -403,7 +403,7 @@ 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) + subroutine orb_range_off_diagonal_single_to_2_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 @@ -486,7 +486,7 @@ 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) + subroutine orb_range_off_diagonal_double_to_2_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 @@ -559,7 +559,7 @@ 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) + subroutine orb_range_off_diagonal_double_to_2_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 diff --git a/src/two_rdm_routines/all_states_update_openmp.irp.f b/src/two_rdm_routines/all_states_update_openmp.irp.f index 41cb94bc..54ba59ec 100644 --- a/src/two_rdm_routines/all_states_update_openmp.irp.f +++ b/src/two_rdm_routines/all_states_update_openmp.irp.f @@ -1,4 +1,4 @@ - subroutine orb_range_diag_to_all_states_two_rdm_dm_buffer(det_1,c_1,N_st,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + 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 diff --git a/src/two_rdm_routines/state_av_david_omp.irp.f b/src/two_rdm_routines/state_av_david_omp.irp.f index bb195454..2a6e10a2 100644 --- a/src/two_rdm_routines/state_av_david_omp.irp.f +++ b/src/two_rdm_routines/state_av_david_omp.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 @@ -270,8 +270,8 @@ 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) -! print*,'todo orb_range_off_diag_double_to_two_rdm_ab_dm_buffer' + 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) +! print*,'todo orb_range_off_diag_double_to_2_rdm_ab_dm_buffer' enddo endif @@ -353,13 +353,13 @@ 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,orb_bitmask,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,orb_bitmask,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 @@ -386,7 +386,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 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 @@ -457,13 +457,13 @@ 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,orb_bitmask,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,orb_bitmask,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 @@ -489,8 +489,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) -! print*,'to do orb_range_off_diag_double_to_two_rdm_bb_dm_buffer' + 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 @@ -524,7 +524,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/state_av_update_omp.irp.f b/src/two_rdm_routines/state_av_update_omp.irp.f index 9d0f3fe8..35024331 100644 --- a/src/two_rdm_routines/state_av_update_omp.irp.f +++ b/src/two_rdm_routines/state_av_update_omp.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 @@ -175,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 @@ -257,7 +257,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,orb_bitmask,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 @@ -408,7 +408,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,orb_bitmask,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 ! @@ -512,7 +512,7 @@ endif end - subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,orb_bitmask,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 @@ -616,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 @@ -711,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 From 7f8858005277c9d172ccb40093f24ec53f1fa911 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 17:23:21 +0100 Subject: [PATCH 12/29] renamed files of routines in 2rdm --- src/two_rdm_routines/all_states_david.irp.f | 496 -------------- src/two_rdm_routines/all_states_update.irp.f | 635 ------------------ ..._openmp.irp.f => davidson_like_2rdm.irp.f} | 0 ...rp.f => davidson_like_state_av_2rdm.irp.f} | 0 ...te_omp.irp.f => updata_state_av_rdm.irp.f} | 0 ...s_update_openmp.irp.f => update_rdm.irp.f} | 0 6 files changed, 1131 deletions(-) delete mode 100644 src/two_rdm_routines/all_states_david.irp.f delete mode 100644 src/two_rdm_routines/all_states_update.irp.f rename src/two_rdm_routines/{all_states_david_openmp.irp.f => davidson_like_2rdm.irp.f} (100%) rename src/two_rdm_routines/{state_av_david_omp.irp.f => davidson_like_state_av_2rdm.irp.f} (100%) rename src/two_rdm_routines/{state_av_update_omp.irp.f => updata_state_av_rdm.irp.f} (100%) rename src/two_rdm_routines/{all_states_update_openmp.irp.f => update_rdm.irp.f} (100%) diff --git a/src/two_rdm_routines/all_states_david.irp.f b/src/two_rdm_routines/all_states_david.irp.f deleted file mode 100644 index b455d54a..00000000 --- a/src/two_rdm_routines/all_states_david.irp.f +++ /dev/null @@ -1,496 +0,0 @@ -subroutine orb_range_all_states_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_2_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_rdm_routines/all_states_update.irp.f b/src/two_rdm_routines/all_states_update.irp.f deleted file mode 100644 index 00507448..00000000 --- a/src/two_rdm_routines/all_states_update.irp.f +++ /dev/null @@ -1,635 +0,0 @@ - subroutine orb_range_diagonal_contrib_to_all_2_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) - ! If alpha/beta, electron 1 is alpha, electron 2 is beta - ! Therefore you don't necessayr have symmetry between electron 1 and 2 - big_array(h1,h2,h1,h2,istate) += 1.0d0 * 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 -! pause - 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_2_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_2_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_2_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_2_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_2_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_2_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_rdm_routines/all_states_david_openmp.irp.f b/src/two_rdm_routines/davidson_like_2rdm.irp.f similarity index 100% rename from src/two_rdm_routines/all_states_david_openmp.irp.f rename to src/two_rdm_routines/davidson_like_2rdm.irp.f diff --git a/src/two_rdm_routines/state_av_david_omp.irp.f b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f similarity index 100% rename from src/two_rdm_routines/state_av_david_omp.irp.f rename to src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f diff --git a/src/two_rdm_routines/state_av_update_omp.irp.f b/src/two_rdm_routines/updata_state_av_rdm.irp.f similarity index 100% rename from src/two_rdm_routines/state_av_update_omp.irp.f rename to src/two_rdm_routines/updata_state_av_rdm.irp.f diff --git a/src/two_rdm_routines/all_states_update_openmp.irp.f b/src/two_rdm_routines/update_rdm.irp.f similarity index 100% rename from src/two_rdm_routines/all_states_update_openmp.irp.f rename to src/two_rdm_routines/update_rdm.irp.f From 2e90197987dc8181ab39cc3f88bd7c61527c767e Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 18:09:04 +0100 Subject: [PATCH 13/29] renamed and documented properly all providers for two rdms --- src/two_body_rdm/act_2_rdm.irp.f | 62 ++++----- src/two_body_rdm/example.irp.f | 25 ++++ src/two_body_rdm/full_orb_2_rdm.irp.f | 33 +++-- src/two_body_rdm/state_av_act_2rdm.irp.f | 124 +++++++++++------- .../state_av_full_orb_2_rdm.irp.f | 35 +++-- 5 files changed, 171 insertions(+), 108 deletions(-) diff --git a/src/two_body_rdm/act_2_rdm.irp.f b/src/two_body_rdm/act_2_rdm.irp.f index 4a8a64d2..5914f411 100644 --- a/src/two_body_rdm/act_2_rdm.irp.f +++ b/src/two_body_rdm/act_2_rdm.irp.f @@ -4,7 +4,11 @@ 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" ! @@ -12,17 +16,14 @@ ! ! act_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta ! -! Therefore you don't necessayr have symmetry between electron 1 and 2 +! 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*,'' - print*,'' print*,'Providing act_2_rdm_ab_mo ' ispin = 3 - print*,'ispin = ',ispin act_2_rdm_ab_mo = 0.d0 call wall_time(wall_1) 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)) @@ -35,27 +36,22 @@ 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/beta electrons +! 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" -! -! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is alpha, electron 2 is beta -! -! act_2_rdm_aa_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l:beta -! -! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC integer :: ispin double precision :: wall_1, wall_2 ! condition for alpha/beta spin print*,'' - print*,'' - print*,'' print*,'Providing act_2_rdm_aa_mo ' ispin = 1 - print*,'ispin = ',ispin act_2_rdm_aa_mo = 0.d0 call wall_time(wall_1) 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)) @@ -68,27 +64,22 @@ 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 +! 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" -! -! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta -! -! act_2_rdm_bb_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta -! -! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC integer :: ispin double precision :: wall_1, wall_2 ! condition for beta/beta spin print*,'' - print*,'' - print*,'' print*,'Providing act_2_rdm_bb_mo ' ispin = 2 - print*,'ispin = ',ispin act_2_rdm_bb_mo = 0.d0 call wall_time(wall_1) 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)) @@ -100,27 +91,22 @@ 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 of beta/beta electrons +! 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" -! -! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is beta, electron 2 is beta -! -! act_2_rdm_spin_trace_mo(i,j,k,l,istate) = i:beta, j:beta, j:beta, l:beta -! -! Therefore you don't necessayr have symmetry between electron 1 and 2 END_DOC integer :: ispin double precision :: wall_1, wall_2 ! condition for beta/beta spin print*,'' - print*,'' - print*,'' print*,'Providing act_2_rdm_spin_trace_mo ' ispin = 4 - print*,'ispin = ',ispin act_2_rdm_spin_trace_mo = 0.d0 call wall_time(wall_1) 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)) diff --git a/src/two_body_rdm/example.irp.f b/src/two_body_rdm/example.irp.f index fb4ac8ed..4400613c 100644 --- a/src/two_body_rdm/example.irp.f +++ b/src/two_body_rdm/example.irp.f @@ -152,6 +152,13 @@ subroutine routine_full_mos 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 @@ -194,6 +201,10 @@ subroutine routine_full_mos 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) @@ -211,6 +222,20 @@ subroutine routine_full_mos 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 diff --git a/src/two_body_rdm/full_orb_2_rdm.irp.f b/src/two_body_rdm/full_orb_2_rdm.irp.f index bc0350e2..fba88172 100644 --- a/src/two_body_rdm/full_orb_2_rdm.irp.f +++ b/src/two_body_rdm/full_orb_2_rdm.irp.f @@ -8,17 +8,19 @@ ! ! ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE RANGE OF OCCUPIED MOS (CORE+INACT+ACT) BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 ! -! act_2_rdm_ab_mo(i,j,k,l,istate) = i:alpha, j:beta, j:alpha, l: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 is set to zero +! !!!!! 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 @@ -135,9 +137,11 @@ ! ! ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 @@ -231,9 +235,11 @@ ! ! ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 @@ -327,11 +333,18 @@ ! ! ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 diff --git a/src/two_body_rdm/state_av_act_2rdm.irp.f b/src/two_body_rdm/state_av_act_2rdm.irp.f index 064ecc33..d85c3cdb 100644 --- a/src/two_body_rdm/state_av_act_2rdm.irp.f +++ b/src/two_body_rdm/state_av_act_2rdm.irp.f @@ -1,52 +1,22 @@ - - 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 -! = - 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 -! = - 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_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 @@ -68,15 +38,75 @@ 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 -! The active part of the two-electron energy can be computed as: ! -! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_2_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! = \sum_{istate} w(istate) * \sum_{sigma,sigma'} ! -! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) +! 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)) 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 index 9229d146..b3a5fe65 100644 --- 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 @@ -6,13 +6,15 @@ 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) * ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE RANGE OF OCCUPIED MOS (CORE+INACT+ACT) BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! THE NORMALIZATION (i.e. sum of diagonal elements) IS SET TO N_{\alpha} * N_{\beta} ! -! !!!!! WARNING !!!!! For efficiency reasons, electron 1 is ALPHA, electron 2 is 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 ! @@ -129,11 +131,13 @@ 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) * ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" +! WHERE ALL ORBITALS (i,j,k,l) BELONGS TO ALL OCCUPIED ORBITALS : core, inactive and active ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 @@ -223,12 +227,14 @@ 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" ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS -! ! !!!!! WARNING !!!!! IF "no_core_density" then all elements involving at least one CORE MO is set to zero END_DOC @@ -317,11 +323,14 @@ 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'} ! -! !!!!! WARNING !!!!! ALL SLATER DETERMINANTS IN PSI_DET MUST BELONG TO AN ACTIVE SPACE DEFINED BY "list_act" ! -! BUT THE STRUCTURE OF THE TWO-RDM ON THE FULL RANGE OF MOs IS IMPLEMENTED BECAUSE IT CAN BE CONVENIENT FOR SOME APPLICATIONS +! 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 From d9bb07a2f23f791462ed37b871628d37af036d8d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 18:18:18 +0100 Subject: [PATCH 14/29] renamed two rdm in casscf --- src/casscf/densities.irp.f | 3 +- src/casscf/get_energy.irp.f | 55 +------------------------------------ 2 files changed, 2 insertions(+), 56 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 3d1ff0f9..5c31b6bb 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -56,8 +56,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,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) + 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 From 6d0bcd96ed88c14301204905c5d65302e29c30d5 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 20:46:13 +0100 Subject: [PATCH 15/29] removed some useless cas_dft_one_e_dm --- src/determinants/cas_one_e_rdm.irp.f | 37 ---------------------------- 1 file changed, 37 deletions(-) delete mode 100644 src/determinants/cas_one_e_rdm.irp.f diff --git a/src/determinants/cas_one_e_rdm.irp.f b/src/determinants/cas_one_e_rdm.irp.f deleted file mode 100644 index 0471bde6..00000000 --- a/src/determinants/cas_one_e_rdm.irp.f +++ /dev/null @@ -1,37 +0,0 @@ - - BEGIN_PROVIDER [double precision, one_e_act_dm_beta_mo_for_dft, (n_act_orb,n_act_orb,N_states)] - implicit none - BEGIN_DOC - ! one_e_act_dm_beta_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the BETA ELECTRONS - END_DOC - integer :: i,j,ii,jj,istate - do istate = 1, N_states - do ii = 1, n_act_orb - i = list_act(ii) - do jj = 1, n_act_orb - j = list_act(jj) - one_e_act_dm_beta_mo_for_dft(jj,ii,istate) = one_e_dm_mo_beta(j,i,istate) - enddo - enddo - enddo - -END_PROVIDER - - BEGIN_PROVIDER [double precision, one_e_act_dm_alpha_mo_for_dft, (n_act_orb,n_act_orb,N_states)] - implicit none - BEGIN_DOC - ! one_e_act_dm_alpha_mo_for_dft = pure ACTIVE part of the ONE ELECTRON REDUCED DENSITY MATRIX for the ALPHA ELECTRONS - END_DOC - integer :: i,j,ii,jj,istate - do istate = 1, N_states - do ii = 1, n_act_orb - i = list_act(ii) - do jj = 1, n_act_orb - j = list_act(jj) - one_e_act_dm_alpha_mo_for_dft(jj,ii,istate) = one_e_dm_mo_alpha(j,i,istate) - enddo - enddo - enddo - -END_PROVIDER - From 26474d9c462000631af41c63e605138ed1523f4a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sun, 22 Mar 2020 21:59:21 +0100 Subject: [PATCH 16/29] cleaning in dft_utils_in_r --- src/dft_utils_in_r/dm_in_r.irp.f | 353 +--------------------- src/dft_utils_in_r/dm_in_r_routines.irp.f | 290 ++++++++++++++++++ 2 files changed, 305 insertions(+), 338 deletions(-) create mode 100644 src/dft_utils_in_r/dm_in_r_routines.irp.f 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..f043a70e 100644 --- a/src/dft_utils_in_r/dm_in_r.irp.f +++ b/src/dft_utils_in_r/dm_in_r.irp.f @@ -1,293 +1,3 @@ -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 - - - 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 @@ -320,9 +30,7 @@ end 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) ] implicit none BEGIN_DOC @@ -331,8 +39,7 @@ END_PROVIDER ! where r_i is the ith point of the grid and istate is the state number END_DOC integer :: i,istate - double precision :: r(3) - double precision, allocatable :: dm_a(:),dm_b(:) + double precision :: r(3),weight allocate(dm_a(N_states),dm_b(N_states)) do istate = 1, N_states do i = 1, n_points_final_grid @@ -340,8 +47,10 @@ END_PROVIDER 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) + weight = final_weight_at_r_vector(i) + + elec_beta_num_grid_becke(istate) += * weight + elec_alpha_num_grid_becke(istate) += * weight enddo enddo @@ -353,12 +62,20 @@ END_PROVIDER &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_PROVIDER [double precision, scal_prod_grad_one_e_dm_ab, (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 +! +! 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 END_DOC implicit none @@ -374,7 +91,6 @@ END_PROVIDER 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) @@ -390,48 +106,9 @@ END_PROVIDER 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)) + 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) 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) - enddo - 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 + + From 50123076a05088a48aa07cb577d81f5f386248dc Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 23 Mar 2020 01:19:30 +0100 Subject: [PATCH 17/29] cleaning and renamed a lot of stuffs in dft and density matrices --- src/dft_utils_in_r/dm_in_r.irp.f | 46 ++++++++++++++++++++++---------- src/dft_utils_one_e/sr_exc.irp.f | 4 +-- src/functionals/lda.irp.f | 16 +++++------ src/functionals/sr_lda.irp.f | 16 +++++------ 4 files changed, 50 insertions(+), 32 deletions(-) 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 f043a70e..c7ede35d 100644 --- a/src/dft_utils_in_r/dm_in_r.irp.f +++ b/src/dft_utils_in_r/dm_in_r.irp.f @@ -40,17 +40,15 @@ END_PROVIDER END_DOC integer :: i,istate double precision :: r(3),weight - allocate(dm_a(N_states),dm_b(N_states)) 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) weight = final_weight_at_r_vector(i) - elec_beta_num_grid_becke(istate) += * weight - elec_alpha_num_grid_becke(istate) += * weight + 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 enddo @@ -61,8 +59,8 @@ END_PROVIDER &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_PROVIDER [double precision, scal_prod_grad_one_e_dm_ab, (3,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 ! one_e_dm_and_grad_alpha_in_r(1,i,i_state) = d\dx n_alpha(r_i,istate) ! @@ -91,22 +89,42 @@ END_PROVIDER r(1) = final_grid_points(1,i) r(2) = final_grid_points(2,i) r(3) = final_grid_points(3,i) + 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) + + ! 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_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)) - 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) + + ! 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 diff --git a/src/dft_utils_one_e/sr_exc.irp.f b/src/dft_utils_one_e/sr_exc.irp.f index 3c5a6db5..c6bfcd09 100644 --- a/src/dft_utils_one_e/sr_exc.irp.f +++ b/src/dft_utils_one_e/sr_exc.irp.f @@ -20,8 +20,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) 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 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/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 From 4a527dc6a9e1df6e54660eada148aa2daa74dfd3 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 24 Mar 2020 11:56:37 +0100 Subject: [PATCH 18/29] added all_but_del_orb --- src/bitmask/core_inact_act_virt.irp.f | 29 +++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index d30e989f..b2cb36c0 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -413,3 +413,32 @@ 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 + 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 + list_all_but_del_orb(i) = i + endif + enddo + +END_PROVIDER + From bd51efc0115b82b2032da025e270b4398a4e86d2 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 24 Mar 2020 11:56:37 +0100 Subject: [PATCH 19/29] added all_but_del_orb in a clean way --- src/bitmask/core_inact_act_virt.irp.f | 29 +++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index d30e989f..b2cb36c0 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -413,3 +413,32 @@ 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 + 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 + list_all_but_del_orb(i) = i + endif + enddo + +END_PROVIDER + From 8f7e7ff264e412047578036c17d35fdab4cfbe93 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 25 Mar 2020 16:01:20 +0100 Subject: [PATCH 20/29] bug in CASSCF --- src/bitmask/core_inact_act_virt.irp.f | 4 +++- src/dft_utils_one_e/utils.irp.f | 23 ++++++++++++++--------- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index b2cb36c0..26942c93 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -431,12 +431,14 @@ 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 - list_all_but_del_orb(i) = i + j += 1 + list_all_but_del_orb(j) = i endif enddo diff --git a/src/dft_utils_one_e/utils.irp.f b/src/dft_utils_one_e/utils.irp.f index 06ba4f30..4ddec671 100644 --- a/src/dft_utils_one_e/utils.irp.f +++ b/src/dft_utils_one_e/utils.irp.f @@ -14,15 +14,20 @@ subroutine GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_ 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 :: 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) - - 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)) + vx_rho_a(istate) = d/e_xmd(n_a,n_b,grad_na,grad_nb,grad_n_a . grad_n_b)/d_n_a + vx_rho_b + vx_grad_rho_a_2 d/e_xmd(n_a,n_b,grad_na,grad_nb,grad_n_a . grad_n_b)/d_grad_rho_a_2 + vx_grad_rho_b_2 + vx_grad_rho_a_b +! 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) +! +! 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 From f51aa26d2bceb755b2cc722df3b612f11f877fba Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Wed, 25 Mar 2020 16:13:26 +0100 Subject: [PATCH 21/29] Bug seems fixed in casscf ... ? --- src/casscf/densities.irp.f | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 5c31b6bb..d181d732 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -49,13 +49,10 @@ 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) + ! 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 From 0a6ad5f6ded1b7461e817a324d0e58aaf29a3fbd Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 27 Mar 2020 14:34:38 +0100 Subject: [PATCH 22/29] removed stupid bug in src/dft_utils_one_e/utils.irp.f --- src/dft_utils_one_e/utils.irp.f | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/dft_utils_one_e/utils.irp.f b/src/dft_utils_one_e/utils.irp.f index 4ddec671..06ba4f30 100644 --- a/src/dft_utils_one_e/utils.irp.f +++ b/src/dft_utils_one_e/utils.irp.f @@ -14,20 +14,15 @@ subroutine GGA_sr_type_functionals(r,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_ 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)) - vx_rho_a(istate) = d/e_xmd(n_a,n_b,grad_na,grad_nb,grad_n_a . grad_n_b)/d_n_a - vx_rho_b - vx_grad_rho_a_2 d/e_xmd(n_a,n_b,grad_na,grad_nb,grad_n_a . grad_n_b)/d_grad_rho_a_2 - vx_grad_rho_b_2 - vx_grad_rho_a_b -! 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) -! -! 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)) + 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) + + 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 From 192854f771a92c4f1a39917451b43978b518e172 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 27 Mar 2020 18:06:31 +0100 Subject: [PATCH 23/29] minor cleaning in dft_utils_in_r --- src/dft_utils_in_r/dm_in_r.irp.f | 113 ++++++++++++------------------- 1 file changed, 43 insertions(+), 70 deletions(-) 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 c7ede35d..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,60 +1,3 @@ - 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 :: 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 - - enddo - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, elec_beta_num_grid_becke , (N_states) ] -&BEGIN_PROVIDER [double precision, elec_alpha_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 - END_DOC - integer :: i,istate - 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) - 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 - 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) ] @@ -62,19 +5,21 @@ END_PROVIDER &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 -! 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 + ! 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 implicit none integer :: i,j,k,l,m,istate @@ -130,3 +75,31 @@ END_PROVIDER END_PROVIDER + + 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 + ! 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),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) + 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 + + From 9d2d00f0404faf6aba2775864cb62d7089d0a234 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 30 Mar 2020 16:00:50 +0200 Subject: [PATCH 24/29] more cleaning in functionals --- src/dft_utils_one_e/ec_lyp.irp.f | 125 --------- src/dft_utils_one_e/ec_lyp_2.irp.f | 28 -- src/dft_utils_one_e/ec_scan.irp.f | 99 ------- src/dft_utils_one_e/ec_scan_2.irp.f | 100 ------- src/dft_utils_one_e/effective_pot.irp.f | 3 + src/dft_utils_one_e/garbage_func.irp.f | 264 ++++++++++++++++++ src/dft_utils_one_e/rho_ab_to_rho_tot.irp.f | 34 +++ ...sr_lda.irp.f => routines_exc_sr_lda.irp.f} | 0 ...sr_pbe.irp.f => routines_exc_sr_pbe.irp.f} | 16 ++ src/dft_utils_one_e/sr_exc.irp.f | 86 ------ 10 files changed, 317 insertions(+), 438 deletions(-) delete mode 100644 src/dft_utils_one_e/ec_lyp.irp.f delete mode 100644 src/dft_utils_one_e/ec_lyp_2.irp.f delete mode 100644 src/dft_utils_one_e/ec_scan.irp.f delete mode 100644 src/dft_utils_one_e/ec_scan_2.irp.f create mode 100644 src/dft_utils_one_e/garbage_func.irp.f rename src/dft_utils_one_e/{exc_sr_lda.irp.f => routines_exc_sr_lda.irp.f} (100%) rename src/dft_utils_one_e/{exc_sr_pbe.irp.f => routines_exc_sr_pbe.irp.f} (96%) delete mode 100644 src/dft_utils_one_e/sr_exc.irp.f 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..5a61de15 100644 --- a/src/dft_utils_one_e/effective_pot.irp.f +++ b/src/dft_utils_one_e/effective_pot.irp.f @@ -7,8 +7,11 @@ ! 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. ! END_DOC 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/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 c6bfcd09..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_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) - 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 - From f4fa819249fffc22690494a4dfcf5390d7667702 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 30 Mar 2020 17:40:24 +0200 Subject: [PATCH 25/29] cleaning in dft --- src/README.rst | 48 ++++++ src/dft_utils_one_e/utils.irp.f | 60 +++----- src/functionals/pbe.irp.f | 83 ++++------ src/functionals/sr_pbe.irp.f | 261 +++++++++++++++----------------- src/hartree_fock/10.hf.bats | 2 +- 5 files changed, 219 insertions(+), 235 deletions(-) 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/dft_utils_one_e/utils.irp.f b/src/dft_utils_one_e/utils.irp.f index 06ba4f30..faa97c11 100644 --- a/src/dft_utils_one_e/utils.irp.f +++ b/src/dft_utils_one_e/utils.irp.f @@ -1,58 +1,32 @@ -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 :: 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) - - 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 - - -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) + 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 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) + ! 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 + diff --git a/src/functionals/pbe.irp.f b/src/functionals/pbe.irp.f index f6122f89..48b0661d 100644 --- a/src/functionals/pbe.irp.f +++ b/src/functionals/pbe.irp.f @@ -6,7 +6,6 @@ ! 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(:) @@ -22,9 +21,6 @@ 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) @@ -40,7 +36,7 @@ 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(0.d0,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 @@ -56,7 +52,6 @@ BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ] ! 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(:) @@ -72,9 +67,6 @@ BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ] energy_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) @@ -90,7 +82,7 @@ BEGIN_PROVIDER[double precision, energy_c_pbe, (N_states) ] 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(0.d0,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 @@ -159,7 +151,6 @@ END_PROVIDER ! 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(:) @@ -179,9 +170,6 @@ END_PROVIDER 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) @@ -197,7 +185,7 @@ END_PROVIDER 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(0.d0,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 @@ -325,63 +313,54 @@ END_PROVIDER ! 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 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 - 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 + ! call exc_sr_pbe + call GGA_sr_type_functionals(0.d0,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! inputs + ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs exchange + ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) ! outputs correlation + 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_dvxc_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_dvxc_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 diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index c0cd3cd1..46bd1f38 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, allocatable :: 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 @@ -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 @@ -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 } From 7bd7b6294cdf6187f5d0d40e0a232d60e7762572 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 30 Mar 2020 19:30:29 +0200 Subject: [PATCH 26/29] removed small bug --- src/dft_keywords/EZFIO.cfg | 4 ++-- src/dft_utils_one_e/utils.irp.f | 4 +--- src/functionals/sr_pbe.irp.f | 2 +- 3 files changed, 4 insertions(+), 6 deletions(-) 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_one_e/utils.irp.f b/src/dft_utils_one_e/utils.irp.f index faa97c11..21816fa8 100644 --- a/src/dft_utils_one_e/utils.irp.f +++ b/src/dft_utils_one_e/utils.irp.f @@ -9,10 +9,8 @@ subroutine GGA_sr_type_functionals(mu,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad 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 - integer :: istate - double precision :: r2(3),dr2(3), local_potential,r12,dx2 + double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,vrhoc,vrhoo,vsigmacc,vsigmaco,vsigmaoo - double precision :: rhoc,rhoo,sigmacc,sigmaco,sigmaoo,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) diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index 46bd1f38..f6043479 100644 --- a/src/functionals/sr_pbe.irp.f +++ b/src/functionals/sr_pbe.irp.f @@ -12,7 +12,7 @@ END_DOC integer :: istate,i,j,m double precision :: mu,weight - double precision, allocatable :: ex, ec + 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 From 506f1cb09456b5d85b99ce4c51fdc2b73ebf1bea Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 31 Mar 2020 14:13:49 +0200 Subject: [PATCH 27/29] modified pbe.irp.f --- src/dft_utils_one_e/effective_pot.irp.f | 5 +- src/dft_utils_one_e/mu_erf_dft.irp.f | 4 +- src/functionals/pbe.irp.f | 343 +++++++++++------------- src/mo_one_e_ints/EZFIO.cfg | 1 - 4 files changed, 155 insertions(+), 198 deletions(-) diff --git a/src/dft_utils_one_e/effective_pot.irp.f b/src/dft_utils_one_e/effective_pot.irp.f index 5a61de15..27f4841e 100644 --- a/src/dft_utils_one_e/effective_pot.irp.f +++ b/src/dft_utils_one_e/effective_pot.irp.f @@ -10,10 +10,9 @@ ! ! 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/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/functionals/pbe.irp.f b/src/functionals/pbe.irp.f index 48b0661d..df32cce2 100644 --- a/src/functionals/pbe.irp.f +++ b/src/functionals/pbe.irp.f @@ -1,124 +1,79 @@ - 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 :: 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 - 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(0.d0,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 :: 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 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(0.d0,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 do i = 1, ao_num do j = 1, ao_num - potential_x_alpha_ao_pbe(j,i,istate) = pot_scal_x_alpha_ao_pbe(j,i,istate) + pot_grad_x_alpha_ao_pbe(j,i,istate) + pot_grad_x_alpha_ao_pbe(i,j,istate) - potential_x_beta_ao_pbe(j,i,istate) = pot_scal_x_beta_ao_pbe(j,i,istate) + pot_grad_x_beta_ao_pbe(j,i,istate) + pot_grad_x_beta_ao_pbe(i,j,istate) + potential_x_alpha_ao_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_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_pbe(j,i,istate) = pot_scal_c_alpha_ao_pbe(j,i,istate) + pot_grad_c_alpha_ao_pbe(j,i,istate) + pot_grad_c_alpha_ao_pbe(i,j,istate) - potential_c_beta_ao_pbe(j,i,istate) = pot_scal_c_beta_ao_pbe(j,i,istate) + pot_grad_c_beta_ao_pbe(j,i,istate) + pot_grad_c_beta_ao_pbe(i,j,istate) + potential_c_alpha_ao_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_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_pbe,(ao_num,ao_num,N_states)] &BEGIN_PROVIDER [double precision, potential_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none @@ -129,8 +84,8 @@ END_PROVIDER do istate = 1, n_states 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_alpha_ao_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_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 @@ -138,78 +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_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)] +&BEGIN_PROVIDER[double precision, aos_sr_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_sr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_dsr_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_dsr_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_dsr_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_dsr_vx_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) +! 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 :: 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_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 + mu = 0.d0 do istate = 1, N_states do i = 1, n_points_final_grid 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(0.d0,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_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_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_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 @@ -218,42 +171,44 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_scal_x_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_scal_c_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&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)] + BEGIN_PROVIDER [double precision, pot_sr_scal_x_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_scal_c_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&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 END_DOC - pot_scal_c_alpha_ao_pbe = 0.d0 - pot_scal_x_alpha_ao_pbe = 0.d0 - pot_scal_c_beta_ao_pbe = 0.d0 - pot_scal_x_beta_ao_pbe = 0.d0 + pot_sr_scal_c_alpha_ao_pbe = 0.d0 + pot_sr_scal_x_alpha_ao_pbe = 0.d0 + pot_sr_scal_c_beta_ao_pbe = 0.d0 + pot_sr_scal_x_beta_ao_pbe = 0.d0 double precision :: wall_1,wall_2 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_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_scal_c_alpha_ao_pbe(1,1,istate),size(pot_scal_c_alpha_ao_pbe,1)) + 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_vc_beta_pbe_w(1,1,istate),size(aos_vc_beta_pbe_w,1), & + 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_scal_c_beta_ao_pbe(1,1,istate),size(pot_scal_c_beta_ao_pbe,1)) + 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_vx_alpha_pbe_w(1,1,istate),size(aos_vx_alpha_pbe_w,1), & + 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_scal_x_alpha_ao_pbe(1,1,istate),size(pot_scal_x_alpha_ao_pbe,1)) + 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_vx_beta_pbe_w(1,1,istate),size(aos_vx_beta_pbe_w,1), & + 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_scal_x_beta_ao_pbe(1,1,istate), size(pot_scal_x_beta_ao_pbe,1)) + pot_sr_scal_x_beta_ao_pbe(1,1,istate), size(pot_sr_scal_x_beta_ao_pbe,1)) enddo call wall_time(wall_2) @@ -261,10 +216,10 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_grad_x_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_grad_x_beta_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_grad_c_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_grad_c_beta_ao_pbe,(ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_sr_grad_x_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_grad_x_beta_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_grad_c_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_grad_c_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the gradienst of the density and orbitals @@ -272,31 +227,31 @@ END_PROVIDER integer :: istate double precision :: wall_1,wall_2 call wall_time(wall_1) - pot_grad_c_alpha_ao_pbe = 0.d0 - pot_grad_x_alpha_ao_pbe = 0.d0 - pot_grad_c_beta_ao_pbe = 0.d0 - pot_grad_x_beta_ao_pbe = 0.d0 + pot_sr_grad_c_alpha_ao_pbe = 0.d0 + pot_sr_grad_x_alpha_ao_pbe = 0.d0 + pot_sr_grad_c_beta_ao_pbe = 0.d0 + 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_dvc_alpha_pbe_w(1,1,istate),size(aos_dvc_alpha_pbe_w,1), & + 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_grad_c_alpha_ao_pbe(1,1,istate),size(pot_grad_c_alpha_ao_pbe,1)) + 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_dvc_beta_pbe_w(1,1,istate),size(aos_dvc_beta_pbe_w,1), & + 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_grad_c_beta_ao_pbe(1,1,istate),size(pot_grad_c_beta_ao_pbe,1)) + 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_dvx_alpha_pbe_w(1,1,istate),size(aos_dvx_alpha_pbe_w,1), & + 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_grad_x_alpha_ao_pbe(1,1,istate),size(pot_grad_x_alpha_ao_pbe,1)) + 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_dvx_beta_pbe_w(1,1,istate),size(aos_dvx_beta_pbe_w,1), & + 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_grad_x_beta_ao_pbe(1,1,istate),size(pot_grad_x_beta_ao_pbe,1)) + pot_sr_grad_x_beta_ao_pbe(1,1,istate),size(pot_sr_grad_x_beta_ao_pbe,1)) enddo call wall_time(wall_2) @@ -304,13 +259,13 @@ END_PROVIDER 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_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)] +&BEGIN_PROVIDER[double precision, aos_dsr_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] +&BEGIN_PROVIDER[double precision, aos_dsr_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) +! 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 :: mu,weight @@ -320,8 +275,9 @@ END_PROVIDER 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_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 @@ -339,28 +295,28 @@ END_PROVIDER grad_rho_a_b += grad_rho_a(m) * grad_rho_b(m) enddo - ! call exc_sr_pbe - call GGA_sr_type_functionals(0.d0,rho_a,rho_b,grad_rho_a_2,grad_rho_b_2,grad_rho_a_b, & ! inputs - ex,vx_rho_a,vx_rho_b,vx_grad_rho_a_2,vx_grad_rho_b_2,vx_grad_rho_a_b, & ! outputs exchange - ec,vc_rho_a,vc_rho_b,vc_grad_rho_a_2,vc_grad_rho_b_2,vc_grad_rho_a_b ) ! outputs correlation + ! inputs + 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 *= weight vc_rho_a *= weight vx_rho_b *= weight vc_rho_b *= weight do m= 1,3 - 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)) + 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 + 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) + 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_dvxc_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_dvxc_beta_pbe_w (j,i,istate) += ( contrib_grad_cb(m) + contrib_grad_xb(m) ) * 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 @@ -369,36 +325,36 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_scal_xc_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_scal_xc_beta_ao_pbe, (ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_sr_scal_xc_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_scal_xc_beta_ao_pbe, (ao_num,ao_num,N_states)] implicit none 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 END_DOC - pot_scal_xc_alpha_ao_pbe = 0.d0 - pot_scal_xc_beta_ao_pbe = 0.d0 + pot_sr_scal_xc_alpha_ao_pbe = 0.d0 + pot_sr_scal_xc_beta_ao_pbe = 0.d0 double precision :: wall_1,wall_2 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_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_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_scal_xc_alpha_ao_pbe,1)) + 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_vxc_beta_pbe_w(1,1,istate),size(aos_vxc_beta_pbe_w,1), & + 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_scal_xc_beta_ao_pbe(1,1,istate),size(pot_scal_xc_beta_ao_pbe,1)) + 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) END_PROVIDER - BEGIN_PROVIDER [double precision, pot_grad_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_grad_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_sr_grad_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_sr_grad_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the gradienst of the density and orbitals @@ -406,21 +362,22 @@ END_PROVIDER integer :: istate double precision :: wall_1,wall_2 call wall_time(wall_1) - pot_grad_xc_alpha_ao_pbe = 0.d0 - pot_grad_xc_beta_ao_pbe = 0.d0 + pot_sr_grad_xc_alpha_ao_pbe = 0.d0 + pot_sr_grad_xc_beta_ao_pbe = 0.d0 do istate = 1, N_states - ! correlation alpha + ! exchange - 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_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_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_grad_xc_alpha_ao_pbe,1)) - ! correlation beta + 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_dvxc_beta_pbe_w(1,1,istate),size(aos_dvxc_beta_pbe_w,1), & + 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_grad_xc_beta_ao_pbe(1,1,istate),size(pot_grad_xc_beta_ao_pbe,1)) + pot_sr_grad_xc_beta_ao_pbe(1,1,istate),size(pot_sr_grad_xc_beta_ao_pbe,1)) enddo call wall_time(wall_2) END_PROVIDER + 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 From b85f60627f94db7453cb2e650e479d66acf81f44 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Tue, 31 Mar 2020 14:25:01 +0200 Subject: [PATCH 28/29] cleaning in functionals --- src/functionals/pbe.irp.f | 220 +++++++++++++++++------------------ src/functionals/sr_pbe.irp.f | 72 ++++++------ 2 files changed, 146 insertions(+), 146 deletions(-) diff --git a/src/functionals/pbe.irp.f b/src/functionals/pbe.irp.f index df32cce2..23b3925b 100644 --- a/src/functionals/pbe.irp.f +++ b/src/functionals/pbe.irp.f @@ -63,11 +63,11 @@ END_PROVIDER do istate = 1, n_states do i = 1, ao_num do j = 1, ao_num - potential_x_alpha_ao_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_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_x_alpha_ao_pbe(j,i,istate) = pot_scal_x_alpha_ao_pbe(j,i,istate) + pot_grad_x_alpha_ao_pbe(j,i,istate) + pot_grad_x_alpha_ao_pbe(i,j,istate) + potential_x_beta_ao_pbe(j,i,istate) = pot_scal_x_beta_ao_pbe(j,i,istate) + pot_grad_x_beta_ao_pbe(j,i,istate) + pot_grad_x_beta_ao_pbe(i,j,istate) - potential_c_alpha_ao_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_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) + potential_c_alpha_ao_pbe(j,i,istate) = pot_scal_c_alpha_ao_pbe(j,i,istate) + pot_grad_c_alpha_ao_pbe(j,i,istate) + pot_grad_c_alpha_ao_pbe(i,j,istate) + potential_c_beta_ao_pbe(j,i,istate) = pot_scal_c_beta_ao_pbe(j,i,istate) + pot_grad_c_beta_ao_pbe(j,i,istate) + pot_grad_c_beta_ao_pbe(i,j,istate) enddo enddo enddo @@ -84,8 +84,8 @@ END_PROVIDER do istate = 1, n_states do i = 1, ao_num do j = 1, ao_num - potential_xc_alpha_ao_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_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) + 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) enddo enddo enddo @@ -94,19 +94,19 @@ 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)] -&BEGIN_PROVIDER[double precision, aos_sr_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_sr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dsr_vc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dsr_vc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dsr_vx_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dsr_vx_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] + 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_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_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) +! 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 :: mu,weight @@ -115,10 +115,10 @@ END_PROVIDER 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 + 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 @@ -152,17 +152,17 @@ END_PROVIDER 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 * 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) + 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_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) + 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 @@ -171,10 +171,10 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_sr_scal_x_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_scal_c_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&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)] + BEGIN_PROVIDER [double precision, pot_scal_x_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_scal_c_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&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 ! @@ -182,33 +182,33 @@ END_PROVIDER BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the scalar part of the potential END_DOC - pot_sr_scal_c_alpha_ao_pbe = 0.d0 - pot_sr_scal_x_alpha_ao_pbe = 0.d0 - pot_sr_scal_c_beta_ao_pbe = 0.d0 - pot_sr_scal_x_beta_ao_pbe = 0.d0 + pot_scal_c_alpha_ao_pbe = 0.d0 + pot_scal_x_alpha_ao_pbe = 0.d0 + pot_scal_c_beta_ao_pbe = 0.d0 + pot_scal_x_beta_ao_pbe = 0.d0 double precision :: wall_1,wall_2 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, & - pot_sr_scal_c_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_c_alpha_ao_pbe,1)) + 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_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)) + 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_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)) + 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_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)) + 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 call wall_time(wall_2) @@ -216,10 +216,10 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_sr_grad_x_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_grad_x_beta_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_grad_c_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_grad_c_beta_ao_pbe,(ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_grad_x_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_grad_x_beta_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_grad_c_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_grad_c_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the gradienst of the density and orbitals @@ -227,31 +227,31 @@ END_PROVIDER integer :: istate double precision :: wall_1,wall_2 call wall_time(wall_1) - pot_sr_grad_c_alpha_ao_pbe = 0.d0 - pot_sr_grad_x_alpha_ao_pbe = 0.d0 - pot_sr_grad_c_beta_ao_pbe = 0.d0 - pot_sr_grad_x_beta_ao_pbe = 0.d0 + pot_grad_c_alpha_ao_pbe = 0.d0 + pot_grad_x_alpha_ao_pbe = 0.d0 + pot_grad_c_beta_ao_pbe = 0.d0 + 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_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)) + 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_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)) + 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_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)) + 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_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)) + 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 call wall_time(wall_2) @@ -259,13 +259,13 @@ END_PROVIDER 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)] -&BEGIN_PROVIDER[double precision, aos_dsr_vxc_alpha_pbe_w , (ao_num,n_points_final_grid,N_states)] -&BEGIN_PROVIDER[double precision, aos_dsr_vxc_beta_pbe_w , (ao_num,n_points_final_grid,N_states)] + 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_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_sr_vxc_alpha_pbe_w(j,i) = ao_i(r_j) * (v^x_alpha(r_j) + v^c_alpha(r_j)) * W(r_j) +! 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 :: mu,weight @@ -276,8 +276,8 @@ END_PROVIDER 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 mu = 0.d0 - aos_dsr_vxc_alpha_pbe_w = 0.d0 - aos_dsr_vxc_beta_pbe_w = 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 @@ -310,13 +310,13 @@ END_PROVIDER 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 + 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) + 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_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) + 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 @@ -325,36 +325,36 @@ END_PROVIDER END_PROVIDER - BEGIN_PROVIDER [double precision, pot_sr_scal_xc_alpha_ao_pbe, (ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_scal_xc_beta_ao_pbe, (ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_scal_xc_alpha_ao_pbe, (ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_scal_xc_beta_ao_pbe, (ao_num,ao_num,N_states)] implicit none 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 END_DOC - pot_sr_scal_xc_alpha_ao_pbe = 0.d0 - pot_sr_scal_xc_beta_ao_pbe = 0.d0 + pot_scal_xc_alpha_ao_pbe = 0.d0 + pot_scal_xc_beta_ao_pbe = 0.d0 double precision :: wall_1,wall_2 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, & - pot_sr_scal_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_scal_xc_alpha_ao_pbe,1)) + 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_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)) + 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) END_PROVIDER - BEGIN_PROVIDER [double precision, pot_sr_grad_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, pot_sr_grad_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] + BEGIN_PROVIDER [double precision, pot_grad_xc_alpha_ao_pbe,(ao_num,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, pot_grad_xc_beta_ao_pbe,(ao_num,ao_num,N_states)] implicit none BEGIN_DOC ! intermediate quantity for the calculation of the vxc potentials for the GGA functionals related to the gradienst of the density and orbitals @@ -362,19 +362,19 @@ END_PROVIDER integer :: istate double precision :: wall_1,wall_2 call wall_time(wall_1) - pot_sr_grad_xc_alpha_ao_pbe = 0.d0 - pot_sr_grad_xc_beta_ao_pbe = 0.d0 + pot_grad_xc_alpha_ao_pbe = 0.d0 + pot_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, & - pot_sr_grad_xc_alpha_ao_pbe(1,1,istate),size(pot_sr_grad_xc_alpha_ao_pbe,1)) + 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)) ! 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, & - pot_sr_grad_xc_beta_ao_pbe(1,1,istate),size(pot_sr_grad_xc_beta_ao_pbe,1)) + 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) diff --git a/src/functionals/sr_pbe.irp.f b/src/functionals/sr_pbe.irp.f index f6043479..af202cfb 100644 --- a/src/functionals/sr_pbe.irp.f +++ b/src/functionals/sr_pbe.irp.f @@ -188,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 @@ -231,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 @@ -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 From 25102d79a31e9de594e07114f9696284963c897e Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 2 Apr 2020 14:22:01 +0200 Subject: [PATCH 29/29] fixed a bug in two_rdm, added the possibility to Write/Read the all_states active 2 rdm --- src/bitmask/EZFIO.cfg | 5 ++ src/bitmask/core_inact_act_virt.irp.f | 5 +- src/two_body_rdm/EZFIO.cfg | 48 ++++++++++++++++++ src/two_body_rdm/README.rst | 3 +- src/two_body_rdm/act_2_rdm.irp.f | 49 +++++++++++++++++-- src/two_rdm_routines/davidson_like_2rdm.irp.f | 12 ++--- .../davidson_like_state_av_2rdm.irp.f | 13 +++-- src/two_rdm_routines/update_rdm.irp.f | 2 - ...av_rdm.irp.f => update_state_av_rdm.irp.f} | 0 9 files changed, 115 insertions(+), 22 deletions(-) create mode 100644 src/bitmask/EZFIO.cfg create mode 100644 src/two_body_rdm/EZFIO.cfg rename src/two_rdm_routines/{updata_state_av_rdm.irp.f => update_state_av_rdm.irp.f} (100%) 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 26942c93..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 ] 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/README.rst b/src/two_body_rdm/README.rst index 69f1f2a4..c82f7b0a 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -3,7 +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/act_2_rdm.irp.f b/src/two_body_rdm/act_2_rdm.irp.f index 5914f411..3d4a9ace 100644 --- a/src/two_body_rdm/act_2_rdm.irp.f +++ b/src/two_body_rdm/act_2_rdm.irp.f @@ -26,8 +26,17 @@ ispin = 3 act_2_rdm_ab_mo = 0.d0 call wall_time(wall_1) - 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)) - + 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 @@ -54,7 +63,17 @@ ispin = 1 act_2_rdm_aa_mo = 0.d0 call wall_time(wall_1) - 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)) + 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 @@ -82,7 +101,17 @@ ispin = 2 act_2_rdm_bb_mo = 0.d0 call wall_time(wall_1) - 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)) + 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 @@ -109,7 +138,17 @@ ispin = 4 act_2_rdm_spin_trace_mo = 0.d0 call wall_time(wall_1) - 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)) + 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 diff --git a/src/two_rdm_routines/davidson_like_2rdm.irp.f b/src/two_rdm_routines/davidson_like_2rdm.irp.f index 2b1e2cfa..3ad218e0 100644 --- a/src/two_rdm_routines/davidson_like_2rdm.irp.f +++ b/src/two_rdm_routines/davidson_like_2rdm.irp.f @@ -137,7 +137,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin PROVIDE N_int call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) - sze_buff = 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 @@ -267,7 +267,7 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin 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) -! print*,'coucou' + enddo endif @@ -347,15 +347,13 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin 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) + 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 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_2_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) - 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) -! print*,'to do orb_range_off_diag_single_to_2_rdm_aa_dm_buffer' + 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 @@ -382,7 +380,6 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin 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) -! print*,'to do orb_range_off_diag_double_to_2_rdm_aa_dm_buffer' enddo endif call update_keys_values_n_states(keys,values,nkeys,dim1,n_st,big_array,lock_2rdm) @@ -453,7 +450,6 @@ subroutine orb_range_2_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,ispin 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) -! print*,'to do orb_range_off_diag_single_to_2_rdm_ab_dm_buffer' ! increment the beta /beta part for single excitations 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) diff --git a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f index 2a6e10a2..eb247dea 100644 --- a/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f +++ b/src/two_rdm_routines/davidson_like_state_av_2rdm.irp.f @@ -139,7 +139,7 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ 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 @@ -271,11 +271,12 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ endif endif 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) -! print*,'todo orb_range_off_diag_double_to_2_rdm_ab_dm_buffer' - + enddo endif + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 enddo enddo @@ -364,6 +365,8 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ enddo + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + nkeys = 0 ! Compute Hij for all alpha doubles ! ---------------------------------- @@ -389,6 +392,8 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ 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 @@ -466,6 +471,8 @@ subroutine orb_range_2_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_ 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 ! ---------------------------------- diff --git a/src/two_rdm_routines/update_rdm.irp.f b/src/two_rdm_routines/update_rdm.irp.f index 54ba59ec..4d74280e 100644 --- a/src/two_rdm_routines/update_rdm.irp.f +++ b/src/two_rdm_routines/update_rdm.irp.f @@ -257,11 +257,9 @@ if(list_orb_reverse(p2).lt.0)return p2 = list_orb_reverse(p2) if(alpha_beta)then -! print*,'coucou' nkeys += 1 do istate = 1, N_st values(istate,nkeys) = c_1(istate) * phase -! print*,'values',values(istate,nkeys),nkeys enddo keys(1,nkeys) = h1 keys(2,nkeys) = h2 diff --git a/src/two_rdm_routines/updata_state_av_rdm.irp.f b/src/two_rdm_routines/update_state_av_rdm.irp.f similarity index 100% rename from src/two_rdm_routines/updata_state_av_rdm.irp.f rename to src/two_rdm_routines/update_state_av_rdm.irp.f