From 6d30e194b894dbba11dec21ac349b1a6eb069f51 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 13 Apr 2017 20:04:35 +0200 Subject: [PATCH 01/48] working on davidson --- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 3 ++- src/Davidson/u0Hu0.irp.f | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index afb1a50c..d78a9705 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -405,12 +405,13 @@ subroutine get_carlo_workbatch(computed, comb, Ncomb, tbc) return endif icount = icount + tbc(0) - tbc_save - if (icount > n) then + if ((i>1000).and.(icount > n)) then call get_filling_teeth(computed, tbc) icount = 0 n = ishft(tbc_save,-4) endif enddo + call get_filling_teeth(computed, tbc) end subroutine diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index b096d407..af01eba8 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -656,7 +656,7 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) v_0 = 0.d0 - do k_a=1,N_det-1 + do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation ! ----------------------------------------------------------------------- @@ -947,6 +947,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze integer :: exc(0:2,2,2) call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) if ((degree == 2).and.(exc(0,1,1)==1)) cycle +! if ((degree > 1)) cycle ! if (exc(0,1,2) /= 0) cycle call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) vt (:,i) = vt (:,i) + hij*u_0(j,:) From 77f38a94a2924c5f39cdaddd1762e9432e3212bb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 11:09:55 +0200 Subject: [PATCH 02/48] working on davidson --- src/Davidson/u0Hu0.irp.f | 279 +++++++++++++++--------- src/Determinants/slater_rules.irp.f | 5 +- src/Determinants/spindeterminants.irp.f | 12 + 3 files changed, 195 insertions(+), 101 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index af01eba8..b7d47e08 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -632,9 +632,9 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) PROVIDE ref_bitmask_energy double precision :: hij, s2 - integer :: i,j + integer :: i,j,k integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: degree, istate + integer :: istate integer :: krow, kcol, krow_b, kcol_b integer :: lrow, lcol integer :: mrow, mcol @@ -646,16 +646,20 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) double precision :: ck(N_st), cl(N_st), cm(N_st) integer :: n_singles, n_doubles integer, allocatable :: singles(:), doubles(:) + integer, allocatable :: singles_a(:,:), singles_b(:,:) integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) + logical, allocatable :: is_single_b(:) + integer :: maxab, n_singles_max - allocate( buffer(N_int,N_det_alpha_unique), & - singles(N_det_alpha_unique), doubles(N_det_alpha_unique), & + maxab = max(N_det_alpha_unique, N_det_beta_unique) + allocate( buffer(N_int,maxab), & + singles(maxab), doubles(maxab), & is_single_a(N_det_alpha_unique), & - idx(N_det_alpha_unique), idx0(N_det_alpha_unique) ) + is_single_b(N_det_beta_unique), & + idx(maxab), idx0(maxab)) v_0 = 0.d0 - do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation @@ -690,12 +694,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) i=1 l_a = k_a+1 lcol = psi_bilinear_matrix_columns(l_a) - do while ( (lcol == kcol).and.(l_a <= N_det) ) + do while (lcol == kcol) lrow = psi_bilinear_matrix_rows(l_a) buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow) idx(i) = lrow - i=i+1 - l_a = l_a + 1 + i = i +1 + l_a = l_a+1 + if (l_a > N_det) exit lcol = psi_bilinear_matrix_columns(l_a) enddo i = i-1 @@ -747,12 +752,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) i=1 l_b = k_b+1 lrow = psi_bilinear_matrix_transp_rows(l_b) - do while ( (lrow == krow).and.(l_b <= N_det) ) + do while (lrow == krow) lcol = psi_bilinear_matrix_transp_columns(l_b) buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol) idx(i) = lcol - i=i+1 - l_b = l_b + 1 + i = i +1 + l_b = l_b+1 + if (l_b > N_det) exit lrow = psi_bilinear_matrix_transp_rows(l_b) enddo i = i-1 @@ -801,115 +807,190 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Alpha/Beta double excitations ! ============================= - do i=1,N_det_beta_unique + do i=1,maxab idx0(i) = i enddo - is_single_a(:) = .False. - k_a=1 - do i=1,N_det_beta_unique - - ! Select a beta determinant - ! ------------------------- - - spindet(1:N_int) = psi_det_beta_unique(1:N_int, i) - tmp_det(1:N_int,2) = spindet(1:N_int) + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + n_singles_max = 0 + do i=1,N_det_alpha_unique + spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) call get_all_spin_singles( & - psi_det_beta_unique, idx0, spindet, N_int, N_det_beta_unique, & - singles, n_singles ) + psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& + singles, n_singles) + n_singles_max = max(n_singles_max, n_singles) + enddo - do j=1,n_singles - is_single_a( singles(j) ) = .True. - enddo + allocate (singles_a(0:n_singles_max, N_det_alpha_unique)) + do i=1,N_det_alpha_unique + spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& + singles_a(1,i), singles_a(0,i)) + enddo - ! For all alpha.beta pairs with the selected beta - ! ----------------------------------------------- + do k_a=1,N_det + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) kcol = psi_bilinear_matrix_columns(k_a) - do while (kcol < i) - k_a = k_a+1 - if (k_a > N_det) exit - 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) + + is_single_a = .False. + do k=1,singles_a(0,krow) + is_single_a( singles_a(k,krow) ) = .True. enddo - do while (kcol == i) + if (k_a > 1) then + if (kcol /= psi_bilinear_matrix_columns(k_a-1)) then + call get_all_spin_singles( & + psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& + singles, n_singles) + endif + else + call get_all_spin_singles( & + psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& + singles, n_singles) + endif - krow = psi_bilinear_matrix_rows(k_a) - tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow) + ! Loop over singly excited beta columns + ! ------------------------------------- - ! Loop over all alpha.beta pairs with a single exc alpha - ! ------------------------------------------------------ + do i=1,n_singles + lcol = singles(i) + ! TODO cycle if lcol <= kcol + tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) - l_a = k_a+1 - if (l_a > N_det) exit - lrow = psi_bilinear_matrix_rows(l_a) - lcol = psi_bilinear_matrix_columns(l_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + ! TODO loop - do while (lrow == krow) - - ! Loop over all alpha.beta pairs with a single exc alpha - ! ------------------------------------------------------ + do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) + lrow = psi_bilinear_matrix_rows(l_a) if (is_single_a(lrow)) then + tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) - tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int,lrow) - - ! Build list of singly excited beta - ! --------------------------------- + call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) + v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + endif + l_a += 1 - m_b = psi_bilinear_matrix_order_reverse(l_a) - m_b = m_b+1 - j=1 - do while ( (mrow == lrow) ) - mcol = psi_bilinear_matrix_transp_columns(m_b) - buffer(1:N_int,j) = psi_det_beta_unique(1:N_int,mcol) - idx(j) = mcol - j = j+1 - m_b = m_b+1 - if (m_b <= N_det) exit - mrow = psi_bilinear_matrix_transp_rows(m_b) - enddo - j=j-1 + enddo + enddo - call get_all_spin_singles( & - buffer, idx, tmp_det(1,2), N_int, j, & - doubles, n_doubles) + enddo - ! Compute Hij for all doubles - ! --------------------------- + !---- - m_b = psi_bilinear_matrix_order(l_a)+1 - mcol = psi_bilinear_matrix_transp_columns(m_b) - do j=1,n_doubles - tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, doubles(j) ) - call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) - do while (mcol /= doubles(j)) - m_b = m_b+1 - if (m_b > N_det) exit - mcol = psi_bilinear_matrix_transp_columns(m_b) - enddo - m_a = psi_bilinear_matrix_order_reverse(m_b) +! k_a=1 +! do i=1,N_det_beta_unique +! +! ! Select a beta determinant +! ! ------------------------- +! +! spindet(1:N_int) = psi_det_beta_unique(1:N_int, i) +! tmp_det(1:N_int,2) = spindet(1:N_int) +! +! call get_all_spin_singles( & +! psi_det_beta_unique, idx0, spindet, N_int, N_det_beta_unique, & +! singles, n_singles ) +! +! do j=1,n_singles +! is_single_a( singles(j) ) = .True. +! enddo +! +! ! For all alpha.beta pairs with the selected beta +! ! ----------------------------------------------- +! +! kcol = psi_bilinear_matrix_columns(k_a) +! do while (kcol < i) +! k_a = k_a+1 +! if (k_a > N_det) exit +! kcol = psi_bilinear_matrix_columns(k_a) +! enddo +! +! do while (kcol == i) +! +! krow = psi_bilinear_matrix_rows(k_a) +! tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow) +! +! ! Loop over all alpha.beta pairs with a single exc alpha +! ! ------------------------------------------------------ +! +! l_a = k_a+1 +! if (l_a > N_det) exit +! lrow = psi_bilinear_matrix_rows(l_a) +! lcol = psi_bilinear_matrix_columns(l_a) +! +! do while (lrow == krow) +! +! ! Loop over all alpha.beta pairs with a single exc alpha +! ! ------------------------------------------------------ +! if (is_single_a(lrow)) then +! +! tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int,lrow) +! +! ! Build list of singly excited beta +! ! --------------------------------- +! +! m_b = psi_bilinear_matrix_order_reverse(l_a) +! m_b = m_b+1 +! j=1 +! do while ( (mrow == lrow) ) +! mcol = psi_bilinear_matrix_transp_columns(m_b) +! buffer(1:N_int,j) = psi_det_beta_unique(1:N_int,mcol) +! idx(j) = mcol +! j = j+1 +! m_b = m_b+1 +! if (m_b <= N_det) exit +! mrow = psi_bilinear_matrix_transp_rows(m_b) +! enddo +! j=j-1 +! +! call get_all_spin_singles( & +! buffer, idx, tmp_det(1,2), N_int, j, & +! doubles, n_doubles) +! +! ! Compute Hij for all doubles +! ! --------------------------- +! +! m_b = psi_bilinear_matrix_order(l_a)+1 +! mcol = psi_bilinear_matrix_transp_columns(m_b) +! do j=1,n_doubles +! tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, doubles(j) ) +! call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) +! do while (mcol /= doubles(j)) +! m_b = m_b+1 +! if (m_b > N_det) exit +! mcol = psi_bilinear_matrix_transp_columns(m_b) +! enddo +! m_a = psi_bilinear_matrix_order_reverse(m_b) ! v_0(m_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) ! v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(m_a,1:N_st) - enddo - - endif - l_a = l_a+1 - if (l_a > N_det) exit - lrow = psi_bilinear_matrix_rows(l_a) - lcol = psi_bilinear_matrix_columns(l_a) - enddo - - k_b = k_b+1 - if (k_b > N_det) exit - kcol = psi_bilinear_matrix_transp_columns(k_b) - enddo - - do j=1,n_singles - is_single_a( singles(j) ) = .False. - enddo - - enddo +! enddo +! +! endif +! l_a = l_a+1 +! if (l_a > N_det) exit +! lrow = psi_bilinear_matrix_rows(l_a) +! lcol = psi_bilinear_matrix_columns(l_a) +! enddo +! +! k_b = k_b+1 +! if (k_b > N_det) exit +! kcol = psi_bilinear_matrix_transp_columns(k_b) +! enddo +! +! do j=1,n_singles +! is_single_a( singles(j) ) = .False. +! enddo +! +! enddo end @@ -946,7 +1027,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze integer :: degree integer :: exc(0:2,2,2) call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) - if ((degree == 2).and.(exc(0,1,1)==1)) cycle +! if ((degree == 2).and.(exc(0,1,1)==1)) cycle ! if ((degree > 1)) cycle ! if (exc(0,1,2) /= 0) cycle call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 56ad5617..1e0cb0a8 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2566,13 +2566,14 @@ subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij) double precision, intent(out) :: hij integer :: exc(0:2,2,2) - double precision :: phase + double precision :: phase, phase2 double precision, external :: get_mo_bielec_integral PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map call get_mono_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint) - call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase,Nint) + call get_mono_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint) + phase = phase*phase2 if (exc(1,1,1) == exc(1,2,2)) then hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) else if (exc(1,2,1) == exc(1,1,2)) then diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 4bb35979..783474f9 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -389,6 +389,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ] use bitmasks implicit none BEGIN_DOC @@ -428,6 +429,17 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) do l=1,N_states call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det) enddo + psi_bilinear_matrix_columns_loc(1:N_det_beta_unique) = -1 + psi_bilinear_matrix_columns_loc(1) = 1 + do k=2,N_det + if (psi_bilinear_matrix_columns(k) == psi_bilinear_matrix_columns(k-1)) then + cycle + else + l = psi_bilinear_matrix_columns(k) + psi_bilinear_matrix_columns_loc(l) = k + endif + enddo + psi_bilinear_matrix_columns_loc(N_det_beta_unique+1) = N_det+1 deallocate(to_sort) END_PROVIDER From 26c591c183289363fc7522a6d7f1e9cd8dfbf35a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 11:18:13 +0200 Subject: [PATCH 03/48] Fast davidson --- src/Davidson/u0Hu0.irp.f | 167 +++++++-------------------------------- 1 file changed, 30 insertions(+), 137 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index b7d47e08..421c31cd 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -659,6 +659,30 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) is_single_b(N_det_beta_unique), & idx(maxab), idx0(maxab)) + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + n_singles_max = 0 + do i=1,N_det_alpha_unique + spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& + singles, n_singles) + n_singles_max = max(n_singles_max, n_singles) + enddo + + allocate (singles_a(0:n_singles_max, N_det_alpha_unique)) + do i=1,N_det_alpha_unique + spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& + singles_a(1,i), singles_a(0,i)) + enddo + v_0 = 0.d0 do k_a=1,N_det @@ -807,35 +831,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Alpha/Beta double excitations ! ============================= - do i=1,maxab - idx0(i) = i - enddo - - ! Prepare the array of all alpha single excitations - ! ------------------------------------------------- - - n_singles_max = 0 - do i=1,N_det_alpha_unique - spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) - call get_all_spin_singles( & - psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& - singles, n_singles) - n_singles_max = max(n_singles_max, n_singles) - enddo - - allocate (singles_a(0:n_singles_max, N_det_alpha_unique)) - do i=1,N_det_alpha_unique - spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) - call get_all_spin_singles( & - psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& - singles_a(1,i), singles_a(0,i)) - enddo - do k_a=1,N_det - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - krow = psi_bilinear_matrix_rows(k_a) kcol = psi_bilinear_matrix_columns(k_a) @@ -864,11 +861,14 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) do i=1,n_singles lcol = singles(i) - ! TODO cycle if lcol <= kcol + if (lcol <= kcol) cycle + tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) l_a = psi_bilinear_matrix_columns_loc(lcol) - ! TODO loop + do while (l_a <= k_a) + l_a += 1 + enddo do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) lrow = psi_bilinear_matrix_rows(l_a) @@ -877,6 +877,7 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) endif l_a += 1 @@ -885,114 +886,6 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo - !---- - -! k_a=1 -! do i=1,N_det_beta_unique -! -! ! Select a beta determinant -! ! ------------------------- -! -! spindet(1:N_int) = psi_det_beta_unique(1:N_int, i) -! tmp_det(1:N_int,2) = spindet(1:N_int) -! -! call get_all_spin_singles( & -! psi_det_beta_unique, idx0, spindet, N_int, N_det_beta_unique, & -! singles, n_singles ) -! -! do j=1,n_singles -! is_single_a( singles(j) ) = .True. -! enddo -! -! ! For all alpha.beta pairs with the selected beta -! ! ----------------------------------------------- -! -! kcol = psi_bilinear_matrix_columns(k_a) -! do while (kcol < i) -! k_a = k_a+1 -! if (k_a > N_det) exit -! kcol = psi_bilinear_matrix_columns(k_a) -! enddo -! -! do while (kcol == i) -! -! krow = psi_bilinear_matrix_rows(k_a) -! tmp_det(1:N_int,1) = psi_det_alpha_unique(1:N_int,krow) -! -! ! Loop over all alpha.beta pairs with a single exc alpha -! ! ------------------------------------------------------ -! -! l_a = k_a+1 -! if (l_a > N_det) exit -! lrow = psi_bilinear_matrix_rows(l_a) -! lcol = psi_bilinear_matrix_columns(l_a) -! -! do while (lrow == krow) -! -! ! Loop over all alpha.beta pairs with a single exc alpha -! ! ------------------------------------------------------ -! if (is_single_a(lrow)) then -! -! tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int,lrow) -! -! ! Build list of singly excited beta -! ! --------------------------------- -! -! m_b = psi_bilinear_matrix_order_reverse(l_a) -! m_b = m_b+1 -! j=1 -! do while ( (mrow == lrow) ) -! mcol = psi_bilinear_matrix_transp_columns(m_b) -! buffer(1:N_int,j) = psi_det_beta_unique(1:N_int,mcol) -! idx(j) = mcol -! j = j+1 -! m_b = m_b+1 -! if (m_b <= N_det) exit -! mrow = psi_bilinear_matrix_transp_rows(m_b) -! enddo -! j=j-1 -! -! call get_all_spin_singles( & -! buffer, idx, tmp_det(1,2), N_int, j, & -! doubles, n_doubles) -! -! ! Compute Hij for all doubles -! ! --------------------------- -! -! m_b = psi_bilinear_matrix_order(l_a)+1 -! mcol = psi_bilinear_matrix_transp_columns(m_b) -! do j=1,n_doubles -! tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, doubles(j) ) -! call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) -! do while (mcol /= doubles(j)) -! m_b = m_b+1 -! if (m_b > N_det) exit -! mcol = psi_bilinear_matrix_transp_columns(m_b) -! enddo -! m_a = psi_bilinear_matrix_order_reverse(m_b) -! v_0(m_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) -! v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(m_a,1:N_st) -! enddo -! -! endif -! l_a = l_a+1 -! if (l_a > N_det) exit -! lrow = psi_bilinear_matrix_rows(l_a) -! lcol = psi_bilinear_matrix_columns(l_a) -! enddo -! -! k_b = k_b+1 -! if (k_b > N_det) exit -! kcol = psi_bilinear_matrix_transp_columns(k_b) -! enddo -! -! do j=1,n_singles -! is_single_a( singles(j) ) = .False. -! enddo -! -! enddo - - end From 2e65943c0b3eb0d49b6008d53c3df90def18823d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 12:04:21 +0200 Subject: [PATCH 04/48] Bug corrected in selection tasks --- plugins/CAS_SD_ZMQ/selection.irp.f | 3 +- plugins/Full_CI_ZMQ/zmq_selection.irp.f | 3 +- src/Davidson/u0Hu0.irp.f | 53 +++++++++++++++++-------- src/Determinants/s2.irp.f | 40 ++++++++++++++++--- src/Determinants/slater_rules.irp.f | 3 +- 5 files changed, 76 insertions(+), 26 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 5d2cda78..3692710d 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1241,8 +1241,7 @@ subroutine ZMQ_selection(N_in, pt2) do i= 1, N_det_generators k = k+1 write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N - k = k+20 - if (k>20*maxtasks) then + if (k>=maxtasks) then k=0 call add_task_to_taskserver(zmq_to_qp_run_socket,task) endif diff --git a/plugins/Full_CI_ZMQ/zmq_selection.irp.f b/plugins/Full_CI_ZMQ/zmq_selection.irp.f index 62703a43..7ffb4a44 100644 --- a/plugins/Full_CI_ZMQ/zmq_selection.irp.f +++ b/plugins/Full_CI_ZMQ/zmq_selection.irp.f @@ -32,8 +32,7 @@ subroutine ZMQ_selection(N_in, pt2) do i= 1, N_det_generators k = k+1 write(task(20*(k-1)+1:20*k),'(I9,1X,I9,''|'')') i, N - k = k+20 - if (k>20*maxtasks) then + if (k>=maxtasks) then k=0 call add_task_to_taskserver(zmq_to_qp_run_socket,task) endif diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 421c31cd..7231611a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -631,8 +631,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) PROVIDE ref_bitmask_energy - double precision :: hij, s2 - integer :: i,j,k + 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 @@ -684,6 +684,7 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo v_0 = 0.d0 + s_0 = 0.d0 do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation @@ -703,10 +704,14 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Diagonal contribution ! --------------------- - double precision, external :: diag_H_mat_elem + double precision, external :: diag_H_mat_elem, diag_S_mat_elem - v_0(k_a,1:N_st) = v_0(k_a,1:N_st) + diag_H_mat_elem(tmp_det,N_int) * & - psi_bilinear_matrix_values(k_a,1:N_st) + hij = diag_H_mat_elem(tmp_det,N_int) + sij = diag_S_mat_elem(tmp_det,N_int) + do l=1,N_st + v_0(k_a,l) = v_0(k_a,l) + hij * psi_bilinear_matrix_values(k_a,l) + s_0(k_a,l) = s_0(k_a,l) + sij * psi_bilinear_matrix_values(k_a,l) + enddo ! Get all single and double alpha excitations @@ -746,8 +751,11 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) - v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) - v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + do l=1,N_st + v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) + v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + ! single => sij = 0 + enddo enddo ! Compute Hij for all alpha doubles @@ -761,8 +769,11 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) lrow = psi_bilinear_matrix_rows(l_a) enddo call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) - v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) - v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + do l=1,N_st + v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) + v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + ! same spin => sij = 0 + enddo enddo @@ -805,8 +816,11 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) tmp_det2(1:N_int,2) = psi_det_beta_unique (1:N_int, lcol) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) - v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) - v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + do l=1,N_st + v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) + v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + ! single => sij = 0 + enddo enddo ! Compute Hij for all beta doubles @@ -821,8 +835,11 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) - v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) - v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) + do l=1,N_st + v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) + v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + ! same spin => sij = 0 + enddo enddo end do @@ -875,9 +892,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) if (is_single_a(lrow)) then 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) - v_0(k_a, 1:N_st) += hij * psi_bilinear_matrix_values(l_a,1:N_st) - v_0(l_a, 1:N_st) += hij * psi_bilinear_matrix_values(k_a,1:N_st) + call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij,sij) + do l=1,N_st + v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) + s_0(k_a, l) -= sij * psi_bilinear_matrix_values(l_a,l) + s_0(l_a, l) -= sij * psi_bilinear_matrix_values(k_a,l) + enddo endif l_a += 1 diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index a6e69fb5..0340361d 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -1,3 +1,35 @@ +double precision function diag_S_mat_elem(key_i,Nint) + implicit none + use bitmasks + include 'Utils/constants.include.F' + + integer :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2) + BEGIN_DOC +! Returns + END_DOC + integer :: nup, i + integer(bit_kind) :: xorvec(N_int_max) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + + do i=1,Nint + xorvec(i) = xor(key_i(i,1),key_i(i,2)) + enddo + + do i=1,Nint + xorvec(i) = iand(xorvec(i),key_i(i,1)) + enddo + + nup = 0 + do i=1,Nint + if (xorvec(i) /= 0_bit_kind) then + nup += popcnt(xorvec(i)) + endif + enddo + diag_S_mat_elem = dble(nup) + +end + subroutine get_s2(key_i,key_j,Nint,s2) implicit none use bitmasks @@ -25,11 +57,9 @@ subroutine get_s2(key_i,key_j,Nint,s2) endif endif case(0) - nup = 0 - do i=1,Nint - nup += popcnt(iand(xor(key_i(i,1),key_i(i,2)),key_i(i,1))) - enddo - s2 = dble(nup) + double precision, external :: diag_S_mat_elem + !DIR$ FORCEINLINE + s2 = diag_S_mat_elem(key_i,Nint) end select end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 1e0cb0a8..ef246e50 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -11,6 +11,7 @@ subroutine get_excitation_degree(key1,key2,degree,Nint) integer, intent(out) :: degree integer(bit_kind) :: xorvec(2*N_int_max) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec integer :: l ASSERT (Nint > 0) @@ -2555,7 +2556,7 @@ subroutine i_H_j_double_spin(key_i,key_j,Nint,hij) exc(1,2), mo_integrals_map) ) end -subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij) +subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij,phase) use bitmasks implicit none BEGIN_DOC From 3a824d5d0ab74c3d132c89942a3d045a051c1214 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 15:04:29 +0200 Subject: [PATCH 05/48] New Davidson OK --- src/Davidson/diagonalization_hs2.irp.f | 12 +-- src/Davidson/diagonalize_CI.irp.f | 1 - src/Davidson/u0Hu0.irp.f | 132 +++++++++++++++++------- src/Determinants/slater_rules.irp.f | 2 +- src/Determinants/spindeterminants.irp.f | 24 ++++- src/Utils/sort.irp.f | 36 ++++++- 6 files changed, 155 insertions(+), 52 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index bf56855a..71d69e82 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -25,7 +25,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) double precision, allocatable :: H_jj(:), S2_jj(:) - double precision :: diag_h_mat_elem + double precision :: diag_H_mat_elem, diag_S_mat_elem integer :: i ASSERT (N_st > 0) ASSERT (sze > 0) @@ -37,10 +37,10 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) + !$OMP DO SCHEDULE(static) do i=1,sze - H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) - call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) + H_jj(i) = diag_H_mat_elem(dets_in(1,1,i),Nint) + S2_jj(i) = diag_S_mat_elem(dets_in(1,1,i),Nint) enddo !$OMP END DO !$OMP END PARALLEL @@ -209,7 +209,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag call normalize(u_in(1,k),sze) enddo - + update_dets = 1 @@ -235,7 +235,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s if (distributed_davidson) then call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8,update_dets) else - call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) endif update_dets = 0 diff --git a/src/Davidson/diagonalize_CI.irp.f b/src/Davidson/diagonalize_CI.irp.f index e1b67438..9b98ea91 100644 --- a/src/Davidson/diagonalize_CI.irp.f +++ b/src/Davidson/diagonalize_CI.irp.f @@ -66,7 +66,6 @@ END_PROVIDER call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_eigenvectors_s2, & size(CI_eigenvectors,1),CI_electronic_energy, & N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,output_determinants) - else if (diag_algorithm == "Lapack") then diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 7231611a..e59f80c0 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -613,20 +613,37 @@ end -subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) +subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) use bitmasks implicit none BEGIN_DOC ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> ! - ! n : number of determinants - ! - ! H_jj : array of - ! - ! S2_jj : array of + ! Assumes that the determinants are in psi_det END_DOC integer, intent(in) :: N_st,sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(inout) :: v_0(sze_8,N_st), s_0(sze_8,N_st), u_0(sze_8,N_st) + integer :: k + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) + do k=1,N_st + call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + END_DOC + integer, intent(in) :: N_st,sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st), u_0(sze_8,N_st) PROVIDE ref_bitmask_energy @@ -643,7 +660,6 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) integer(bit_kind) :: tmp_det2(N_int,2) integer(bit_kind) :: tmp_det3(N_int,2) integer(bit_kind), allocatable :: buffer(:,:) - double precision :: ck(N_st), cl(N_st), cm(N_st) integer :: n_singles, n_doubles integer, allocatable :: singles(:), doubles(:) integer, allocatable :: singles_a(:,:), singles_b(:,:) @@ -651,18 +667,33 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) logical, allocatable :: is_single_a(:) logical, allocatable :: is_single_b(:) integer :: maxab, n_singles_max + double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) maxab = max(N_det_alpha_unique, N_det_beta_unique) allocate( buffer(N_int,maxab), & singles(maxab), doubles(maxab), & is_single_a(N_det_alpha_unique), & is_single_b(N_det_beta_unique), & - idx(maxab), idx0(maxab)) + idx(maxab), idx0(maxab), & + u_t(N_st,N_det), v_t(N_st,N_det), s_t(N_st,N_det) ) do i=1,maxab idx0(i) = i enddo +! call dtranspose( & +! u_0, & +! size(u_0, 1), & +! u_t, & +! size(u_t, 1), & +! N_det, N_st) +! + do k=1,N_det + do l=1,N_st + u_t(l,k) = u_0(k,l) + enddo + enddo + ! Prepare the array of all alpha single excitations ! ------------------------------------------------- @@ -683,8 +714,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) singles_a(1,i), singles_a(0,i)) enddo - v_0 = 0.d0 - s_0 = 0.d0 + v_t = 0.d0 + s_t = 0.d0 do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation @@ -699,21 +730,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Initial determinant is at k_b in beta-major representation ! ---------------------------------------------------------------------- - k_b = psi_bilinear_matrix_order_reverse(k_a) + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ! Diagonal contribution - ! --------------------- - - double precision, external :: diag_H_mat_elem, diag_S_mat_elem - - hij = diag_H_mat_elem(tmp_det,N_int) - sij = diag_S_mat_elem(tmp_det,N_int) - do l=1,N_st - v_0(k_a,l) = v_0(k_a,l) + hij * psi_bilinear_matrix_values(k_a,l) - s_0(k_a,l) = s_0(k_a,l) + sij * psi_bilinear_matrix_values(k_a,l) - enddo - - ! Get all single and double alpha excitations ! =========================================== @@ -721,7 +739,7 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Loop inside the beta column to gather all the connected alphas i=1 - l_a = k_a+1 + l_a = k_a lcol = psi_bilinear_matrix_columns(l_a) do while (lcol == kcol) lrow = psi_bilinear_matrix_rows(l_a) @@ -752,8 +770,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) do l=1,N_st - v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) - v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + v_t(l,l_a) += hij * u_t(l,k_a) + v_t(l,k_a) += hij * u_t(l,l_a) ! single => sij = 0 enddo enddo @@ -770,8 +788,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) do l=1,N_st - v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) - v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + v_t(l,l_a) += hij * u_t(l,k_a) + v_t(l,k_a) += hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo @@ -785,7 +803,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) ! Loop inside the alpha row to gather all the connected betas i=1 - l_b = k_b+1 + l_b = k_b + lrow = psi_bilinear_matrix_transp_rows(l_b) do while (lrow == krow) lcol = psi_bilinear_matrix_transp_columns(l_b) @@ -817,8 +836,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) do l=1,N_st - v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) - v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + v_t(l,l_a) += hij * u_t(l,k_a) + v_t(l,k_a) += hij * u_t(l,l_a) ! single => sij = 0 enddo enddo @@ -836,8 +855,8 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) do l=1,N_st - v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) - v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) + v_t(l,l_a) += hij * u_t(l,k_a) + v_t(l,k_a) += hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo @@ -892,12 +911,13 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) if (is_single_a(lrow)) then 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,sij) + call i_H_j_double_alpha_beta(tmp_det,tmp_det2,N_int,hij) + call get_s2(tmp_det,tmp_det2,N_int,sij) do l=1,N_st - v_0(k_a, l) += hij * psi_bilinear_matrix_values(l_a,l) - v_0(l_a, l) += hij * psi_bilinear_matrix_values(k_a,l) - s_0(k_a, l) -= sij * psi_bilinear_matrix_values(l_a,l) - s_0(l_a, l) -= sij * psi_bilinear_matrix_values(k_a,l) + v_t(l,k_a) += hij * u_t(l,l_a) + v_t(l,l_a) += hij * u_t(l,k_a) + s_t(l,k_a) += sij * u_t(l,l_a) + s_t(l,l_a) += sij * u_t(l,k_a) enddo endif l_a += 1 @@ -905,6 +925,38 @@ subroutine H_S2_u_0_nstates_new(v_0,s_0,N_st,sze_8) enddo enddo + ! Diagonal contribution + ! --------------------- + + double precision, external :: diag_H_mat_elem, diag_S_mat_elem + + hij = diag_H_mat_elem(tmp_det,N_int) + sij = diag_S_mat_elem(tmp_det,N_int) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) + enddo + + enddo + +! call dtranspose( & +! v_t, & +! size(v_t, 1), & +! v_0, & +! size(v_0, 1), & +! N_st, N_det) +! +! call dtranspose( & +! s_t, & +! size(s_t, 1), & +! s_0, & +! size(s_0, 1), & +! N_st, N_det) + do k=1,N_det + do l=1,N_st + v_0(k,l) = v_t(l,k) + s_0(k,l) = s_t(l,k) + enddo enddo end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index ef246e50..496b59de 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2556,7 +2556,7 @@ subroutine i_H_j_double_spin(key_i,key_j,Nint,hij) exc(1,2), mo_integrals_map) ) end -subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij,phase) +subroutine i_H_j_double_alpha_beta(key_i,key_j,Nint,hij) use bitmasks implicit none BEGIN_DOC diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 783474f9..31fd3915 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -389,6 +389,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ] use bitmasks implicit none @@ -429,7 +430,6 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) do l=1,N_states call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det) enddo - psi_bilinear_matrix_columns_loc(1:N_det_beta_unique) = -1 psi_bilinear_matrix_columns_loc(1) = 1 do k=2,N_det if (psi_bilinear_matrix_columns(k) == psi_bilinear_matrix_columns(k-1)) then @@ -440,6 +440,9 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) endif enddo psi_bilinear_matrix_columns_loc(N_det_beta_unique+1) = N_det+1 + do k=1,N_det + psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_order(k)) = k + enddo deallocate(to_sort) END_PROVIDER @@ -448,7 +451,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_order , (N_det) ] -&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] +&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] use bitmasks implicit none BEGIN_DOC @@ -487,7 +490,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det) enddo do k=1,N_det - psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_transp_order(k)) = k + psi_bilinear_matrix_order_transp_reverse(psi_bilinear_matrix_transp_order(k)) = k enddo deallocate(to_sort) END_PROVIDER @@ -1387,3 +1390,18 @@ subroutine get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_ end +subroutine copy_psi_bilinear_to_psi(psi, isize) + implicit none + BEGIN_DOC +! Overwrites psi_det and psi_coef with the wf in bilinear order + END_DOC + integer, intent(in) :: isize + integer(bit_kind), intent(out) :: psi(N_int,2,isize) + integer :: i,j,k,l + do k=1,isize + i = psi_bilinear_matrix_rows(k) + j = psi_bilinear_matrix_columns(k) + psi(1:N_int,1,k) = psi_det_alpha_unique(1:N_int,i) + psi(1:N_int,2,k) = psi_det_beta_unique(1:N_int,j) + enddo +end diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index dc91ab3a..04e71208 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -158,6 +158,34 @@ BEGIN_TEMPLATE end subroutine heap_$Xsort_big + subroutine sorted_$Xnumber(x,isize,n) + implicit none + BEGIN_DOC +! Returns the number of sorted elements + END_DOC + integer, intent(in) :: isize + $type, intent(inout) :: x(isize) + integer, intent(out) :: n + integer :: i + if (isize < 2) then + n = 1 + return + endif + + if (x(1) > x(2)) then + n=1 + else + n=0 + endif + + do i=2,isize + if (x(i-1) > x(i)) then + n=n+1 + endif + enddo + + end + subroutine $Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -168,10 +196,16 @@ BEGIN_TEMPLATE integer,intent(in) :: isize $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) + integer :: n if (isize < 32) then call insertion_$Xsort(x,iorder,isize) else - call heap_$Xsort(x,iorder,isize) +! call sorted_$Xnumber(x,isize,n) +! if ( (16*n) / isize > 0) then +! call insertion_$Xsort(x,iorder,isize) +! else + call heap_$Xsort(x,iorder,isize) +! endif endif end subroutine $Xsort From 23685ab5d073f3a8eae0fd5ad58f4d14424765db Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 15:41:35 +0200 Subject: [PATCH 06/48] New Davidson OK --- src/Davidson/u0Hu0.irp.f | 110 ++++++++++++++++++++------------------- 1 file changed, 57 insertions(+), 53 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index e59f80c0..f168f371 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -668,6 +668,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) logical, allocatable :: is_single_b(:) integer :: maxab, n_singles_max double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t maxab = max(N_det_alpha_unique, N_det_beta_unique) allocate( buffer(N_int,maxab), & @@ -681,18 +682,12 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) idx0(i) = i enddo -! call dtranspose( & -! u_0, & -! size(u_0, 1), & -! u_t, & -! size(u_t, 1), & -! N_det, N_st) -! - do k=1,N_det - do l=1,N_st - u_t(l,k) = u_0(k,l) - enddo - enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) ! Prepare the array of all alpha single excitations ! ------------------------------------------------- @@ -770,8 +765,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) do l=1,N_st - v_t(l,l_a) += hij * u_t(l,k_a) - v_t(l,k_a) += hij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo enddo @@ -788,8 +783,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) do l=1,N_st - v_t(l,l_a) += hij * u_t(l,k_a) - v_t(l,k_a) += hij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo @@ -836,8 +831,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) do l=1,N_st - v_t(l,l_a) += hij * u_t(l,k_a) - v_t(l,k_a) += hij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo enddo @@ -855,8 +850,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) do l=1,N_st - v_t(l,l_a) += hij * u_t(l,k_a) - v_t(l,k_a) += hij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo @@ -867,15 +862,20 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! Alpha/Beta double excitations ! ============================= + is_single_a = .False. + krow = 1 do k_a=1,N_det + do k=1,singles_a(0,krow) + is_single_a( singles_a(k,krow) ) = .False. + enddo + 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) - is_single_a = .False. do k=1,singles_a(0,krow) is_single_a( singles_a(k,krow) ) = .True. enddo @@ -906,23 +906,33 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a += 1 enddo + n_doubles=0 do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) lrow = psi_bilinear_matrix_rows(l_a) - if (is_single_a(lrow)) then - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) - do l=1,N_st - v_t(l,k_a) += hij * u_t(l,l_a) - v_t(l,l_a) += hij * u_t(l,k_a) - s_t(l,k_a) += sij * u_t(l,l_a) - s_t(l,l_a) += sij * u_t(l,k_a) - enddo + if (.not.is_single_a(lrow)) then + continue + else + n_doubles = n_doubles+1 + doubles(n_doubles) = lrow + idx(n_doubles) = l_a endif - l_a += 1 - + l_a = l_a+1 enddo + + do k=1,n_doubles + lrow = doubles(k) + l_a = idx(k) + 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) + call get_s2(tmp_det,tmp_det2,N_int,sij) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo + enddo + enddo ! Diagonal contribution @@ -939,25 +949,19 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo -! call dtranspose( & -! v_t, & -! size(v_t, 1), & -! v_0, & -! size(v_0, 1), & -! N_st, N_det) -! -! call dtranspose( & -! s_t, & -! size(s_t, 1), & -! s_0, & -! size(s_0, 1), & -! N_st, N_det) - do k=1,N_det - do l=1,N_st - v_0(k,l) = v_t(l,k) - s_0(k,l) = s_t(l,k) - enddo - enddo + call dtranspose( & + v_t, & + size(v_t, 1), & + v_0, & + size(v_0, 1), & + N_st, N_det) + + call dtranspose( & + s_t, & + size(s_t, 1), & + s_0, & + size(s_0, 1), & + N_st, N_det) end From 923eec3c25c48abcd5002a774e244e7648ab3706 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 16:40:12 +0200 Subject: [PATCH 07/48] OpenMP davidson --- src/Davidson/u0Hu0.irp.f | 247 +++++++++++++----------- src/Determinants/spindeterminants.irp.f | 35 ++++ 2 files changed, 167 insertions(+), 115 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index f168f371..376b6e14 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -662,20 +662,15 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) integer(bit_kind), allocatable :: buffer(:,:) integer :: n_singles, n_doubles integer, allocatable :: singles(:), doubles(:) - integer, allocatable :: singles_a(:,:), singles_b(:,:) + integer, allocatable :: singles_b(:,:) integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) - logical, allocatable :: is_single_b(:) - integer :: maxab, n_singles_max + integer :: maxab, n_singles_max, kcol_prev double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t maxab = max(N_det_alpha_unique, N_det_beta_unique) - allocate( buffer(N_int,maxab), & - singles(maxab), doubles(maxab), & - is_single_a(N_det_alpha_unique), & - is_single_b(N_det_beta_unique), & - idx(maxab), idx0(maxab), & + allocate(idx0(maxab), & u_t(N_st,N_det), v_t(N_st,N_det), s_t(N_st,N_det) ) do i=1,maxab @@ -692,25 +687,127 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! Prepare the array of all alpha single excitations ! ------------------------------------------------- - n_singles_max = 0 - do i=1,N_det_alpha_unique - spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) - call get_all_spin_singles( & - psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& - singles, n_singles) - n_singles_max = max(n_singles_max, n_singles) - enddo - - allocate (singles_a(0:n_singles_max, N_det_alpha_unique)) - do i=1,N_det_alpha_unique - spindet(1:N_int) = psi_det_alpha_unique(1:N_int, i) - call get_all_spin_singles( & - psi_det_alpha_unique, idx0, spindet, N_int, N_det_alpha_unique,& - singles_a(1,i), singles_a(0,i)) - enddo - v_t = 0.d0 s_t = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$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 singles_alpha, psi_bilinear_matrix_columns_loc, & + !$OMP idx0, u_t, v_t, s_t, maxab) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & + !$OMP lcol, lrow, is_single_a,l_a, l_b, & + !$OMP buffer, singles, doubles, n_singles, n_doubles, & + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer(N_int,maxab), & + singles(maxab), doubles(maxab), & + idx(maxab), & +! v_t(N_st,N_det), s_t(N_st,N_det), & + is_single_a(N_det_alpha_unique)) + is_single_a = .False. + kcol_prev=-1 + krow=1 + + !$OMP DO SCHEDULE(static,1) + do k_a=1,N_det + + do k=1,singles_alpha(0,krow) + is_single_a( singles_alpha(k,krow) ) = .False. + enddo + + 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) + + do k=1,singles_alpha(0,krow) + is_single_a( singles_alpha(k,krow) ) = .True. + enddo + + if (kcol /= kcol_prev) then + call get_all_spin_singles( & + psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& + singles, n_singles) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles + lcol = singles(i) + if (lcol <= kcol) cycle + + tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + do while (l_a <= k_a) + l_a += 1 + enddo + + n_doubles=1 + do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) + lrow = psi_bilinear_matrix_rows(l_a) + if (.not.is_single_a(lrow)) then + continue + else + doubles(n_doubles) = lrow + idx(n_doubles) = l_a + n_doubles = n_doubles+1 + endif + l_a = l_a+1 + enddo + n_doubles = n_doubles-1 + + do k=1,n_doubles + lrow = doubles(k) + l_a = idx(k) + 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) + call get_s2(tmp_det,tmp_det2,N_int,sij) + do l=1,N_st + !$OMP ATOMIC + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + !$OMP ATOMIC + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + !$OMP ATOMIC + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo + enddo + + enddo + + ! Diagonal contribution + ! --------------------- + + double precision, external :: diag_H_mat_elem, diag_S_mat_elem + + hij = diag_H_mat_elem(tmp_det,N_int) + sij = diag_S_mat_elem(tmp_det,N_int) + do l=1,N_st + !$OMP ATOMIC + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) + !$OMP ATOMIC + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) + enddo + + enddo + !$OMP END DO NOWAIT + + !$OMP DO SCHEDULE(static,1) do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation @@ -765,7 +862,9 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo @@ -783,7 +882,9 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo @@ -831,7 +932,9 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo @@ -850,104 +953,18 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo end do + !$OMP END DO - - ! Alpha/Beta double excitations - ! ============================= - - is_single_a = .False. - krow = 1 - do k_a=1,N_det - - do k=1,singles_a(0,krow) - is_single_a( singles_a(k,krow) ) = .False. - enddo - - 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) - - do k=1,singles_a(0,krow) - is_single_a( singles_a(k,krow) ) = .True. - enddo - - if (k_a > 1) then - if (kcol /= psi_bilinear_matrix_columns(k_a-1)) then - call get_all_spin_singles( & - psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& - singles, n_singles) - endif - else - call get_all_spin_singles( & - psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& - singles, n_singles) - endif - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles - lcol = singles(i) - if (lcol <= kcol) cycle - - tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - do while (l_a <= k_a) - l_a += 1 - enddo - - n_doubles=0 - do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) - lrow = psi_bilinear_matrix_rows(l_a) - if (.not.is_single_a(lrow)) then - continue - else - n_doubles = n_doubles+1 - doubles(n_doubles) = lrow - idx(n_doubles) = l_a - endif - l_a = l_a+1 - enddo - - do k=1,n_doubles - lrow = doubles(k) - l_a = idx(k) - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) - do l=1,N_st - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) - s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) - enddo - enddo - - enddo - - ! Diagonal contribution - ! --------------------- - - double precision, external :: diag_H_mat_elem, diag_S_mat_elem - - hij = diag_H_mat_elem(tmp_det,N_int) - sij = diag_S_mat_elem(tmp_det,N_int) - do l=1,N_st - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) - enddo - - enddo + !$OMP END PARALLEL call dtranspose( & v_t, & diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 31fd3915..43ea36aa 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -1405,3 +1405,38 @@ subroutine copy_psi_bilinear_to_psi(psi, isize) psi(1:N_int,2,k) = psi_det_beta_unique(1:N_int,j) enddo end + +BEGIN_PROVIDER [ integer, singles_alpha_size ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + singles_alpha_size = elec_alpha_num * (mo_tot_num - elec_alpha_num) +END_PROVIDER + +BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_unique) ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + integer :: i + integer, allocatable :: idx0(:) + allocate (idx0(N_det_alpha_unique)) + do i=1, N_det_alpha_unique + idx0(i) = i + enddo + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(singles_alpha, N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int) & + !$OMP PRIVATE(i) + do i=1, N_det_alpha_unique + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & + N_det_alpha_unique, singles_alpha(1,i), singles_alpha(0,i)) + enddo + !$OMP END PARALLEL DO + + deallocate(idx0) +END_PROVIDER + From 7a09448f62bd66d2d546741a759bbdfb8bcc6b45 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 18:11:02 +0200 Subject: [PATCH 08/48] OpenMP davidson --- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 5 +- src/Davidson/u0Hu0.irp.f | 125 ++++++++++++--------- src/Determinants/spindeterminants.irp.f | 2 +- src/Utils/sort.irp.f | 17 ++- 4 files changed, 84 insertions(+), 65 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 8a47cb9d..84992449 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -56,7 +56,10 @@ subroutine sort_selection_buffer(b) iorder(i) = i end do ! Optimal for almost sorted data - call insertion_dsort(absval, iorder, b%cur) +! call sorted_dnumber(absval, b%cur, i) +! if (b%cur/i > +! call insertion_dsort(absval, iorder, b%cur) + call dsort(absval, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 376b6e14..094ce412 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -669,9 +669,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t - maxab = max(N_det_alpha_unique, N_det_beta_unique) - allocate(idx0(maxab), & - u_t(N_st,N_det), v_t(N_st,N_det), s_t(N_st,N_det) ) + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab), u_t(N_st,N_det) ) do i=1,maxab idx0(i) = i @@ -684,12 +683,12 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) size(u_t, 1), & N_det, N_st) + v_0 = 0.d0 + s_0 = 0.d0 + ! Prepare the array of all alpha single excitations ! ------------------------------------------------- - v_t = 0.d0 - s_t = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & !$OMP psi_bilinear_matrix_columns, & @@ -700,24 +699,30 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & !$OMP singles_alpha, psi_bilinear_matrix_columns_loc, & - !$OMP idx0, u_t, v_t, s_t, maxab) & + !$OMP singles_alpha_size, sze_8, & + !$OMP idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, is_single_a,l_a, l_b, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & - !$OMP tmp_det2, hij, sij, idx, l, kcol_prev) + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, s_t) ! Alpha/Beta double excitations ! ============================= allocate( buffer(N_int,maxab), & - singles(maxab), doubles(maxab), & - idx(maxab), & -! v_t(N_st,N_det), s_t(N_st,N_det), & + singles(singles_alpha_size), & + doubles(maxab), & + idx(maxab), & + v_t(N_st,N_det), s_t(N_st,N_det), & is_single_a(N_det_alpha_unique)) is_single_a = .False. kcol_prev=-1 krow=1 + v_t = 0.d0 + s_t = 0.d0 + + !$OMP DO SCHEDULE(static,1) do k_a=1,N_det @@ -764,29 +769,58 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) else doubles(n_doubles) = lrow idx(n_doubles) = l_a + if (n_doubles == maxab) then + + do k=1,n_doubles + lrow = doubles(k) + l_a = idx(k) + 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) + call get_s2(tmp_det,tmp_det2,N_int,sij) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo + enddo + + n_doubles=0 + endif n_doubles = n_doubles+1 endif l_a = l_a+1 enddo n_doubles = n_doubles-1 - do k=1,n_doubles - lrow = doubles(k) - l_a = idx(k) - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) - do l=1,N_st - !$OMP ATOMIC - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - !$OMP ATOMIC - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) - !$OMP ATOMIC - v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC - s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) - enddo - enddo + if (n_doubles > 0) then + do k=1,n_doubles + lrow = doubles(k) + l_a = idx(k) + 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) + call get_s2(tmp_det,tmp_det2,N_int,sij) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo + enddo + endif +! do k=1,n_doubles +! lrow = doubles(k) +! l_a = idx(k) +! 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) +! call get_s2(tmp_det,tmp_det2,N_int,sij) +! do l=1,N_st +! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) +! s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) +! v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) +! s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) +! enddo +! enddo enddo @@ -798,9 +832,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) hij = diag_H_mat_elem(tmp_det,N_int) sij = diag_S_mat_elem(tmp_det,N_int) do l=1,N_st - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) - !$OMP ATOMIC s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) enddo @@ -862,9 +894,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo @@ -882,9 +912,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo @@ -932,9 +960,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 enddo @@ -953,33 +979,26 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo end do - !$OMP END DO + !$OMP END DO NOWAIT + + !$OMP CRITICAL + do l=1,N_st + do i=1, N_det + v_0(i,l) = v_0(i,l) + v_t(l,i) + s_0(i,l) = s_0(i,l) + s_t(l,i) + enddo + enddo + !$OMP END CRITICAL !$OMP END PARALLEL - call dtranspose( & - v_t, & - size(v_t, 1), & - v_0, & - size(v_0, 1), & - N_st, N_det) - - call dtranspose( & - s_t, & - size(s_t, 1), & - s_0, & - size(s_0, 1), & - N_st, N_det) - end diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 43ea36aa..a28649a7 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -771,7 +771,7 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles endif enddo n_singles = n_singles-1 - deallocate(xorvec) + deallocate(xorvec, degree) end diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index 04e71208..51dee121 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -164,7 +164,7 @@ BEGIN_TEMPLATE ! Returns the number of sorted elements END_DOC integer, intent(in) :: isize - $type, intent(inout) :: x(isize) + $type, intent(in) :: x(isize) integer, intent(out) :: n integer :: i if (isize < 2) then @@ -172,14 +172,14 @@ BEGIN_TEMPLATE return endif - if (x(1) > x(2)) then + if (x(1) >= x(2)) then n=1 else n=0 endif do i=2,isize - if (x(i-1) > x(i)) then + if (x(i-1) >= x(i)) then n=n+1 endif enddo @@ -197,15 +197,12 @@ BEGIN_TEMPLATE $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) integer :: n - if (isize < 32) then + call sorted_$Xnumber(x,isize,n) + print *, isize, n, isize-n + if ( isize-n < 1000) then call insertion_$Xsort(x,iorder,isize) else -! call sorted_$Xnumber(x,isize,n) -! if ( (16*n) / isize > 0) then -! call insertion_$Xsort(x,iorder,isize) -! else - call heap_$Xsort(x,iorder,isize) -! endif + call heap_$Xsort(x,iorder,isize) endif end subroutine $Xsort From bddd875af76392e85875fa325b4a09ea4cad5292 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 14 Apr 2017 18:16:31 +0200 Subject: [PATCH 09/48] OpenMP davidson --- src/Davidson/u0Hu0.irp.f | 14 +------------- src/Utils/sort.irp.f | 1 - 2 files changed, 1 insertion(+), 14 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 094ce412..06a8becd 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -808,19 +808,6 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo enddo endif -! do k=1,n_doubles -! lrow = doubles(k) -! l_a = idx(k) -! 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) -! call get_s2(tmp_det,tmp_det2,N_int,sij) -! do l=1,N_st -! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) -! s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) -! v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) -! s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) -! enddo -! enddo enddo @@ -997,6 +984,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo !$OMP END CRITICAL + !$OMP BARRIER !$OMP END PARALLEL end diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index 51dee121..fa3ca382 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -198,7 +198,6 @@ BEGIN_TEMPLATE integer,intent(inout) :: iorder(isize) integer :: n call sorted_$Xnumber(x,isize,n) - print *, isize, n, isize-n if ( isize-n < 1000) then call insertion_$Xsort(x,iorder,isize) else From fd6af192b26216a212bb63213497f1dd8629d086 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 15 Apr 2017 01:06:09 +0200 Subject: [PATCH 10/48] Davidson OK --- src/Davidson/u0Hu0.irp.f | 114 +++++++++++------------- src/Determinants/slater_rules.irp.f | 2 +- src/Determinants/spindeterminants.irp.f | 16 ++-- 3 files changed, 60 insertions(+), 72 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 06a8becd..50546a33 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -710,7 +710,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! ============================= allocate( buffer(N_int,maxab), & - singles(singles_alpha_size), & + singles(maxab), & doubles(maxab), & idx(maxab), & v_t(N_st,N_det), s_t(N_st,N_det), & @@ -725,7 +725,6 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) !$OMP DO SCHEDULE(static,1) do k_a=1,N_det - do k=1,singles_alpha(0,krow) is_single_a( singles_alpha(k,krow) ) = .False. enddo @@ -793,36 +792,22 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo n_doubles = n_doubles-1 - if (n_doubles > 0) then - do k=1,n_doubles - lrow = doubles(k) - l_a = idx(k) - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) - do l=1,N_st - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) - v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) - enddo - enddo - endif + do k=1,n_doubles + lrow = doubles(k) + l_a = idx(k) + 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) + call get_s2(tmp_det,tmp_det2,N_int,sij) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) + enddo + enddo enddo - ! Diagonal contribution - ! --------------------- - - double precision, external :: diag_H_mat_elem, diag_S_mat_elem - - hij = diag_H_mat_elem(tmp_det,N_int) - sij = diag_S_mat_elem(tmp_det,N_int) - do l=1,N_st - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) - enddo - enddo !$OMP END DO NOWAIT @@ -855,7 +840,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) do while (lcol == kcol) lrow = psi_bilinear_matrix_rows(l_a) buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow) - idx(i) = lrow + idx(i) = l_a i = i +1 l_a = l_a+1 if (l_a > N_det) exit @@ -867,17 +852,14 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) buffer, idx, spindet, N_int, i, & singles, doubles, n_singles, n_doubles ) + ! Compute Hij for all alpha singles ! ---------------------------------- - l_a = k_a - lrow = psi_bilinear_matrix_rows(l_a) tmp_det2(1:N_int,2) = psi_det_beta_unique (1:N_int, kcol) do i=1,n_singles - do while ( lrow < singles(i) ) - l_a = l_a+1 - lrow = psi_bilinear_matrix_rows(l_a) - enddo + l_a = singles(i) + lrow = psi_bilinear_matrix_rows(l_a) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) do l=1,N_st @@ -886,22 +868,19 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! single => sij = 0 enddo enddo + ! Compute Hij for all alpha doubles ! ---------------------------------- - l_a = k_a - lrow = psi_bilinear_matrix_rows(l_a) do i=1,n_doubles - do while (lrow < doubles(i)) - l_a = l_a+1 - lrow = psi_bilinear_matrix_rows(l_a) - enddo - call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, doubles(i)), N_int, hij) + l_a = doubles(i) + lrow = psi_bilinear_matrix_rows(l_a) + call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), N_int, hij) do l=1,N_st v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - ! same spin => sij = 0 + ! same spin => sij = 0 enddo enddo @@ -920,14 +899,14 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) do while (lrow == krow) lcol = psi_bilinear_matrix_transp_columns(l_b) buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol) - idx(i) = lcol + idx(i) = l_b i = i +1 l_b = l_b+1 if (l_b > N_det) exit lrow = psi_bilinear_matrix_transp_rows(l_b) enddo i = i-1 - + call get_all_spin_singles_and_doubles( & buffer, idx, spindet, N_int, i, & singles, doubles, n_singles, n_doubles ) @@ -935,17 +914,13 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! Compute Hij for all beta singles ! ---------------------------------- - l_b = k_b - lcol = psi_bilinear_matrix_transp_columns(l_b) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, krow) do i=1,n_singles - do while ( lcol < singles(i) ) - l_b = l_b+1 - lcol = psi_bilinear_matrix_transp_columns(l_b) - enddo + l_b = singles(i) + lcol = psi_bilinear_matrix_transp_columns(l_b) tmp_det2(1:N_int,2) = psi_det_beta_unique (1:N_int, lcol) - l_a = psi_bilinear_matrix_transp_order(l_b) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) + l_a = psi_bilinear_matrix_transp_order(l_b) do l=1,N_st v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) @@ -956,24 +931,32 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! Compute Hij for all beta doubles ! ---------------------------------- - l_b = k_b - lcol = psi_bilinear_matrix_transp_columns(l_b) do i=1,n_doubles - do while (lcol < doubles(i)) - l_b = l_b+1 - lcol = psi_bilinear_matrix_transp_columns(l_b) - enddo + l_b = doubles(i) + lcol = psi_bilinear_matrix_transp_columns(l_b) + call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), N_int, hij) l_a = psi_bilinear_matrix_transp_order(l_b) - call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, doubles(i)), N_int, hij) do l=1,N_st v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 enddo enddo - + + ! Diagonal contribution + ! --------------------- + + double precision, external :: diag_H_mat_elem, diag_S_mat_elem + + hij = diag_H_mat_elem(tmp_det,N_int) + sij = diag_S_mat_elem(tmp_det,N_int) + do l=1,N_st + v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) + enddo + end do - !$OMP END DO NOWAIT + !$OMP END DO !$OMP CRITICAL do l=1,N_st @@ -1021,7 +1004,12 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze integer :: degree integer :: exc(0:2,2,2) call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) -! if ((degree == 2).and.(exc(0,1,1)==1)) cycle +! if ((degree == 2).and.(exc(0,1,1)==1)) then +! continue +! else +! cycle +! endif +! if ((degree == 2).and.(exc(0,1,1)==1)) cycle ! if ((degree > 1)) cycle ! if (exc(0,1,2) /= 0) cycle call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 496b59de..4d5b1bd3 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2524,7 +2524,7 @@ subroutine i_H_j_mono_spin(key_i,key_j,Nint,spin,hij) PROVIDE big_array_exchange_integrals mo_bielec_integrals_in_map call get_mono_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint) - call get_mono_excitation_from_fock(key_i,key_j,exc(1,2),exc(1,1),spin,phase,hij) + call get_mono_excitation_from_fock(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij) end subroutine i_H_j_double_spin(key_i,key_j,Nint,hij) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index a28649a7..afd34d13 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -641,17 +641,17 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - select case (Nint) - case (1) - call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) - return +! select case (Nint) +! case (1) +! call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) +! return ! case (2) ! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) ! return - case (3) - call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - return - end select +! case (3) +! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) +! return +! end select size_buffer_align = align_double(size_buffer) From 9d3d843bc7f50f74a0ca479061a9c1cc7180b293 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 16 Apr 2017 01:28:35 +0200 Subject: [PATCH 11/48] Debugged Davidson for large Ndet --- src/Davidson/u0Hu0.irp.f | 102 ++++++++++++++------- src/Determinants/spindeterminants.irp.f | 114 +++++++++++++++++------- 2 files changed, 152 insertions(+), 64 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 50546a33..30ff0fa8 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -665,7 +665,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) integer, allocatable :: singles_b(:,:) integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) - integer :: maxab, n_singles_max, kcol_prev + integer :: maxab, n_singles_max, kcol_prev, nmax double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t @@ -702,7 +702,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) !$OMP singles_alpha_size, sze_8, & !$OMP idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & - !$OMP lcol, lrow, is_single_a,l_a, l_b, & + !$OMP lcol, lrow, is_single_a,l_a, l_b, nmax, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, s_t) @@ -756,11 +756,12 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) l_a = psi_bilinear_matrix_columns_loc(lcol) - do while (l_a <= k_a) - l_a += 1 - enddo n_doubles=1 + + ! Loop over alpha singles + ! ----------------------- + do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) lrow = psi_bilinear_matrix_rows(l_a) if (.not.is_single_a(lrow)) then @@ -778,8 +779,8 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) call get_s2(tmp_det,tmp_det2,N_int,sij) do l=1,N_st v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) enddo enddo @@ -811,6 +812,10 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo !$OMP END DO NOWAIT + + ! Single and double alpha excitations + ! =================================== + !$OMP DO SCHEDULE(static,1) do k_a=1,N_det @@ -828,23 +833,18 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ! Get all single and double alpha excitations - ! =========================================== - spindet(1:N_int) = tmp_det(1:N_int,1) ! Loop inside the beta column to gather all the connected alphas - i=1 - l_a = k_a - lcol = psi_bilinear_matrix_columns(l_a) - do while (lcol == kcol) + l_a = k_a+1 + nmax = min(N_det_alpha_unique, N_det - l_a) + do i=1,nmax + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit lrow = psi_bilinear_matrix_rows(l_a) buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow) idx(i) = l_a - i = i +1 l_a = l_a+1 - if (l_a > N_det) exit - lcol = psi_bilinear_matrix_columns(l_a) enddo i = i-1 @@ -852,7 +852,6 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) buffer, idx, spindet, N_int, i, & singles, doubles, n_singles, n_doubles ) - ! Compute Hij for all alpha singles ! ---------------------------------- @@ -884,26 +883,38 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo enddo + end do + !$OMP END DO NOWAIT + + + ! Single and double beta excitations + ! ================================== + + !$OMP DO SCHEDULE(static,1) + do k_b=1,N_det + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + krow = psi_bilinear_matrix_transp_rows(k_b) + kcol = psi_bilinear_matrix_transp_columns(k_b) - ! Get all single and double beta excitations - ! =========================================== + 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) + k_a = psi_bilinear_matrix_transp_order(k_b) ! Loop inside the alpha row to gather all the connected betas - i=1 - l_b = k_b - - lrow = psi_bilinear_matrix_transp_rows(l_b) - do while (lrow == krow) + l_b = k_b+1 + nmax = min(N_det_beta_unique, N_det - l_b) + do i=1,nmax + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit lcol = psi_bilinear_matrix_transp_columns(l_b) buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol) idx(i) = l_b - i = i +1 l_b = l_b+1 - if (l_b > N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l_b) enddo i = i-1 @@ -943,9 +954,25 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo enddo - ! Diagonal contribution - ! --------------------- + end do + !$OMP END DO NOWAIT + + ! Diagonal contribution + ! ===================== + + !$OMP DO SCHEDULE(static,1) + do k_a=1,N_det + + ! 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) + double precision, external :: diag_H_mat_elem, diag_S_mat_elem hij = diag_H_mat_elem(tmp_det,N_int) @@ -956,7 +983,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo end do - !$OMP END DO + !$OMP END DO NOWAIT !$OMP CRITICAL do l=1,N_st @@ -986,7 +1013,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze double precision, allocatable :: vt(:,:) integer, allocatable :: idx(:) - integer :: i,j, jj + integer :: i,j, jj, l double precision :: hij do i=1,n @@ -995,6 +1022,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze allocate(idx(0:n), vt(N_st,n)) Vt = 0.d0 + !$OMP PARALLEL DO DEFAULT(shared) PRIVATE(i,idx,jj,j,degree,exc,phase,hij,l) SCHEDULE(static,1) do i=2,n idx(0) = i call filter_connected(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) @@ -1012,11 +1040,19 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze ! if ((degree == 2).and.(exc(0,1,1)==1)) cycle ! if ((degree > 1)) cycle ! if (exc(0,1,2) /= 0) cycle +! if (exc(0,1,1) == 2) cycle +! if (exc(0,1,2) == 2) cycle +! if ((degree==1).and.(exc(0,1,2) == 1)) cycle call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) - vt (:,i) = vt (:,i) + hij*u_0(j,:) - vt (:,j) = vt (:,j) + hij*u_0(i,:) + do l=1,N_st + !$OMP ATOMIC + vt (l,i) = vt (l,i) + hij*u_0(j,l) + !$OMP ATOMIC + vt (l,j) = vt (l,j) + hij*u_0(i,l) + enddo enddo enddo + !$OMP END PARALLEL DO do i=1,n v_0(i,:) = v_0(i,:) + vt(:,i) enddo diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index afd34d13..73460d0b 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -389,8 +389,6 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order , (N_det) ] -&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] -&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ] use bitmasks implicit none BEGIN_DOC @@ -408,7 +406,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) PROVIDE psi_coef_sorted_bit - integer, allocatable :: to_sort(:) + integer*8, allocatable :: to_sort(:) integer, external :: get_index_in_psi_det_alpha_unique integer, external :: get_index_in_psi_det_beta_unique allocate(to_sort(N_det)) @@ -421,16 +419,47 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) enddo psi_bilinear_matrix_rows(k) = i psi_bilinear_matrix_columns(k) = j - to_sort(k) = N_det_alpha_unique * (j-1) + i + to_sort(k) = int(N_det_alpha_unique,8) * int(j-1,8) + int(i,8) psi_bilinear_matrix_order(k) = k enddo - call isort(to_sort, psi_bilinear_matrix_order, N_det) + call i8sort(to_sort, psi_bilinear_matrix_order, N_det) call iset_order(psi_bilinear_matrix_rows,psi_bilinear_matrix_order,N_det) call iset_order(psi_bilinear_matrix_columns,psi_bilinear_matrix_order,N_det) do l=1,N_states call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det) enddo - psi_bilinear_matrix_columns_loc(1) = 1 + deallocate(to_sort) +END_PROVIDER + + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Order which allors to go from psi_bilinear_matrix to psi_det + END_DOC + integer :: k + do k=1,N_det + psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_order(k)) = k + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1) ] + use bitmasks + implicit none + BEGIN_DOC +! Sparse coefficient matrix if the wave function is expressed in a bilinear form : +! D_a^t C D_b +! +! Rows are alpha determinants and columns are beta. +! +! Order refers to psi_det + END_DOC + integer :: i,j,k, l + + l = psi_bilinear_matrix_columns(1) + psi_bilinear_matrix_columns_loc(l) = 1 do k=2,N_det if (psi_bilinear_matrix_columns(k) == psi_bilinear_matrix_columns(k-1)) then cycle @@ -440,35 +469,27 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) endif enddo psi_bilinear_matrix_columns_loc(N_det_beta_unique+1) = N_det+1 - do k=1,N_det - psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_order(k)) = k - enddo - deallocate(to_sort) END_PROVIDER - BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows , (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_columns, (N_det) ] &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_order , (N_det) ] -&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] use bitmasks implicit none BEGIN_DOC -! Sparse coefficient matrix if the wave function is expressed in a bilinear form : -! D_a^t C D_b +! Transpose of psi_bilinear_matrix +! D_b^t C^t D_a ! ! Rows are Alpha determinants and columns are beta, but the matrix is stored in row major ! format -! -! Order refers to psi_bilinear_matrix END_DOC integer :: i,j,k,l PROVIDE psi_coef_sorted_bit - integer, allocatable :: to_sort(:) + integer*8, allocatable :: to_sort(:) allocate(to_sort(N_det)) do l=1,N_states do k=1,N_det @@ -480,19 +501,50 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ psi_bilinear_matrix_transp_rows (k) = psi_bilinear_matrix_rows (k) i = psi_bilinear_matrix_transp_columns(k) j = psi_bilinear_matrix_transp_rows (k) - to_sort(k) = N_det_beta_unique * (j-1) + i + to_sort(k) = int(N_det_beta_unique,8) * int(j-1,8) + int(i,8) psi_bilinear_matrix_transp_order(k) = k enddo - call isort(to_sort, psi_bilinear_matrix_transp_order, N_det) + call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det) call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) do l=1,N_states call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det) enddo + deallocate(to_sort) +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows_loc, (N_det_alpha_unique+1) ] + use bitmasks + implicit none + BEGIN_DOC +! Location of the columns in the psi_bilinear_matrix + END_DOC + integer :: i,j,k, l + + l = psi_bilinear_matrix_transp_rows(1) + psi_bilinear_matrix_transp_rows_loc(l) = 1 + do k=2,N_det + if (psi_bilinear_matrix_transp_rows(k) == psi_bilinear_matrix_transp_rows(k-1)) then + cycle + else + l = psi_bilinear_matrix_transp_rows(k) + psi_bilinear_matrix_transp_rows_loc(l) = k + endif + enddo + psi_bilinear_matrix_transp_rows_loc(N_det_beta_unique+1) = N_det+1 +END_PROVIDER + +BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] + use bitmasks + implicit none + BEGIN_DOC +! Order which allows to go from psi_bilinear_matrix_order_transp to psi_bilinear_matrix + END_DOC + integer :: k + do k=1,N_det psi_bilinear_matrix_order_transp_reverse(psi_bilinear_matrix_transp_order(k)) = k enddo - deallocate(to_sort) END_PROVIDER @@ -641,17 +693,17 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree -! select case (Nint) -! case (1) -! call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) -! return -! case (2) -! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) -! return -! case (3) -! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) -! return -! end select + select case (Nint) + case (1) + call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) + return + case (2) + call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + return + case (3) + call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + return + end select size_buffer_align = align_double(size_buffer) From 957fa694e287e62b8e65ce8fb6adba3a9824d4c2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 16 Apr 2017 02:37:33 +0200 Subject: [PATCH 12/48] Debugged Davidson for large Ndet --- src/Davidson/u0Hu0.irp.f | 45 +++++++--------------------------------- 1 file changed, 8 insertions(+), 37 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 30ff0fa8..24c4d476 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -757,56 +757,27 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = psi_bilinear_matrix_columns_loc(lcol) - n_doubles=1 - ! Loop over alpha singles ! ----------------------- do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) - lrow = psi_bilinear_matrix_rows(l_a) - if (.not.is_single_a(lrow)) then - continue - else - doubles(n_doubles) = lrow - idx(n_doubles) = l_a - if (n_doubles == maxab) then - - do k=1,n_doubles - lrow = doubles(k) - l_a = idx(k) - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) - do l=1,N_st - v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) - s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) - enddo - enddo - - n_doubles=0 - endif - n_doubles = n_doubles+1 - endif - l_a = l_a+1 - enddo - n_doubles = n_doubles-1 - - do k=1,n_doubles - lrow = doubles(k) - l_a = idx(k) + do l=l_a,psi_bilinear_matrix_columns_loc(lcol+1) + lrow = psi_bilinear_matrix_rows(l) + if (is_single_a(lrow)) exit + enddo + if (l >= psi_bilinear_matrix_columns_loc(lcol+1)) exit + l_a = l 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) call get_s2(tmp_det,tmp_det2,N_int,sij) do l=1,N_st v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) enddo + l_a = l_a+1 enddo - enddo enddo From c30bdd34b83b6774da3fa12e2def6a7fa811e5ac Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 16 Apr 2017 12:08:12 +0200 Subject: [PATCH 13/48] fixed Davidson --- src/Davidson/u0Hu0.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 24c4d476..1a3bcf9f 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -761,7 +761,7 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) ! ----------------------- do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) - do l=l_a,psi_bilinear_matrix_columns_loc(lcol+1) + do l=l_a,psi_bilinear_matrix_columns_loc(lcol+1)-1 lrow = psi_bilinear_matrix_rows(l) if (is_single_a(lrow)) exit enddo From d72440a44c730d5e3072d7d6f15e5ced5a36f801 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 16 Apr 2017 22:23:11 +0200 Subject: [PATCH 14/48] Working on Davdison --- src/Davidson/u0Hu0.irp.f | 788 +++-------------------------------- src/Davidson/u0Hu0_old.irp.f | 669 +++++++++++++++++++++++++++++ 2 files changed, 731 insertions(+), 726 deletions(-) create mode 100644 src/Davidson/u0Hu0_old.irp.f diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 1a3bcf9f..d8426056 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -1,618 +1,3 @@ -subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - BEGIN_DOC - ! Computes e_0 = / - ! - ! n : number of determinants - ! - END_DOC - integer, intent(in) :: n,Nint, N_st, sze_8 - double precision, intent(out) :: e_0(N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - - double precision, allocatable :: H_jj(:), v_0(:,:) - double precision :: u_dot_u,u_dot_v,diag_H_mat_elem - integer :: i,j - allocate (H_jj(n), v_0(sze_8,N_st)) - do i = 1, n - H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) - enddo - - call H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) - do i=1,N_st - e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) - enddo - deallocate (H_jj, v_0) -end - - -subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - ! - END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - integer, allocatable :: shortcut(:,:), sort_idx(:,:) - integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st - - N_st_8 = align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate( ut(N_st_8,n)) - - v_0 = 0.d0 - - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) - call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n),st(N_st_8,n)) - Vt = 0.d0 - St = 0.d0 - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,2),istate) - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(static,1) - do sh=1,shortcut(0,2) - do i=shortcut(sh,2),shortcut(sh+1,2)-1 - org_i = sort_idx(i,2) - do j=shortcut(sh,2),shortcut(sh+1,2)-1 - org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) - if (ext > 4) exit - end do - if(ext == 4) then - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - end if - end do - end do - enddo - !$OMP END DO - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,1),istate) - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(static,1) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - if (sh==sh2) cycle - - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - enddo - enddo - - exa = 0 - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh,1),i-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - do j=i+1,shortcut(sh+1,1)-1 - if (i==j) cycle - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - enddo - enddo - !$OMP END DO - - do istate=1,N_st - do i=1,n - !$OMP ATOMIC - v_0(i,istate) = v_0(i,istate) + vt(istate,i) - enddo - enddo - - deallocate(vt,st) - !$OMP END PARALLEL - - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - enddo - enddo - deallocate (shortcut, sort_idx, sorted, version, ut) -end - - -BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] - implicit none - BEGIN_DOC -! Energy of the current wave function - END_DOC - call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) -END_PROVIDER - - -subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8,update_dets) - use omp_lib - use bitmasks - use f77_zmq - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - ! - ! S2_jj : array of - END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8, update_dets - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - integer :: i,j,k,l, jj,ii - integer :: i0, j0, ithread - - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - integer :: blockb2, istep - double precision :: ave_workload, workload, target_workload_inv - - integer(ZMQ_PTR) :: handler - - if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" - N_st_8 = N_st ! align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - v_0 = 0.d0 - s_0 = 0.d0 - - call davidson_init(handler,keys_tmp,u_0,size(u_0,1),n,N_st,update_dets) - - ave_workload = 0.d0 - do sh=1,shortcut_(0,1) - ave_workload += shortcut_(0,1) - ave_workload += (shortcut_(sh+1,1) - shortcut_(sh,1))**2 - do i=sh, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - ave_workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 - end do - end do - enddo - ave_workload = ave_workload/dble(shortcut_(0,1)) - target_workload_inv = 0.01d0/ave_workload - - PROVIDE nproc - - - character(len=:), allocatable :: task - task = repeat(' ', iposmax) - character(32) :: tmp_task - integer :: ipos, iposmax - iposmax = shortcut_(0,1)+32 - ipos = 1 - do sh=1,shortcut_(0,1),1 - workload = shortcut_(0,1)+dble(shortcut_(sh+1,1) - shortcut_(sh,1))**2 - do i=sh, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 - end do - end do -! istep = 1+ int(workload*target_workload_inv) - istep = 1 - do blockb2=0, istep-1 - write(tmp_task,'(3(I9,1X),''|'',1X)') sh, blockb2, istep - task = task//tmp_task - ipos += 32 - if (ipos+32 > iposmax) then - call add_task_to_taskserver(handler, trim(task)) - ipos=1 - task = '' - endif - enddo - enddo - if (ipos>1) then - call add_task_to_taskserver(handler, trim(task)) - endif - - !$OMP PARALLEL NUM_THREADS(nproc+2) PRIVATE(ithread) - ithread = omp_get_thread_num() - if (ithread == 0 ) then - call zmq_set_running(handler) - call davidson_run(handler, v_0, s_0, size(v_0,1)) - else if (ithread == 1 ) then - call davidson_miniserver_run (update_dets) - else - call davidson_slave_inproc(ithread) - endif - !$OMP END PARALLEL - - call end_parallel_job(handler, 'davidson') - - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) - enddo - enddo -end - - - -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - ! - ! S2_jj : array of - END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) - integer :: i,j,k,l, jj,ii - integer :: i0, j0 - - integer, allocatable :: shortcut(:,:), sort_idx(:,:) - integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st - - N_st_8 = align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) - allocate( ut(N_st_8,n)) - - v_0 = 0.d0 - s_0 = 0.d0 - - call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) - call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& - !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) - allocate(vt(N_st_8,n),st(N_st_8,n)) - Vt = 0.d0 - St = 0.d0 - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,2),istate) - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(static,4) - do sh=1,shortcut(0,2) - do i=shortcut(sh,2),shortcut(sh+1,2)-1 - org_i = sort_idx(i,2) - do j=shortcut(sh,2),shortcut(sh+1,2)-1 - org_j = sort_idx(j,2) - ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) - if (ext > 4) exit - end do - if(ext == 4) then - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - end if - end do - end do - enddo - !$OMP END DO - - !$OMP DO - do i=1,n - do istate=1,N_st - ut(istate,i) = u_0(sort_idx(i,1),istate) - enddo - enddo - !$OMP END DO - - !$OMP DO SCHEDULE(static,4) - do sh=1,shortcut(0,1) - do sh2=1,shortcut(0,1) - if (sh==sh2) cycle - - exa = 0 - do ni=1,Nint - exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) - end do - if(exa > 2) then - cycle - end if - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - enddo - enddo - - exa = 0 - - do i=shortcut(sh,1),shortcut(sh+1,1)-1 - org_i = sort_idx(i,1) - do ni=1,Nint - sorted_i(ni) = sorted(ni,i,1) - enddo - - do j=shortcut(sh,1),i-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - - do j=i+1,shortcut(sh+1,1)-1 - ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) - if (ext > 4) cycle - do ni=2,Nint - ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) - if (ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx(j,1) - call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) - if (hij /= 0.d0) then - do istate=1,n_st - vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) - enddo - endif - if (ext /= 2) then - call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) - if (s2 /= 0.d0) then - do istate=1,n_st - st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) - enddo - endif - endif - endif - enddo - enddo - enddo - !$OMP END DO - - do istate=1,N_st - do i=1,n - !$OMP ATOMIC - v_0(i,istate) = v_0(i,istate) + vt(istate,i) - !$OMP ATOMIC - s_0(i,istate) = s_0(i,istate) + st(istate,i) - enddo - enddo - - deallocate(vt,st) - !$OMP END PARALLEL - - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) - enddo - enddo - deallocate (shortcut, sort_idx, sorted, version, ut) -end - - - - - subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) use bitmasks implicit none @@ -620,14 +5,30 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> ! ! 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_8 double precision, intent(inout) :: v_0(sze_8,N_st), s_0(sze_8,N_st), u_0(sze_8,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 H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) + v_0 = 0.d0 + s_0 = 0.d0 + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,1,N_det,0,1) + deallocate(u_t) + do k=1,N_st call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det) @@ -636,14 +37,19 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) end -subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) + + +subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 END_DOC - integer, intent(in) :: N_st,sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st), u_0(sze_8,N_st) + integer, intent(in) :: N_st,sze_8,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) PROVIDE ref_bitmask_energy @@ -662,30 +68,20 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) integer(bit_kind), allocatable :: buffer(:,:) integer :: n_singles, n_doubles integer, allocatable :: singles(:), doubles(:) - integer, allocatable :: singles_b(:,:) + integer, allocatable :: singles_a(:) integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) - integer :: maxab, n_singles_max, kcol_prev, nmax - double precision, allocatable :: u_t(:,:), v_t(:,:), s_t(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t, u_t + integer :: maxab, n_singles_a, kcol_prev, nmax + double precision, allocatable :: v_t(:,:), s_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 - allocate(idx0(maxab), u_t(N_st,N_det) ) + allocate(idx0(maxab)) do i=1,maxab idx0(i) = i enddo - call dtranspose( & - u_0, & - size(u_0, 1), & - u_t, & - size(u_t, 1), & - N_det, N_st) - - v_0 = 0.d0 - s_0 = 0.d0 - ! Prepare the array of all alpha single excitations ! ------------------------------------------------- @@ -699,35 +95,33 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & !$OMP singles_alpha, psi_bilinear_matrix_columns_loc, & - !$OMP singles_alpha_size, sze_8, & - !$OMP idx0, u_t, maxab, v_0, s_0) & + !$OMP singles_alpha_size, sze_8, istart, iend, istep, & + !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, is_single_a,l_a, l_b, nmax, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & - !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, s_t) + !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & + !$OMP singles_a, n_singles_a, s_t) ! Alpha/Beta double excitations ! ============================= allocate( buffer(N_int,maxab), & - singles(maxab), & + singles(maxab), & + singles_a(maxab), & doubles(maxab), & idx(maxab), & v_t(N_st,N_det), s_t(N_st,N_det), & is_single_a(N_det_alpha_unique)) is_single_a = .False. kcol_prev=-1 - krow=1 v_t = 0.d0 s_t = 0.d0 !$OMP DO SCHEDULE(static,1) - do k_a=1,N_det - do k=1,singles_alpha(0,krow) - is_single_a( singles_alpha(k,krow) ) = .False. - enddo + do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) kcol = psi_bilinear_matrix_columns(k_a) @@ -742,15 +136,15 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) if (kcol /= kcol_prev) then call get_all_spin_singles( & psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& - singles, n_singles) + singles_a, n_singles_a) endif kcol_prev = kcol ! Loop over singly excited beta columns ! ------------------------------------- - do i=1,n_singles - lcol = singles(i) + do i=1,n_singles_a + lcol = singles_a(i) if (lcol <= kcol) cycle tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) @@ -779,16 +173,19 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) l_a = l_a+1 enddo enddo + do k=1,singles_alpha(0,krow) + is_single_a( singles_alpha(k,krow) ) = .False. + enddo enddo - !$OMP END DO NOWAIT - - ! Single and double alpha excitations - ! =================================== - !$OMP DO SCHEDULE(static,1) - do k_a=1,N_det + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + ! Initial determinant is at k_a in alpha-major representation ! ----------------------------------------------------------------------- @@ -854,27 +251,27 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo enddo - end do - !$OMP END DO NOWAIT - ! Single and double beta excitations - ! ================================== + ! Single and double beta excitations + ! ================================== - !$OMP DO SCHEDULE(static,1) - do k_b=1,N_det - - ! Initial determinant is at k_b in beta-major representation + + ! Initial determinant is at k_a in alpha-major representation ! ----------------------------------------------------------------------- - krow = psi_bilinear_matrix_transp_rows(k_b) - kcol = psi_bilinear_matrix_transp_columns(k_b) + 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) - k_a = psi_bilinear_matrix_transp_order(k_b) + + ! 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 l_b = k_b+1 @@ -925,15 +322,10 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) enddo enddo - end do - !$OMP END DO NOWAIT + ! Diagonal contribution + ! ===================== - ! Diagonal contribution - ! ===================== - - !$OMP DO SCHEDULE(static,1) - do k_a=1,N_det ! Initial determinant is at k_a in alpha-major representation ! ----------------------------------------------------------------------- @@ -971,61 +363,5 @@ subroutine H_S2_u_0_nstates_bilinear_order(v_0,s_0,u_0,N_st,sze_8) end -subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - integer, intent(in) :: N_st,n,Nint, sze_8 - integer(bit_kind), intent(in) :: keys_tmp(Nint,2,n) - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - - PROVIDE ref_bitmask_energy - double precision, allocatable :: vt(:,:) - integer, allocatable :: idx(:) - integer :: i,j, jj, l - double precision :: hij - - do i=1,n - v_0(i,:) = H_jj(i) * u_0(i,:) - enddo - - allocate(idx(0:n), vt(N_st,n)) - Vt = 0.d0 - !$OMP PARALLEL DO DEFAULT(shared) PRIVATE(i,idx,jj,j,degree,exc,phase,hij,l) SCHEDULE(static,1) - do i=2,n - idx(0) = i - call filter_connected(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) - do jj=1,idx(0) - j = idx(jj) - double precision :: phase - integer :: degree - integer :: exc(0:2,2,2) - call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) -! if ((degree == 2).and.(exc(0,1,1)==1)) then -! continue -! else -! cycle -! endif -! if ((degree == 2).and.(exc(0,1,1)==1)) cycle -! if ((degree > 1)) cycle -! if (exc(0,1,2) /= 0) cycle -! if (exc(0,1,1) == 2) cycle -! if (exc(0,1,2) == 2) cycle -! if ((degree==1).and.(exc(0,1,2) == 1)) cycle - call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) - do l=1,N_st - !$OMP ATOMIC - vt (l,i) = vt (l,i) + hij*u_0(j,l) - !$OMP ATOMIC - vt (l,j) = vt (l,j) + hij*u_0(i,l) - enddo - enddo - enddo - !$OMP END PARALLEL DO - do i=1,n - v_0(i,:) = v_0(i,:) + vt(:,i) - enddo -end diff --git a/src/Davidson/u0Hu0_old.irp.f b/src/Davidson/u0Hu0_old.irp.f new file mode 100644 index 00000000..60212164 --- /dev/null +++ b/src/Davidson/u0Hu0_old.irp.f @@ -0,0 +1,669 @@ +subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint, N_st, sze_8 + double precision, intent(out) :: e_0(N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision, allocatable :: H_jj(:), v_0(:,:) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j + allocate (H_jj(n), v_0(sze_8,N_st)) + do i = 1, n + H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) + enddo + + call H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) + do i=1,N_st + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + enddo + deallocate (H_jj, v_0) +end + + +subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate( ut(N_st_8,n)) + + v_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,1) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),shortcut(sh+1,2)-1 + org_j = sort_idx(j,2) + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + end if + end do + end do + enddo + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,1) + do sh=1,shortcut(0,1) + do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + if (i==j) cycle + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO + + do istate=1,N_st + do i=1,n + !$OMP ATOMIC + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + enddo + enddo + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + + +BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] + implicit none + BEGIN_DOC +! Energy of the current wave function + END_DOC + call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) +END_PROVIDER + + +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8,update_dets) + use omp_lib + use bitmasks + use f77_zmq + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8, update_dets + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + integer :: i,j,k,l, jj,ii + integer :: i0, j0, ithread + + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + integer :: blockb2, istep + double precision :: ave_workload, workload, target_workload_inv + + integer(ZMQ_PTR) :: handler + + if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" + N_st_8 = N_st ! align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + v_0 = 0.d0 + s_0 = 0.d0 + + call davidson_init(handler,keys_tmp,u_0,size(u_0,1),n,N_st,update_dets) + + ave_workload = 0.d0 + do sh=1,shortcut_(0,1) + ave_workload += shortcut_(0,1) + ave_workload += (shortcut_(sh+1,1) - shortcut_(sh,1))**2 + do i=sh, shortcut_(0,2), shortcut_(0,1) + do j=i, min(i, shortcut_(0,2)) + ave_workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 + end do + end do + enddo + ave_workload = ave_workload/dble(shortcut_(0,1)) + target_workload_inv = 0.01d0/ave_workload + + PROVIDE nproc + + + character(len=:), allocatable :: task + task = repeat(' ', iposmax) + character(32) :: tmp_task + integer :: ipos, iposmax + iposmax = shortcut_(0,1)+32 + ipos = 1 + do sh=1,shortcut_(0,1),1 + workload = shortcut_(0,1)+dble(shortcut_(sh+1,1) - shortcut_(sh,1))**2 + do i=sh, shortcut_(0,2), shortcut_(0,1) + do j=i, min(i, shortcut_(0,2)) + workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 + end do + end do +! istep = 1+ int(workload*target_workload_inv) + istep = 1 + do blockb2=0, istep-1 + write(tmp_task,'(3(I9,1X),''|'',1X)') sh, blockb2, istep + task = task//tmp_task + ipos += 32 + if (ipos+32 > iposmax) then + call add_task_to_taskserver(handler, trim(task)) + ipos=1 + task = '' + endif + enddo + enddo + if (ipos>1) then + call add_task_to_taskserver(handler, trim(task)) + endif + + !$OMP PARALLEL NUM_THREADS(nproc+2) PRIVATE(ithread) + ithread = omp_get_thread_num() + if (ithread == 0 ) then + call zmq_set_running(handler) + call davidson_run(handler, v_0, s_0, size(v_0,1)) + else if (ithread == 1 ) then + call davidson_miniserver_run (update_dets) + else + call davidson_slave_inproc(ithread) + endif + !$OMP END PARALLEL + + call end_parallel_job(handler, 'davidson') + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo +end + + + +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st,n,Nint, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + double precision :: hij,s2 + double precision, allocatable :: vt(:,:), ut(:,:), st(:,:) + integer :: i,j,k,l, jj,ii + integer :: i0, j0 + + integer, allocatable :: shortcut(:,:), sort_idx(:,:) + integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:) + integer(bit_kind) :: sorted_i(Nint) + + integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate + integer :: N_st_8 + + integer, external :: align_double + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: vt, ut, st + + N_st_8 = align_double(N_st) + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy + + allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2)) + allocate( ut(N_st_8,n)) + + v_0 = 0.d0 + s_0 = 0.d0 + + call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint) + call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,hij,s2,j,k,jj,vt,st,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)& + !$OMP SHARED(n,keys_tmp,ut,Nint,u_0,v_0,s_0,sorted,shortcut,sort_idx,version,N_st,N_st_8) + allocate(vt(N_st_8,n),st(N_st_8,n)) + Vt = 0.d0 + St = 0.d0 + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,2),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,4) + do sh=1,shortcut(0,2) + do i=shortcut(sh,2),shortcut(sh+1,2)-1 + org_i = sort_idx(i,2) + do j=shortcut(sh,2),shortcut(sh+1,2)-1 + org_j = sort_idx(j,2) + ext = popcnt(xor(sorted(1,i,2), sorted(1,j,2))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2))) + if (ext > 4) exit + end do + if(ext == 4) then + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + end if + end do + end do + enddo + !$OMP END DO + + !$OMP DO + do i=1,n + do istate=1,N_st + ut(istate,i) = u_0(sort_idx(i,1),istate) + enddo + enddo + !$OMP END DO + + !$OMP DO SCHEDULE(static,4) + do sh=1,shortcut(0,1) + do sh2=1,shortcut(0,1) + if (sh==sh2) cycle + + exa = 0 + do ni=1,Nint + exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1))) + end do + if(exa > 2) then + cycle + end if + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh2,1),shortcut(sh2+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + enddo + enddo + + exa = 0 + + do i=shortcut(sh,1),shortcut(sh+1,1)-1 + org_i = sort_idx(i,1) + do ni=1,Nint + sorted_i(ni) = sorted(ni,i,1) + enddo + + do j=shortcut(sh,1),i-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + + do j=i+1,shortcut(sh+1,1)-1 + ext = exa + popcnt(xor(sorted_i(1), sorted(1,j,1))) + if (ext > 4) cycle + do ni=2,Nint + ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1))) + if (ext > 4) exit + end do + if(ext <= 4) then + org_j = sort_idx(j,1) + call i_h_j (keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,hij) + if (hij /= 0.d0) then + do istate=1,n_st + vt (istate,org_i) = vt (istate,org_i) + hij*ut(istate,j) + enddo + endif + if (ext /= 2) then + call get_s2(keys_tmp(1,1,org_j),keys_tmp(1,1,org_i),nint,s2) + if (s2 /= 0.d0) then + do istate=1,n_st + st (istate,org_i) = st (istate,org_i) + s2*ut(istate,j) + enddo + endif + endif + endif + enddo + enddo + enddo + !$OMP END DO + + do istate=1,N_st + do i=1,n + !$OMP ATOMIC + v_0(i,istate) = v_0(i,istate) + vt(istate,i) + !$OMP ATOMIC + s_0(i,istate) = s_0(i,istate) + st(istate,i) + enddo + enddo + + deallocate(vt,st) + !$OMP END PARALLEL + + do istate=1,N_st + do i=1,n + v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) + s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) + enddo + enddo + deallocate (shortcut, sort_idx, sorted, version, ut) +end + +subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + integer, intent(in) :: N_st,n,Nint, sze_8 + integer(bit_kind), intent(in) :: keys_tmp(Nint,2,n) + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(in) :: H_jj(n), S2_jj(n) + + PROVIDE ref_bitmask_energy + + double precision, allocatable :: vt(:,:) + integer, allocatable :: idx(:) + integer :: i,j, jj, l + double precision :: hij + + do i=1,n + v_0(i,:) = H_jj(i) * u_0(i,:) + enddo + + allocate(idx(0:n), vt(N_st,n)) + Vt = 0.d0 + !$OMP PARALLEL DO DEFAULT(shared) PRIVATE(i,idx,jj,j,degree,exc,phase,hij,l) SCHEDULE(static,1) + do i=2,n + idx(0) = i + call filter_connected(keys_tmp,keys_tmp(1,1,i),Nint,i-1,idx) + do jj=1,idx(0) + j = idx(jj) + double precision :: phase + integer :: degree + integer :: exc(0:2,2,2) + call get_excitation(keys_tmp(1,1,j),keys_tmp(1,1,i),exc,degree,phase,Nint) +! if ((degree == 2).and.(exc(0,1,1)==1)) then +! continue +! else +! cycle +! endif +! if ((degree == 2).and.(exc(0,1,1)==1)) cycle +! if ((degree > 1)) cycle +! if (exc(0,1,2) /= 0) cycle +! if (exc(0,1,1) == 2) cycle +! if (exc(0,1,2) == 2) cycle +! if ((degree==1).and.(exc(0,1,2) == 1)) cycle + call i_H_j(keys_tmp(1,1,j),keys_tmp(1,1,i),Nint,hij) + do l=1,N_st + !$OMP ATOMIC + vt (l,i) = vt (l,i) + hij*u_0(j,l) + !$OMP ATOMIC + vt (l,j) = vt (l,j) + hij*u_0(i,l) + enddo + enddo + enddo + !$OMP END PARALLEL DO + do i=1,n + v_0(i,:) = v_0(i,:) + vt(:,i) + enddo +end + From 04e9918b90294ae6f5ca477626f15ff03d9a1d11 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Apr 2017 01:36:16 +0200 Subject: [PATCH 15/48] Davidson ZMQ OK --- .../selection_davidson_slave.irp.f | 7 - plugins/Selectors_full/zmq.irp.f | 4 +- src/Davidson/davidson_parallel.irp.f | 659 ++++++------------ src/Davidson/davidson_slave.irp.f | 10 - src/Davidson/diagonalization_hs2.irp.f | 14 +- src/Davidson/u0Hu0.irp.f | 35 + src/Davidson/u0Hu0_old.irp.f | 152 ---- 7 files changed, 259 insertions(+), 622 deletions(-) diff --git a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f index a1e365a4..306320f7 100644 --- a/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_davidson_slave.irp.f @@ -25,7 +25,6 @@ subroutine run_wf double precision :: energy(N_states) character*(64) :: states(4) integer :: rc, i - logical :: force_update call provide_everything @@ -35,7 +34,6 @@ subroutine run_wf states(3) = 'pt2' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - force_update = .True. do @@ -65,12 +63,7 @@ subroutine run_wf ! -------- print *, 'Davidson' - call davidson_miniserver_get(force_update) - force_update = .False. - !$OMP PARALLEL PRIVATE(i) - i = omp_get_thread_num() call davidson_slave_tcp(i) - !$OMP END PARALLEL print *, 'Davidson done' else if (trim(zmq_state) == 'pt2') then diff --git a/plugins/Selectors_full/zmq.irp.f b/plugins/Selectors_full/zmq.irp.f index 8046212b..59f40daf 100644 --- a/plugins/Selectors_full/zmq.irp.f +++ b/plugins/Selectors_full/zmq.irp.f @@ -90,13 +90,13 @@ subroutine zmq_get_psi(zmq_to_qp_run_socket, worker_id, energy, size_energy) psi_det_size = psi_det_size_read TOUCH psi_det_size N_det N_states - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) if (rc /= N_int*2*N_det*bit_kind) then print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,0) if (rc /= psi_det_size*N_states*8) then print *, '77_zmq_recv(zmq_to_qp_run_socket,psi_coef,psi_det_size*N_states*8,ZMQ_SNDMORE)' stop 'error' diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 4c4b11b1..51863c1e 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -1,191 +1,6 @@ - -!brought to you by garniroy inc. - use bitmasks use f77_zmq -subroutine davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) - - implicit none - - - integer , intent(in) :: blockb, bs, blockb2, istep - integer , intent(inout) :: N - integer , intent(inout) :: idx(bs) - double precision , intent(inout) :: vt(N_states_diag, bs) - double precision , intent(inout) :: st(N_states_diag, bs) - - integer :: i,ii, j, sh, sh2, exa, ext, org_i, org_j, istate, ni, endi - integer(bit_kind) :: sorted_i(N_int) - double precision :: s2, hij - logical, allocatable :: wrotten(:) - - PROVIDE dav_det ref_bitmask_energy - - allocate(wrotten(bs)) - wrotten = .false. - - ii=0 - sh = blockb - do sh2=1,shortcut_(0,1) - exa = popcnt(xor(version_(1,sh,1), version_(1,sh2,1))) - do ni=2,N_int - exa = exa + popcnt(xor(version_(ni,sh,1), version_(ni,sh2,1))) - end do - if(exa > 2) cycle - - do i=blockb2+shortcut_(sh,1),shortcut_(sh+1,1)-1, istep - ii = i - shortcut_(blockb,1) + 1 - - org_i = sort_idx_(i,1) - do ni=1,N_int - sorted_i(ni) = sorted_(ni,i,1) - enddo - - do j=shortcut_(sh2,1), shortcut_(sh2+1,1)-1 - if(i == j) cycle - ext = exa + popcnt(xor(sorted_i(1), sorted_(1,j,1))) - if(ext > 4) cycle - do ni=2,N_int - ext = ext + popcnt(xor(sorted_i(ni), sorted_(ni,j,1))) - if(ext > 4) exit - end do - if(ext <= 4) then - org_j = sort_idx_(j,1) - call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) - call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) -! call i_h_j (sorted_(1,j,1),sorted_(1,i,1),n_int,hij) -! call get_s2(sorted_(1,j,1),sorted_(1,i,1),n_int,s2) - if(.not. wrotten(ii)) then - wrotten(ii) = .true. - idx(ii) = org_i - vt (:,ii) = 0d0 - st (:,ii) = 0d0 - end if - do istate=1,N_states_diag - vt (istate,ii) = vt (istate,ii) +hij*dav_ut(istate,org_j) - st (istate,ii) = st (istate,ii) +s2*dav_ut(istate,org_j) - enddo - endif - enddo - enddo - enddo - - - if ( blockb <= shortcut_(0,2) ) then - sh=blockb - do sh2=sh, shortcut_(0,2), shortcut_(0,1) - do i=blockb2+shortcut_(sh2,2),shortcut_(sh2+1,2)-1, istep - ii += 1 - if (ii>bs) then - print *, irp_here - stop 'ii>bs' - endif - org_i = sort_idx_(i,2) - do j=shortcut_(sh2,2),shortcut_(sh2+1,2)-1 - if(i == j) cycle - org_j = sort_idx_(j,2) - ext = popcnt(xor(sorted_(1,i,2), sorted_(1,j,2))) - if (ext > 4) cycle - do ni=2,N_int - ext = ext + popcnt(xor(sorted_(ni,i,2), sorted_(ni,j,2))) - if (ext > 4) exit - end do - if(ext == 4) then - call i_h_j (dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,hij) - call get_s2(dav_det(1,1,org_j),dav_det(1,1,org_i),n_int,s2) -! call i_h_j (sorted_(1,j,2),sorted_(1,i,2),n_int,hij) -! call get_s2(sorted_(1,j,2),sorted_(1,i,2),n_int,s2) - if(.not. wrotten(ii)) then - wrotten(ii) = .true. - idx(ii) = org_i - vt (:,ii) = 0d0 - st (:,ii) = 0d0 - end if - do istate=1,N_states_diag - vt (istate,ii) = vt (istate,ii) +hij*dav_ut(istate,org_j) - st (istate,ii) = st (istate,ii) +s2*dav_ut(istate,org_j) - enddo - end if - end do - end do - enddo - endif - - N=0 - do i=1,bs - if(wrotten(i)) then - N += 1 - idx(N) = idx(i) - vt(:,N) = vt(:,i) - st(:,N) = st(:,i) - end if - end do - - -end subroutine - - - - -subroutine davidson_collect(N, idx, vt, st , v0t, s0t) - implicit none - - - integer , intent(in) :: N - integer , intent(in) :: idx(N) - double precision , intent(in) :: vt(N_states_diag, N) - double precision , intent(in) :: st(N_states_diag, N) - double precision , intent(inout) :: v0t(N_states_diag,dav_size) - double precision , intent(inout) :: s0t(N_states_diag,dav_size) - - integer :: i, j, k - - do i=1,N - k = idx(i) - do j=1,N_states_diag - v0t(j,k) = v0t(j,k) + vt(j,i) - s0t(j,k) = s0t(j,k) + st(j,i) - enddo - end do -end subroutine - - -subroutine davidson_init(zmq_to_qp_run_socket,dets_in,u,n0,n,n_st,update_dets) - use f77_zmq - implicit none - - integer(ZMQ_PTR), intent(out) :: zmq_to_qp_run_socket - integer, intent(in) :: n0,n, n_st, update_dets - double precision, intent(in) :: u(n0,n_st) - integer(bit_kind), intent(in) :: dets_in(N_int,2,n) - integer :: i,k - - - if (update_dets == 1) then - dav_size = n - touch dav_size - do i=1,dav_size - do k=1,N_int - dav_det(k,1,i) = dets_in(k,1,i) - dav_det(k,2,i) = dets_in(k,2,i) - enddo - enddo - touch dav_det - endif - - do i=1,n - do k=1,n_st - dav_ut(k,i) = u(i,k) - enddo - enddo - - soft_touch dav_ut - - call new_parallel_job(zmq_to_qp_run_socket,"davidson") -end subroutine - - subroutine davidson_slave_inproc(i) implicit none @@ -211,8 +26,6 @@ subroutine davidson_run_slave(thread,iproc) integer, intent(in) :: thread, iproc integer :: worker_id, task_id, blockb - character*(512) :: task - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket @@ -231,7 +44,11 @@ subroutine davidson_run_slave(thread,iproc) return end if - call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) + integer :: sze_8 + integer, external :: align_double + sze_8 = align_double(N_det) + + call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_states_diag, sze_8, worker_id) call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) @@ -239,85 +56,111 @@ end subroutine -subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, worker_id) +subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_8, worker_id) use f77_zmq implicit none integer(ZMQ_PTR),intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR),intent(in) :: zmq_socket_push - integer,intent(in) :: worker_id - integer :: task_id - character*(512) :: task + integer,intent(in) :: worker_id, N_st, sze_8 + integer :: task_id + character*(512) :: msg + integer :: imin, imax, ishift, istep + double precision, allocatable :: v_0(:,:), s_0(:,:), u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_0, s_0 - integer :: blockb, blockb2, istep - integer :: N - integer , allocatable :: idx(:) - double precision , allocatable :: vt(:,:) - double precision , allocatable :: st(:,:) + allocate(v_0(N_det,N_st), s_0(N_det,N_st),u_t(N_st,N_det)) + + ! Get wave function (u_t) + ! ----------------------- + + integer :: rc + write(msg, *) 'get_psi ', worker_id + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0) + if (rc /= len(trim(msg))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(msg),len(trim(msg)),0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,msg,len(msg),0) + if (msg(1:13) /= 'get_psi_reply') then + print *, rc, trim(msg) + print *, 'Error in get_psi_reply' + stop 'error' + endif + + integer :: N_states_read, N_det_read, psi_det_size_read + integer :: N_det_selectors_read, N_det_generators_read + double precision :: energy(N_states_diag) + + read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read,& + N_det_generators_read, N_det_selectors_read + if (rc /= worker_id) then + print *, 'Wrong worker ID' + stop 'error' + endif - integer :: bs, i, j - - allocate(idx(1), vt(1,1), st(1,1)) + if (N_states_read /= N_st) then + stop 'error : N_st' + endif + + if (N_det_read /= N_det) then + stop 'error : N_det' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)*8,0) + if (rc /= size(u_t)*8) then + print *, rc, size(u_t)*8 + print *, 'f77_zmq_recv(zmq_to_qp_run_socket,u_t,size(u_t)Ă—8,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,N_states_diag*8,0) + if (rc /= N_states_diag*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,N_states_diag*8,0)' + stop 'error' + endif + + ! Run tasks + ! --------- do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + v_0 = 0.d0 + s_0 = 0.d0 + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) if(task_id == 0) exit - read (task,*) blockb, blockb2, istep - bs = shortcut_(blockb+1,1) - shortcut_(blockb, 1) - do i=blockb, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - bs += shortcut_(j+1,2) - shortcut_(j, 2) - end do - end do - if(bs > size(idx)) then - deallocate(idx, vt, st) - allocate(idx(bs)) - allocate(vt(N_states_diag, bs)) - allocate(st(N_states_diag, bs)) - end if - - call davidson_process(blockb, blockb2, N, idx, vt, st, bs, istep) + read (msg,*) imin, imax, ishift, istep + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,imin,imax,ishift,istep) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - call davidson_push_results(zmq_socket_push, blockb, blockb2, N, idx, vt, st, task_id) + call davidson_push_results(zmq_socket_push, v_0, s_0, task_id) end do - deallocate(idx, vt, st) end subroutine -subroutine davidson_push_results(zmq_socket_push, blockb, blocke, N, idx, vt, st, task_id) +subroutine davidson_push_results(zmq_socket_push, v_0, s_0, task_id) use f77_zmq implicit none integer(ZMQ_PTR) ,intent(in) :: zmq_socket_push integer ,intent(in) :: task_id - - integer ,intent(in) :: blockb, blocke - integer ,intent(in) :: N - integer ,intent(in) :: idx(N) - double precision ,intent(in) :: vt(N_states_diag, N) - double precision ,intent(in) :: st(N_states_diag, N) + double precision ,intent(in) :: v_0(N_det,N_states_diag) + double precision ,intent(in) :: s_0(N_det,N_states_diag) integer :: rc - rc = f77_zmq_send( zmq_socket_push, blockb, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push blockb" + rc = f77_zmq_send( zmq_socket_push, v_0, 8*N_states_diag*N_det, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N_det) stop "davidson_push_results failed to push vt" - rc = f77_zmq_send( zmq_socket_push, blocke, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push blocke" - - rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE) - if(rc /= 4) stop "davidson_push_results failed to push N" - - rc = f77_zmq_send( zmq_socket_push, idx, 4*N, ZMQ_SNDMORE) - if(rc /= 4*N) stop "davidson_push_results failed to push idx" - - rc = f77_zmq_send( zmq_socket_push, vt, 8*N_states_diag* N, ZMQ_SNDMORE) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push vt" - - rc = f77_zmq_send( zmq_socket_push, st, 8*N_states_diag* N, ZMQ_SNDMORE) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to push st" + rc = f77_zmq_send( zmq_socket_push, s_0, 8*N_states_diag*N_det, ZMQ_SNDMORE) + if(rc /= 8*N_states_diag* N_det) stop "davidson_push_results failed to push st" rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) if(rc /= 4) stop "davidson_push_results failed to push task_id" @@ -334,37 +177,22 @@ end subroutine -subroutine davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) +subroutine davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) use f77_zmq implicit none integer(ZMQ_PTR) ,intent(in) :: zmq_socket_pull integer ,intent(out) :: task_id - integer ,intent(out) :: blockb, blocke - integer ,intent(out) :: N - integer ,intent(out) :: idx(*) - double precision ,intent(out) :: vt(N_states_diag, *) - double precision ,intent(out) :: st(N_states_diag, *) + double precision ,intent(out) :: v_0(N_det,N_states_diag) + double precision ,intent(out) :: s_0(N_det,N_states_diag) integer :: rc - rc = f77_zmq_recv( zmq_socket_pull, blockb, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull blockb" - - rc = f77_zmq_recv( zmq_socket_pull, blocke, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull blocke" - - rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) - if(rc /= 4) stop "davidson_push_results failed to pull N" - - rc = f77_zmq_recv( zmq_socket_pull, idx, 4*N, 0) - if(rc /= 4*N) stop "davidson_push_results failed to pull idx" + rc = f77_zmq_recv( zmq_socket_pull, v_0, 8*size(v_0), 0) + if(rc /= 8*size(s_0)) stop "davidson_push_results failed to pull v_0" - rc = f77_zmq_recv( zmq_socket_pull, vt, 8*N_states_diag* N, 0) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull vt" - - rc = f77_zmq_recv( zmq_socket_pull, st, 8*N_states_diag* N, 0) - if(rc /= 8*N_states_diag* N) stop "davidson_push_results failed to pull st" + rc = f77_zmq_recv( zmq_socket_pull, s_0, 8*size(s_0), 0) + if(rc /= 8*size(s_0)) stop "davidson_push_results failed to pull s_0" rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) if(rc /= 4) stop "davidson_pull_results failed to pull task_id" @@ -391,45 +219,27 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LD double precision ,intent(inout) :: v0(LDA, N_states_diag) double precision ,intent(inout) :: s0(LDA, N_states_diag) - integer :: more, task_id, taskn + integer :: more, task_id - integer :: blockb, blocke - integer :: N - integer , allocatable :: idx(:) - double precision , allocatable :: vt(:,:), v0t(:,:), s0t(:,:) - double precision , allocatable :: st(:,:) - - integer :: msize - - msize = (1 + max_blocksize)*2 - allocate(idx(msize)) - allocate(vt(N_states_diag, msize)) - allocate(st(N_states_diag, msize)) - allocate(v0t(N_states_diag, dav_size)) - allocate(s0t(N_states_diag, dav_size)) - - v0t = 0.d0 - s0t = 0.d0 + double precision, allocatable :: v_0(:,:), s_0(:,:) + integer :: i,j + allocate(v_0(N_det,N_states_diag), s_0(N_det,N_states_diag)) + v0 = 0.d0 + s0 = 0.d0 more = 1 - do while (more == 1) - call davidson_pull_results(zmq_socket_pull, blockb, blocke, N, idx, vt, st, task_id) - !DIR$ FORCEINLINE - call davidson_collect(N, idx, vt, st , v0t, s0t) + call davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) + do j=1,N_states_diag + do i=1,N_det + v0(i,j) = v0(i,j) + v_0(i,j) + s0(i,j) = s0(i,j) + s_0(i,j) + enddo + enddo call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) end do - deallocate(idx,vt,st) + deallocate(v_0,s_0) - integer :: i,j - do j=1,N_states_diag - do i=1,dav_size - v0(i,j) = v0t(j,i) - s0(i,j) = s0t(j,i) - enddo - enddo - - deallocate(v0t,s0t) end subroutine @@ -456,168 +266,129 @@ subroutine davidson_run(zmq_to_qp_run_socket , v0, s0, LDA) call davidson_collector(zmq_collector, zmq_socket_pull , v0, s0, LDA) call end_zmq_to_qp_run_socket(zmq_collector) call end_zmq_pull_socket(zmq_socket_pull) - call davidson_miniserver_end() end subroutine -subroutine davidson_miniserver_run(update_dets) +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) + use omp_lib + use bitmasks use f77_zmq implicit none - integer update_dets - integer(ZMQ_PTR) responder - character*(64) address - character(len=:), allocatable :: buffer - integer rc + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! n : number of determinants + ! + ! H_jj : array of + ! + ! S2_jj : array of + END_DOC + integer, intent(in) :: N_st, sze_8 + double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(inout):: u_0(sze_8,N_st) + integer :: i,j,k + integer :: ithread + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate (character(len=20) :: buffer) - address = 'tcp://*:11223' - - PROVIDE dav_det dav_ut dav_size + 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) - responder = f77_zmq_socket(zmq_context, ZMQ_REP) - rc = f77_zmq_bind(responder,address) + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket - do - rc = f77_zmq_recv(responder, buffer, 5, 0) - if (buffer(1:rc) == 'end') then - rc = f77_zmq_send (responder, "end", 3, 0) - exit - else if (buffer(1:rc) == 'det') then - rc = f77_zmq_send (responder, dav_size, 4, ZMQ_SNDMORE) - rc = f77_zmq_send (responder, dav_det, 16*N_int*dav_size, 0) - else if (buffer(1:rc) == 'ut') then - rc = f77_zmq_send (responder, update_dets, 4, ZMQ_SNDMORE) - rc = f77_zmq_send (responder, dav_size, 4, ZMQ_SNDMORE) - rc = f77_zmq_send (responder, dav_ut, 8*dav_size*N_states_diag, 0) - endif + if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (n>0) + PROVIDE ref_bitmask_energy nproc + + v_0 = 0.d0 + s_0 = 0.d0 + + call new_parallel_job(zmq_to_qp_run_socket,'davidson') + + character*(512) :: task + integer :: rc + double precision :: energy(N_st) + energy = 0.d0 + + task = ' ' + write(task,*) 'put_psi ', 1, N_st, N_det, N_det + rc = f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE) + if (rc /= len(trim(task))) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,trim(task),len(trim(task)),ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE) + if (rc /= N_int*2*N_det*bit_kind) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE) + if (rc /= size(u_t)*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,u_t,size(u_t)*8,ZMQ_SNDMORE)' + stop 'error' + endif + + rc = f77_zmq_send(zmq_to_qp_run_socket,energy,N_st*8,0) + if (rc /= N_st*8) then + print *, 'f77_zmq_send(zmq_to_qp_run_socket,energy,size_energy*8,0)' + stop 'error' + endif + + rc = f77_zmq_recv(zmq_to_qp_run_socket,task,len(task),0) + if (task(1:rc) /= 'put_psi_reply 1') then + print *, rc, trim(task) + print *, 'Error in put_psi_reply' + stop 'error' + endif + + deallocate(u_t) + + + integer :: istep, imin, imax, ishift + istep=1 + do imin=1,N_det, 524288 + do ishift=0,istep-1 + imax = min(N_det, imin+524288-1) + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo enddo - rc = f77_zmq_close(responder) -end subroutine + v_0 = 0.d0 + s_0 = 0.d0 - -subroutine davidson_miniserver_end() - implicit none - use f77_zmq - - integer(ZMQ_PTR) requester - character*(64) address - integer rc - character*(64) buf - - address = trim(qp_run_address)//':11223' - requester = f77_zmq_socket(zmq_context, ZMQ_REQ) - rc = f77_zmq_connect(requester,address) - - rc = f77_zmq_send(requester, "end", 3, 0) - rc = f77_zmq_recv(requester, buf, 3, 0) - rc = f77_zmq_close(requester) -end subroutine - - -subroutine davidson_miniserver_get(force_update) - implicit none - use f77_zmq - logical, intent(in) :: force_update - integer(ZMQ_PTR) requester - character*(64) address - character*(20) buffer - integer rc, update_dets - - address = trim(qp_run_address)//':11223' - - requester = f77_zmq_socket(zmq_context, ZMQ_REQ) - rc = f77_zmq_connect(requester,address) - - rc = f77_zmq_send(requester, 'ut', 2, 0) - - rc = f77_zmq_recv(requester, update_dets, 4, 0) - if (rc /= 4) then - print *, irp_here, ': f77_zmq_recv(requester, update_dets, 4, 0)' - print *, irp_here, ': rc = ', rc + call omp_set_nested(.True.) + !$OMP PARALLEL NUM_THREADS(2) PRIVATE(ithread) + ithread = omp_get_thread_num() + if (ithread == 0 ) then + call zmq_set_running(zmq_to_qp_run_socket) + call davidson_run(zmq_to_qp_run_socket, v_0, s_0, size(v_0,1)) + else + call davidson_slave_inproc(1) endif + !$OMP END PARALLEL + call end_parallel_job(zmq_to_qp_run_socket, 'davidson') - rc = f77_zmq_recv(requester, dav_size, 4, 0) - if (rc /= 4) then - print *, irp_here, ': f77_zmq_recv(requester, dav_size, 4, 0)' - print *, irp_here, ': rc = ', rc - endif - - if (update_dets == 1 .or. force_update) then - TOUCH dav_size - endif - rc = f77_zmq_recv(requester, dav_ut, 8*dav_size*N_states_diag, 0) - if (rc /= 8*dav_size*N_states_diag) then - print *, irp_here, ': f77_zmq_recv(requester, dav_ut, 8*dav_size*N_states_diag, 0)' - print *, irp_here, ': rc = ', rc - endif - SOFT_TOUCH dav_ut - if (update_dets == 1 .or. force_update) then - rc = f77_zmq_send(requester, 'det', 3, 0) - rc = f77_zmq_recv(requester, dav_size, 4, 0) - if (rc /= 4) then - print *, irp_here, ': f77_zmq_recv(requester, dav_size, 4, 0)' - print *, irp_here, ': rc = ', rc - endif - rc = f77_zmq_recv(requester, dav_det, 16*N_int*dav_size, 0) - if (rc /= 16*N_int*dav_size) then - print *, irp_here, ': f77_zmq_recv(requester, dav_det, 16*N_int*dav_size, 0)' - print *, irp_here, ': rc = ', rc - endif - SOFT_TOUCH dav_det - endif - -end subroutine - - - - BEGIN_PROVIDER [ integer(bit_kind), dav_det, (N_int, 2, dav_size) ] - use bitmasks - implicit none - BEGIN_DOC -! Temporary arrays for parallel davidson -! -! Touched in davidson_miniserver_get - END_DOC - integer :: i,k - - dav_det = 0_bit_kind -END_PROVIDER - -BEGIN_PROVIDER [ double precision, dav_ut, (N_states_diag, dav_size) ] - use bitmasks - implicit none - BEGIN_DOC -! Temporary arrays for parallel davidson -! -! Touched in davidson_miniserver_get - END_DOC - dav_ut = -huge(1.d0) -END_PROVIDER - - -BEGIN_PROVIDER [ integer, dav_size ] - implicit none - BEGIN_DOC -! Size of the arrays for Davidson -! -! Touched in davidson_miniserver_get - END_DOC - dav_size = 1 -END_PROVIDER - - - BEGIN_PROVIDER [ integer, shortcut_, (0:dav_size+1, 2) ] -&BEGIN_PROVIDER [ integer(bit_kind), version_, (N_int, dav_size, 2) ] -&BEGIN_PROVIDER [ integer(bit_kind), sorted_, (N_int, dav_size, 2) ] -&BEGIN_PROVIDER [ integer, sort_idx_, (dav_size, 2) ] -&BEGIN_PROVIDER [ integer, max_blocksize ] -implicit none - call sort_dets_ab_v(dav_det, sorted_(1,1,1), sort_idx_(1,1), shortcut_(0,1), version_(1,1,1), dav_size, N_int) - call sort_dets_ba_v(dav_det, sorted_(1,1,2), sort_idx_(1,2), shortcut_(0,2), version_(1,1,2), dav_size, N_int) - max_blocksize = max(shortcut_(0,1), shortcut_(0,2)) -END_PROVIDER - + do k=1,N_st + call dset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo +end diff --git a/src/Davidson/davidson_slave.irp.f b/src/Davidson/davidson_slave.irp.f index 4d0864e8..d0be9a37 100644 --- a/src/Davidson/davidson_slave.irp.f +++ b/src/Davidson/davidson_slave.irp.f @@ -7,7 +7,6 @@ program davidson_slave integer(ZMQ_PTR) :: zmq_to_qp_run_socket double precision :: energy(N_states_diag) character*(64) :: state - logical :: force_update call provide_everything call switch_qp_run_to_master @@ -17,21 +16,12 @@ program davidson_slave state = 'Waiting' zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - force_update = .True. do call wait_for_state(zmq_state,state) if(trim(state) /= "davidson") exit - call davidson_miniserver_get(force_update) - force_update = .False. - integer :: rc, i - print *, 'Davidson slave running' - - !$OMP PARALLEL PRIVATE(i) - i = omp_get_thread_num() call davidson_slave_tcp(i) - !$OMP END PARALLEL end do end diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 71d69e82..8754fb29 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -110,7 +110,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s character*(16384) :: write_buffer double precision :: to_print(3,N_st) double precision :: cpu, wall - integer :: shift, shift2, itermax, update_dets + integer :: shift, shift2, itermax double precision :: r1, r2 logical :: state_ok(N_st_diag*davidson_sze_max) include 'constants.include.F' @@ -211,8 +211,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s enddo - update_dets = 1 - do while (.not.converged) do k=1,N_st_diag @@ -233,11 +231,10 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s if (distributed_davidson) then - call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8,update_dets) + call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) else call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) endif - update_dets = 0 ! Compute h_kl = = @@ -641,8 +638,11 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz ! ----------------------------------------- -! call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) - call H_S2_u_0_nstates(W(1,shift+1),S(1,shift+1),U(1,shift+1),H_jj,S2_jj,sze,dets_in,Nint,N_st_diag,sze_8) + if (distributed_davidson) then + call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) + else + call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) + endif ! Compute h_kl = = diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index d8426056..a4c50a19 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -1,3 +1,38 @@ +subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) + use bitmasks + implicit none + BEGIN_DOC + ! Computes e_0 = / + ! + ! n : number of determinants + ! + END_DOC + integer, intent(in) :: n,Nint, N_st, sze_8 + double precision, intent(out) :: e_0(N_st) + double precision, intent(inout):: u_0(sze_8,N_st) + integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) + + double precision, allocatable :: v_0(:,:), s_0(:,:) + double precision :: u_dot_u,u_dot_v,diag_H_mat_elem + integer :: i,j + allocate (v_0(sze_8,N_st),s_0(sze_8,N_st)) + call H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) + do i=1,N_st + e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) + enddo + deallocate (s_0, v_0) +end + +BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] + implicit none + BEGIN_DOC +! Energy of the current wave function + END_DOC + call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) +END_PROVIDER + + + subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) use bitmasks implicit none diff --git a/src/Davidson/u0Hu0_old.irp.f b/src/Davidson/u0Hu0_old.irp.f index 60212164..42587e5b 100644 --- a/src/Davidson/u0Hu0_old.irp.f +++ b/src/Davidson/u0Hu0_old.irp.f @@ -1,32 +1,3 @@ -subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) - use bitmasks - implicit none - BEGIN_DOC - ! Computes e_0 = / - ! - ! n : number of determinants - ! - END_DOC - integer, intent(in) :: n,Nint, N_st, sze_8 - double precision, intent(out) :: e_0(N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - - double precision, allocatable :: H_jj(:), v_0(:,:) - double precision :: u_dot_u,u_dot_v,diag_H_mat_elem - integer :: i,j - allocate (H_jj(n), v_0(sze_8,N_st)) - do i = 1, n - H_jj(i) = diag_H_mat_elem(keys_tmp(1,1,i),Nint) - enddo - - call H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) - do i=1,N_st - e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) - enddo - deallocate (H_jj, v_0) -end - subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) use bitmasks @@ -254,129 +225,6 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) end -BEGIN_PROVIDER [ double precision, psi_energy, (N_states) ] - implicit none - BEGIN_DOC -! Energy of the current wave function - END_DOC - call u_0_H_u_0(psi_energy,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) -END_PROVIDER - - -subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8,update_dets) - use omp_lib - use bitmasks - use f77_zmq - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> - ! - ! n : number of determinants - ! - ! H_jj : array of - ! - ! S2_jj : array of - END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8, update_dets - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) - double precision, intent(in) :: H_jj(n), S2_jj(n) - integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) - double precision :: hij,s2 - integer :: i,j,k,l, jj,ii - integer :: i0, j0, ithread - - integer(bit_kind) :: sorted_i(Nint) - - integer :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate - integer :: N_st_8 - - integer, external :: align_double - integer :: blockb2, istep - double precision :: ave_workload, workload, target_workload_inv - - integer(ZMQ_PTR) :: handler - - if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" - N_st_8 = N_st ! align_double(N_st) - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (n>0) - PROVIDE ref_bitmask_energy - - v_0 = 0.d0 - s_0 = 0.d0 - - call davidson_init(handler,keys_tmp,u_0,size(u_0,1),n,N_st,update_dets) - - ave_workload = 0.d0 - do sh=1,shortcut_(0,1) - ave_workload += shortcut_(0,1) - ave_workload += (shortcut_(sh+1,1) - shortcut_(sh,1))**2 - do i=sh, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - ave_workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 - end do - end do - enddo - ave_workload = ave_workload/dble(shortcut_(0,1)) - target_workload_inv = 0.01d0/ave_workload - - PROVIDE nproc - - - character(len=:), allocatable :: task - task = repeat(' ', iposmax) - character(32) :: tmp_task - integer :: ipos, iposmax - iposmax = shortcut_(0,1)+32 - ipos = 1 - do sh=1,shortcut_(0,1),1 - workload = shortcut_(0,1)+dble(shortcut_(sh+1,1) - shortcut_(sh,1))**2 - do i=sh, shortcut_(0,2), shortcut_(0,1) - do j=i, min(i, shortcut_(0,2)) - workload += (shortcut_(j+1,2) - shortcut_(j, 2))**2 - end do - end do -! istep = 1+ int(workload*target_workload_inv) - istep = 1 - do blockb2=0, istep-1 - write(tmp_task,'(3(I9,1X),''|'',1X)') sh, blockb2, istep - task = task//tmp_task - ipos += 32 - if (ipos+32 > iposmax) then - call add_task_to_taskserver(handler, trim(task)) - ipos=1 - task = '' - endif - enddo - enddo - if (ipos>1) then - call add_task_to_taskserver(handler, trim(task)) - endif - - !$OMP PARALLEL NUM_THREADS(nproc+2) PRIVATE(ithread) - ithread = omp_get_thread_num() - if (ithread == 0 ) then - call zmq_set_running(handler) - call davidson_run(handler, v_0, s_0, size(v_0,1)) - else if (ithread == 1 ) then - call davidson_miniserver_run (update_dets) - else - call davidson_slave_inproc(ithread) - endif - !$OMP END PARALLEL - - call end_parallel_job(handler, 'davidson') - - do istate=1,N_st - do i=1,n - v_0(i,istate) = v_0(i,istate) + H_jj(i) * u_0(i,istate) - s_0(i,istate) = s_0(i,istate) + s2_jj(i)* u_0(i,istate) - enddo - enddo -end From 30d529aeb2c149a7be5d27cef3fed8ee0e749097 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Apr 2017 02:54:19 +0200 Subject: [PATCH 16/48] Less memory in Davdison --- src/Determinants/spindeterminants.irp.f | 848 ++++++------------------ 1 file changed, 202 insertions(+), 646 deletions(-) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 73460d0b..7c3b1bea 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -684,70 +684,105 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf integer, intent(out) :: n_singles integer, intent(out) :: n_doubles - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align + integer :: i,k,ii, imax + integer, parameter :: block_size=64 + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(block_size,N_int_max) + integer :: degree(block_size) integer, external :: align_double + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - select case (Nint) - case (1) - call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) - return - case (2) - call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - return - case (3) - call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - return - end select +! select case (Nint) +! case (1) +! call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) +! return +! case (2) +! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) +! return +! case (3) +! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) +! return +! end select - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, Nint), degree(size_buffer) ) + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=0,size_buffer-block_size, block_size + + do k=1,Nint + do ii=1,block_size + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) + enddo + enddo + + do ii=1,block_size + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) + else + degree(ii) = 0 + endif + + do k=2,Nint + !DIR$ VECTOR ALIGNED + if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + endif + enddo + enddo + + do ii=1,block_size + if ( degree(ii) == 4 ) then + doubles(n_doubles) = idx(i+ii) + n_doubles = n_doubles+1 + endif + if ( degree(ii) == 2 ) then + singles(n_singles) = idx(i+ii) + n_singles = n_singles+1 + endif + enddo + + enddo + + imax = size_buffer-i do k=1,Nint - do i=1,size_buffer - xorvec(i, k) = xor( spindet(k), buffer(k,i) ) + do ii=1,imax + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) enddo enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) + do ii=1,imax + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) else - degree(i) = 0 + degree(ii) = 0 endif - enddo - - do k=2,Nint - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,k) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,k)) + + do k=2,Nint + !DIR$ VECTOR ALIGNED + if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) endif enddo enddo - n_singles = 1 - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) + do ii=1,imax + if ( degree(ii) == 4 ) then + doubles(n_doubles) = idx(i+ii) n_doubles = n_doubles+1 endif - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) + if ( degree(ii) == 2 ) then + singles(n_singles) = idx(i+ii) n_singles = n_singles+1 endif enddo + n_singles = n_singles-1 n_doubles = n_doubles-1 - deallocate(xorvec) end @@ -767,63 +802,90 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align + integer :: i,k,ii, imax + integer, parameter :: block_size=64 + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(block_size,N_int_max) + integer :: degree(block_size) integer, external :: align_double !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - select case (Nint) - case (1) - call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) - return - case (2) - call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) - return - case (3) - call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) - return - end select +! select case (Nint) +! case (1) +! call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) +! return +! case (2) +! call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) +! return +! case (3) +! call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) +! return +! end select - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, Nint), degree(size_buffer) ) + n_singles = 1 + !DIR$ VECTOR ALIGNED + do i=0,size_buffer-block_size, block_size + + do k=1,Nint + do ii=1,block_size + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) + enddo + enddo + + do ii=1,block_size + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) + else + degree(ii) = 0 + endif + + do k=2,Nint + if ( (degree(ii) <= 2).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + endif + enddo + enddo + + do ii=1,block_size + if ( degree(ii) == 2 ) then + singles(n_singles) = idx(i+ii) + n_singles = n_singles+1 + endif + enddo + + enddo + + imax = size_buffer-i do k=1,Nint - do i=1,size_buffer - xorvec(i, k) = xor( spindet(k), buffer(k,i) ) + do ii=1,imax + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) enddo enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) + do ii=1,imax + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) else - degree(i) = 0 + degree(ii) = 0 endif - enddo - do k=2,Nint - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 2).and.(xorvec(i,k) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,k)) + do k=2,Nint + if ( (degree(ii) <= 2).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) endif enddo enddo - n_singles = 1 - do i=1,size_buffer - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) + do ii=1,imax + if ( degree(ii) == 2 ) then + singles(n_singles) = idx(i+ii) n_singles = n_singles+1 endif enddo n_singles = n_singles-1 - deallocate(xorvec, degree) end @@ -843,604 +905,98 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles integer, intent(out) :: doubles(size_buffer) integer, intent(out) :: n_doubles - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double + integer :: i,k,ii, imax + integer, parameter :: block_size=64 + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(block_size,N_int_max) + integer :: degree(block_size) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - select case (Nint) - case (1) - call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) - return - case (2) - call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) - return - case (3) - call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) - return - end select +! select case (Nint) +! case (1) +! call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) +! return +! case (2) +! call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) +! return +! case (3) +! call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) +! return +! end select - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, Nint), degree(size_buffer) ) + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=0,size_buffer-block_size, block_size + + do k=1,Nint + do ii=1,block_size + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) + enddo + enddo + + do ii=1,block_size + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) + else + degree(ii) = 0 + endif + + do k=2,Nint + !DIR$ VECTOR ALIGNED + if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + endif + enddo + enddo + + do ii=1,block_size + if ( degree(ii) == 4 ) then + doubles(n_doubles) = idx(i+ii) + n_doubles = n_doubles+1 + endif + enddo + + enddo + + imax = size_buffer-i do k=1,Nint - do i=1,size_buffer - xorvec(i, k) = xor( spindet(k), buffer(k,i) ) + do ii=1,imax + xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) enddo enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) + do ii=1,imax + if (xorvec(ii,1) /= 0_8) then + degree(ii) = popcnt(xorvec(ii,1)) else - degree(i) = 0 + degree(ii) = 0 endif - enddo - - do k=2,Nint - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,k) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,k)) + + do k=2,Nint + !DIR$ VECTOR ALIGNED + if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then + degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) endif enddo enddo - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) + do ii=1,imax + if ( degree(ii) == 4 ) then + doubles(n_doubles) = idx(i+ii) n_doubles = n_doubles+1 endif enddo + n_doubles = n_doubles-1 - deallocate(xorvec) -end - -subroutine get_all_spin_singles_and_doubles_1(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single and double excitations in the list of -! unique alpha determinants. -! -! /!\ : The buffer is transposed ! -! - END_DOC - integer, intent(in) :: size_buffer - integer, intent(in) :: idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(size_buffer) - integer(bit_kind), intent(in) :: spindet - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_singles - integer, intent(out) :: n_doubles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:) - integer :: degree - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align) ) - - do i=1,size_buffer - xorvec(i) = xor( spindet, buffer(i) ) - enddo - - n_singles = 1 - n_doubles = 1 - - do i=1,size_buffer - degree = popcnt(xorvec(i)) - if ( degree == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - if ( degree == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - n_doubles = n_doubles-1 - - deallocate(xorvec) -end - - -subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_singles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(size_buffer) - integer(bit_kind), intent(in) :: spindet - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: n_singles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:) - - allocate( xorvec(size_buffer) ) - - do i=1,size_buffer - xorvec(i) = xor( spindet, buffer(i) ) - enddo - - n_singles = 1 - do i=1,size_buffer - if ( popcnt(xorvec(i)) == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - deallocate(xorvec) end -subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the double excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(size_buffer) - integer(bit_kind), intent(in) :: spindet - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_doubles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:) - - integer, external :: align_double - - allocate( xorvec(size_buffer) ) - - do i=1,size_buffer - xorvec(i) = xor( spindet, buffer(i) ) - enddo - - n_doubles = 1 - - do i=1,size_buffer - if ( popcnt(xorvec(i)) == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - enddo - n_doubles = n_doubles-1 - deallocate(xorvec) - -end -subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single and double excitations in the list of -! unique alpha determinants. -! -! /!\ : The buffer is transposed ! -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_singles - integer, intent(out) :: n_doubles - - integer :: i - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 2), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - - n_singles = 1 - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - n_doubles = n_doubles-1 - deallocate(xorvec) - -end - - -subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: n_singles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 2), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 2).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - - n_singles = 1 - do i=1,size_buffer - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - deallocate(xorvec) - -end - - -subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the double excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_doubles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 2), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - enddo - n_doubles = n_doubles-1 - deallocate(xorvec) - -end - -subroutine get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single and double excitations in the list of -! unique alpha determinants. -! -! /!\ : The buffer is transposed ! -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(3,size_buffer) - integer(bit_kind), intent(in) :: spindet(3) - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_singles - integer, intent(out) :: n_doubles - - integer :: i - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 3), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - xorvec(i, 3) = xor( spindet(3), buffer(3,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,3) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,3)) - endif - enddo - - n_singles = 1 - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - n_doubles = n_doubles-1 - deallocate(xorvec) - -end - - -subroutine get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the single excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(3,size_buffer) - integer(bit_kind), intent(in) :: spindet(3) - integer, intent(out) :: singles(size_buffer) - integer, intent(out) :: n_singles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 3), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - xorvec(i, 3) = xor( spindet(3), buffer(3,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 2).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 2).and.(xorvec(i,3) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,3)) - endif - enddo - - n_singles = 1 - do i=1,size_buffer - if ( degree(i) == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - enddo - n_singles = n_singles-1 - deallocate(xorvec) - -end - - -subroutine get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) - use bitmasks - implicit none - BEGIN_DOC -! -! Returns the indices of all the double excitations in the list of -! unique alpha determinants. -! - END_DOC - integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(3,size_buffer) - integer(bit_kind), intent(in) :: spindet(3) - integer, intent(out) :: doubles(size_buffer) - integer, intent(out) :: n_doubles - - integer :: i,k - integer(bit_kind), allocatable :: xorvec(:,:) - integer, allocatable :: degree(:) - integer :: size_buffer_align - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - - size_buffer_align = align_double(size_buffer) - allocate( xorvec(size_buffer_align, 3), degree(size_buffer) ) - - do i=1,size_buffer - xorvec(i, 1) = xor( spindet(1), buffer(1,i) ) - xorvec(i, 2) = xor( spindet(2), buffer(2,i) ) - xorvec(i, 3) = xor( spindet(3), buffer(3,i) ) - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if (xorvec(i,1) /= 0_8) then - degree(i) = popcnt(xorvec(i,1)) - else - degree(i) = 0 - endif - enddo - - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,2) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,2)) - endif - enddo - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - if ( (degree(i) <= 4).and.(xorvec(i,3) /= 0_8) ) then - degree(i) = degree(i) + popcnt(xorvec(i,3)) - endif - enddo - - n_doubles = 1 - do i=1,size_buffer - if ( degree(i) == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - enddo - n_doubles = n_doubles-1 - deallocate(xorvec) - -end subroutine copy_psi_bilinear_to_psi(psi, isize) implicit none From dc2481c96622c35959dc4fd94912251a429befc4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Apr 2017 03:58:02 +0200 Subject: [PATCH 17/48] Less memory in Davdison --- src/Determinants/spindeterminants.irp.f | 218 ++++++------------------ 1 file changed, 56 insertions(+), 162 deletions(-) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 7c3b1bea..4f71090b 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -410,6 +410,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) integer, external :: get_index_in_psi_det_alpha_unique integer, external :: get_index_in_psi_det_beta_unique allocate(to_sort(N_det)) + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k,l) do k=1,N_det i = get_index_in_psi_det_alpha_unique(psi_det(1,1,k),N_int) j = get_index_in_psi_det_beta_unique (psi_det(1,2,k),N_int) @@ -422,6 +423,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_values, (N_det,N_states) to_sort(k) = int(N_det_alpha_unique,8) * int(j-1,8) + int(i,8) psi_bilinear_matrix_order(k) = k enddo + !$OMP END PARALLEL DO call i8sort(to_sort, psi_bilinear_matrix_order, N_det) call iset_order(psi_bilinear_matrix_rows,psi_bilinear_matrix_order,N_det) call iset_order(psi_bilinear_matrix_columns,psi_bilinear_matrix_order,N_det) @@ -439,9 +441,11 @@ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_reverse , (N_det) ] ! Order which allors to go from psi_bilinear_matrix to psi_det END_DOC integer :: k + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(k) do k=1,N_det psi_bilinear_matrix_order_reverse(psi_bilinear_matrix_order(k)) = k enddo + !$OMP END PARALLEL DO END_PROVIDER @@ -491,11 +495,15 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ integer*8, allocatable :: to_sort(:) allocate(to_sort(N_det)) + !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l) + !$OMP DO COLLAPSE(2) do l=1,N_states do k=1,N_det psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l) enddo enddo + !$OMP ENDDO + !$OMP DO do k=1,N_det psi_bilinear_matrix_transp_columns(k) = psi_bilinear_matrix_columns(k) psi_bilinear_matrix_transp_rows (k) = psi_bilinear_matrix_rows (k) @@ -504,6 +512,8 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ to_sort(k) = int(N_det_beta_unique,8) * int(j-1,8) + int(i,8) psi_bilinear_matrix_transp_order(k) = k enddo + !$OMP ENDDO + !$OMP END PARALLEL call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det) call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) @@ -542,9 +552,11 @@ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] END_DOC integer :: k + !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(k) do k=1,N_det psi_bilinear_matrix_order_transp_reverse(psi_bilinear_matrix_transp_order(k)) = k enddo + !$OMP END PARALLEL DO END_PROVIDER @@ -684,11 +696,10 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf integer, intent(out) :: n_singles integer, intent(out) :: n_doubles - integer :: i,k,ii, imax - integer, parameter :: block_size=64 + integer :: i,k include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(block_size,N_int_max) - integer :: degree(block_size) + integer(bit_kind) :: xorvec(N_int_max) + integer :: degree integer, external :: align_double @@ -711,76 +722,34 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf n_singles = 1 n_doubles = 1 !DIR$ VECTOR ALIGNED - do i=0,size_buffer-block_size, block_size + do i=1,size_buffer do k=1,Nint - do ii=1,block_size - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo + xorvec(k) = xor( spindet(k), buffer(k,i) ) enddo - do ii=1,block_size - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) - else - degree(ii) = 0 - endif - - do k=2,Nint - !DIR$ VECTOR ALIGNED - if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) - endif - enddo - enddo - - do ii=1,block_size - if ( degree(ii) == 4 ) then - doubles(n_doubles) = idx(i+ii) - n_doubles = n_doubles+1 - endif - if ( degree(ii) == 2 ) then - singles(n_singles) = idx(i+ii) - n_singles = n_singles+1 - endif - enddo - - enddo - - imax = size_buffer-i - - do k=1,Nint - do ii=1,imax - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo - enddo - - do ii=1,imax - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) else - degree(ii) = 0 + degree = 0 endif do k=2,Nint !DIR$ VECTOR ALIGNED - if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) endif enddo - enddo - do ii=1,imax - if ( degree(ii) == 4 ) then - doubles(n_doubles) = idx(i+ii) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) n_doubles = n_doubles+1 - endif - if ( degree(ii) == 2 ) then - singles(n_singles) = idx(i+ii) + else if ( degree == 2 ) then + singles(n_singles) = idx(i) n_singles = n_singles+1 endif - enddo + enddo n_singles = n_singles-1 n_doubles = n_doubles-1 @@ -802,15 +771,14 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i,k,ii, imax - integer, parameter :: block_size=64 + integer :: i,k include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(block_size,N_int_max) - integer :: degree(block_size) + integer(bit_kind) :: xorvec(N_int_max) + integer :: degree integer, external :: align_double - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec ! select case (Nint) ! case (1) @@ -826,64 +794,29 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles n_singles = 1 !DIR$ VECTOR ALIGNED - do i=0,size_buffer-block_size, block_size + do i=1,size_buffer do k=1,Nint - do ii=1,block_size - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo + xorvec(k) = xor( spindet(k), buffer(k,i) ) enddo - do ii=1,block_size - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) - else - degree(ii) = 0 - endif - - do k=2,Nint - if ( (degree(ii) <= 2).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) - endif - enddo - enddo - - do ii=1,block_size - if ( degree(ii) == 2 ) then - singles(n_singles) = idx(i+ii) - n_singles = n_singles+1 - endif - enddo - - enddo - - imax = size_buffer-i - - do k=1,Nint - do ii=1,imax - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo - enddo - - do ii=1,imax - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) else - degree(ii) = 0 + degree = 0 endif do k=2,Nint - if ( (degree(ii) <= 2).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) endif enddo - enddo - do ii=1,imax - if ( degree(ii) == 2 ) then - singles(n_singles) = idx(i+ii) - n_singles = n_singles+1 + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 endif + enddo n_singles = n_singles-1 @@ -905,13 +838,11 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles integer, intent(out) :: doubles(size_buffer) integer, intent(out) :: n_doubles - integer :: i,k,ii, imax - integer, parameter :: block_size=64 + integer :: i,k, degree include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(block_size,N_int_max) - integer :: degree(block_size) + integer(bit_kind) :: xorvec(N_int_max) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec ! select case (Nint) ! case (1) @@ -927,71 +858,34 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles n_doubles = 1 !DIR$ VECTOR ALIGNED - do i=0,size_buffer-block_size, block_size + do i=1,size_buffer do k=1,Nint - do ii=1,block_size - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo + xorvec(k) = xor( spindet(k), buffer(k,i) ) enddo - do ii=1,block_size - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) - else - degree(ii) = 0 - endif - - do k=2,Nint - !DIR$ VECTOR ALIGNED - if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) - endif - enddo - enddo - - do ii=1,block_size - if ( degree(ii) == 4 ) then - doubles(n_doubles) = idx(i+ii) - n_doubles = n_doubles+1 - endif - enddo - - enddo - - imax = size_buffer-i - - do k=1,Nint - do ii=1,imax - xorvec(ii, k) = xor( spindet(k), buffer(k,ii+i) ) - enddo - enddo - - do ii=1,imax - if (xorvec(ii,1) /= 0_8) then - degree(ii) = popcnt(xorvec(ii,1)) + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) else - degree(ii) = 0 + degree = 0 endif do k=2,Nint !DIR$ VECTOR ALIGNED - if ( (degree(ii) <= 4).and.(xorvec(ii,k) /= 0_8) ) then - degree(ii) = degree(ii) + popcnt(xorvec(ii,k)) + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) endif enddo - enddo - do ii=1,imax - if ( degree(ii) == 4 ) then - doubles(n_doubles) = idx(i+ii) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) n_doubles = n_doubles+1 endif + enddo n_doubles = n_doubles-1 - end @@ -1037,7 +931,7 @@ BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_uniq !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(singles_alpha, N_det_alpha_unique, psi_det_alpha_unique, & !$OMP idx0, N_int) & - !$OMP PRIVATE(i) + !$OMP PRIVATE(i) SCHEDULE(static,1) do i=1, N_det_alpha_unique call get_all_spin_singles( & psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & From fd882fc0c9db1b36c6b46bf38babad500c9dd941 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Apr 2017 22:55:59 +0200 Subject: [PATCH 18/48] Radix sort for negative numbers --- src/Determinants/spindeterminants.irp.f | 8 +- src/Utils/sort.irp.f | 144 ++++++++++++++++++------ 2 files changed, 112 insertions(+), 40 deletions(-) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 4f71090b..5ed7fa74 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -64,9 +64,9 @@ BEGIN_TEMPLATE integer :: i,j,k integer, allocatable :: iorder(:) - integer(8), allocatable :: bit_tmp(:) - integer(8) :: last_key - integer(8), external :: spin_det_search_key + integer*8, allocatable :: bit_tmp(:) + integer*8 :: last_key + integer*8, external :: spin_det_search_key logical,allocatable :: duplicate(:) allocate ( iorder(N_det), bit_tmp(N_det), duplicate(N_det) ) @@ -514,7 +514,7 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_ enddo !$OMP ENDDO !$OMP END PARALLEL - call i8sort(to_sort, psi_bilinear_matrix_transp_order, N_det) + call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1) call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det) call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det) do l=1,N_states diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index fa3ca382..ba27c0f7 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -186,6 +186,15 @@ BEGIN_TEMPLATE end +SUBST [ X, type ] + ; real ;; + d ; double precision ;; + i ; integer ;; + i8 ; integer*8 ;; + i2 ; integer*2 ;; +END_TEMPLATE + +BEGIN_TEMPLATE subroutine $Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -208,6 +217,24 @@ BEGIN_TEMPLATE SUBST [ X, type ] ; real ;; d ; double precision ;; +END_TEMPLATE + +BEGIN_TEMPLATE + subroutine $Xsort(x,iorder,isize) + implicit none + BEGIN_DOC + ! Sort array x(isize). + ! iorder in input should be (1,2,3,...,isize), and in output + ! contains the new order of the elements. + END_DOC + integer,intent(in) :: isize + $type,intent(inout) :: x(isize) + integer,intent(inout) :: iorder(isize) + integer :: n + call $Xradix_sort(x,iorder,isize,-1) + end subroutine $Xsort + +SUBST [ X, type ] i ; integer ;; i8 ; integer*8 ;; i2 ; integer*2 ;; @@ -328,33 +355,78 @@ BEGIN_TEMPLATE integer, intent(in) :: iradix integer :: iradix_new integer*$type, allocatable :: x2(:), x1(:) - integer*$type :: i4 + integer*$type :: i4 ! data type integer*$int_type, allocatable :: iorder1(:),iorder2(:) - integer*$int_type :: i0, i1, i2, i3, i - integer, parameter :: integer_size=$octets + integer*$int_type :: i0, i1, i2, i3, i ! index type integer*$type :: mask - integer :: nthreads, omp_get_num_threads + integer :: err !DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 - if (iradix == -1) then + if (iradix == -1) then ! Sort Positive and negative + + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to allocate arrays' + stop + endif + + i1=1_$int_type + i2=1_$int_type + do i=1_$int_type,isize + if (x(i) < 0_$type) then + iorder1(i1) = iorder(i) + x1(i1) = -x(i) + i1 = i1+1_$int_type + else + iorder2(i2) = iorder(i) + x2(i2) = x(i) + i2 = i2+1_$int_type + endif + enddo + i1=i1-1_$int_type + i2=i2-1_$int_type + + do i=1_$int_type,i2 + iorder(i1+i) = iorder2(i) + x(i1+i) = x2(i) + enddo + deallocate(x2,iorder2,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x2, iorder2' + stop + endif + + + if (i1 > 1_$int_type) then + call $Xradix_sort$big(x1,iorder1,i1,-2) + do i=1_$int_type,i1 + x(i) = -x1(1_$int_type+i1-i) + iorder(i) = iorder1(1_$int_type+i1-i) + enddo + endif + deallocate(x1,iorder1,stat=err) + if (err /= 0) then + print *, irp_here, ': Unable to deallocate arrays x1, iorder1' + stop + endif + + if (i2>1_$int_type) then + call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2) + endif + + return + + else if (iradix == -2) then ! Positive ! Find most significant bit i0 = 0_$int_type - i4 = -1_$type + i4 = maxval(x) - do i=1,isize - i4 = max(i4,x(i)) - enddo - i3 = int(i4,$int_type) - - iradix_new = integer_size-1-leadz(i3) + iradix_new = $integer_size-1-leadz(i4) mask = ibset(0_$type,iradix_new) - nthreads = 1 - ! nthreads = 1+ishft(omp_get_num_threads(),-1) - integer :: err - allocate(x1(isize/nthreads+1),iorder1(isize/nthreads+1),x2(isize/nthreads+1),iorder2(isize/nthreads+1),stat=err) + allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) if (err /= 0) then print *, irp_here, ': Unable to allocate arrays' stop @@ -363,7 +435,7 @@ BEGIN_TEMPLATE i1=1_$int_type i2=1_$int_type - do i=1,isize + do i=1_$int_type,isize if (iand(mask,x(i)) == 0_$type) then iorder1(i1) = iorder(i) x1(i1) = x(i) @@ -377,7 +449,7 @@ BEGIN_TEMPLATE i1=i1-1_$int_type i2=i2-1_$int_type - do i=1,i1 + do i=1_$int_type,i1 iorder(i0+i) = iorder1(i) x(i0+i) = x1(i) enddo @@ -390,7 +462,7 @@ BEGIN_TEMPLATE endif - do i=1,i2 + do i=1_$int_type,i2 iorder(i0+i) = iorder2(i) x(i0+i) = x2(i) enddo @@ -402,12 +474,12 @@ BEGIN_TEMPLATE endif - if (i3>1) then + if (i3>1_$int_type) then call $Xradix_sort$big(x,iorder,i3,iradix_new-1) endif - if (isize-i3>1) then - call $Xradix_sort$big(x(i3+1),iorder(i3+1),isize-i3,iradix_new-1) + if (isize-i3>1_$int_type) then + call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1) endif return @@ -429,24 +501,24 @@ BEGIN_TEMPLATE mask = ibset(0_$type,iradix) - i0=1 - i1=1 + i0=1_$int_type + i1=1_$int_type - do i=1,isize + do i=1_$int_type,isize if (iand(mask,x(i)) == 0_$type) then iorder(i0) = iorder(i) x(i0) = x(i) - i0 = i0+1 + i0 = i0+1_$int_type else iorder2(i1) = iorder(i) x2(i1) = x(i) - i1 = i1+1 + i1 = i1+1_$int_type endif enddo - i0=i0-1 - i1=i1-1 + i0=i0-1_$int_type + i1=i1-1_$int_type - do i=1,i1 + do i=1_$int_type,i1 iorder(i0+i) = iorder2(i) x(i0+i) = x2(i) enddo @@ -463,8 +535,8 @@ BEGIN_TEMPLATE endif - if (i1>1) then - call $Xradix_sort$big(x(i0+1),iorder(i0+1),i1,iradix-1) + if (i1>1_$int_type) then + call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1) endif if (i0>1) then call $Xradix_sort$big(x,iorder,i0,iradix-1) @@ -472,11 +544,11 @@ BEGIN_TEMPLATE end -SUBST [ X, type, octets, is_big, big, int_type ] +SUBST [ X, type, integer_size, is_big, big, int_type ] i ; 4 ; 32 ; .False. ; ; 4 ;; - i8 ; 8 ; 32 ; .False. ; ; 4 ;; - i2 ; 2 ; 32 ; .False. ; ; 4 ;; - i ; 4 ; 64 ; .True. ; _big ; 8 ;; + i8 ; 8 ; 64 ; .False. ; ; 4 ;; + i2 ; 2 ; 16 ; .False. ; ; 4 ;; + i ; 4 ; 32 ; .True. ; _big ; 8 ;; i8 ; 8 ; 64 ; .True. ; _big ; 8 ;; END_TEMPLATE From 9e454d267b9eb406015886d61d13ad59d40d0d03 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 00:01:31 +0200 Subject: [PATCH 19/48] CSC storage for singles alpha --- src/Davidson/u0Hu0.irp.f | 11 +- src/Determinants/spindeterminants.irp.f | 366 ++++++++++++++++++++++-- 2 files changed, 347 insertions(+), 30 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index a4c50a19..eb60f1d8 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -129,7 +129,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP psi_bilinear_matrix_transp_columns, & !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & - !$OMP singles_alpha, psi_bilinear_matrix_columns_loc, & + !$OMP singles_alpha_csc, singles_alpha_csc_idx, & + !$OMP psi_bilinear_matrix_columns_loc, & !$OMP singles_alpha_size, sze_8, istart, iend, istep, & !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & @@ -164,8 +165,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif 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) - do k=1,singles_alpha(0,krow) - is_single_a( singles_alpha(k,krow) ) = .True. + do k=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 + is_single_a( singles_alpha_csc(k) ) = .True. enddo if (kcol /= kcol_prev) then @@ -208,8 +209,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif l_a = l_a+1 enddo enddo - do k=1,singles_alpha(0,krow) - is_single_a( singles_alpha(k,krow) ) = .False. + do k=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 + is_single_a( singles_alpha_csc(k) ) = .False. enddo enddo diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 5ed7fa74..2f0e7330 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -706,17 +706,17 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree -! select case (Nint) -! case (1) -! call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) -! return + select case (Nint) + case (1) + call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) + return ! case (2) ! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) ! return ! case (3) ! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) ! return -! end select + end select n_singles = 1 @@ -780,17 +780,17 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec -! select case (Nint) -! case (1) -! call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) -! return + select case (Nint) + case (1) + call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) + return ! case (2) ! call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) ! return ! case (3) ! call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) ! return -! end select + end select n_singles = 1 !DIR$ VECTOR ALIGNED @@ -807,7 +807,7 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles endif do k=2,Nint - if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + if ( (degree <= 2).and.(xorvec(k) /= 0_8) ) then degree = degree + popcnt(xorvec(k)) endif enddo @@ -844,17 +844,17 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec -! select case (Nint) -! case (1) -! call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) -! return -! case (2) -! call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) -! return + select case (Nint) + case (1) + call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) + return + case (2) + call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) + return ! case (3) ! call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) ! return -! end select + end select n_doubles = 1 !DIR$ VECTOR ALIGNED @@ -916,12 +916,49 @@ BEGIN_PROVIDER [ integer, singles_alpha_size ] singles_alpha_size = elec_alpha_num * (mo_tot_num - elec_alpha_num) END_PROVIDER -BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_unique) ] + BEGIN_PROVIDER [ integer, singles_alpha_csc_idx, (N_det_alpha_unique+1) ] +&BEGIN_PROVIDER [ integer, singles_alpha_csc_size ] implicit none BEGIN_DOC ! Dimension of the singles_alpha array END_DOC integer :: i + integer, allocatable :: idx0(:), s(:) + allocate (idx0(N_det_alpha_unique)) + do i=1, N_det_alpha_unique + idx0(i) = i + enddo + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, & + !$OMP singles_alpha_size, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,s) + allocate (s(singles_alpha_size)) + !$OMP DO SCHEDULE(static,1) + do i=1, N_det_alpha_unique + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & + N_det_alpha_unique, s, singles_alpha_csc_idx(i+1)) + enddo + !$OMP END DO + deallocate(s) + !$OMP END PARALLEL + deallocate(idx0) + + do i=2, N_det_alpha_unique+1 + singles_alpha_csc_idx(i) = singles_alpha_csc_idx(i) + singles_alpha_csc_idx(i-1) + enddo + singles_alpha_csc_size = singles_alpha_csc_idx(N_det_alpha_unique+1) +END_PROVIDER + + +BEGIN_PROVIDER [ integer, singles_alpha_csc, (singles_alpha_csc_size) ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + integer :: i, k integer, allocatable :: idx0(:) allocate (idx0(N_det_alpha_unique)) do i=1, N_det_alpha_unique @@ -929,16 +966,295 @@ BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_uniq enddo !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(singles_alpha, N_det_alpha_unique, psi_det_alpha_unique, & - !$OMP idx0, N_int) & - !$OMP PRIVATE(i) SCHEDULE(static,1) + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,k) SCHEDULE(static,1) do i=1, N_det_alpha_unique call get_all_spin_singles( & psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & - N_det_alpha_unique, singles_alpha(1,i), singles_alpha(0,i)) + N_det_alpha_unique, singles_alpha_csc(singles_alpha_csc_idx(i)), & + k) enddo !$OMP END PARALLEL DO - deallocate(idx0) + END_PROVIDER + + + +subroutine get_all_spin_singles_and_doubles_1(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt( xor( spindet, buffer(i) ) ) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + + +subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + n_singles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + enddo + n_doubles = n_doubles-1 + +end + + + + +subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + integer :: degree + + integer, external :: align_double + + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree + + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + +subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + + integer :: i + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + integer :: degree + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + + n_singles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + if (degree > 2) cycle + + if ( xorvec(2) /= 0_8 ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + + integer :: i, degree + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + + enddo + + n_doubles = n_doubles-1 + +end + From a8885648515c08cb2a2671b66bbeeb37d2e41c7b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 00:01:31 +0200 Subject: [PATCH 20/48] CSC storage for singles alpha --- src/Davidson/u0Hu0.irp.f | 14 +- src/Determinants/spindeterminants.irp.f | 370 ++++++++++++++++++++++-- 2 files changed, 352 insertions(+), 32 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index a4c50a19..b963cf32 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -107,6 +107,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) integer :: maxab, n_singles_a, kcol_prev, nmax + integer*8 :: k8 double precision, allocatable :: v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t @@ -129,14 +130,15 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP psi_bilinear_matrix_transp_columns, & !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & - !$OMP singles_alpha, psi_bilinear_matrix_columns_loc, & + !$OMP singles_alpha_csc, singles_alpha_csc_idx, & + !$OMP psi_bilinear_matrix_columns_loc, & !$OMP singles_alpha_size, sze_8, istart, iend, istep, & !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, is_single_a,l_a, l_b, nmax, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & - !$OMP singles_a, n_singles_a, s_t) + !$OMP singles_a, n_singles_a, s_t, k8) ! Alpha/Beta double excitations ! ============================= @@ -164,8 +166,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif 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) - do k=1,singles_alpha(0,krow) - is_single_a( singles_alpha(k,krow) ) = .True. + do k8=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 + is_single_a( singles_alpha_csc(k8) ) = .True. enddo if (kcol /= kcol_prev) then @@ -208,8 +210,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif l_a = l_a+1 enddo enddo - do k=1,singles_alpha(0,krow) - is_single_a( singles_alpha(k,krow) ) = .False. + do k8=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 + is_single_a( singles_alpha_csc(k8) ) = .False. enddo enddo diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 5ed7fa74..8a5350e6 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -706,17 +706,17 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree -! select case (Nint) -! case (1) -! call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) -! return + select case (Nint) + case (1) + call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) + return ! case (2) ! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) ! return ! case (3) ! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) ! return -! end select + end select n_singles = 1 @@ -780,17 +780,17 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec -! select case (Nint) -! case (1) -! call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) -! return + select case (Nint) + case (1) + call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) + return ! case (2) ! call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) ! return ! case (3) ! call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) ! return -! end select + end select n_singles = 1 !DIR$ VECTOR ALIGNED @@ -807,7 +807,7 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles endif do k=2,Nint - if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + if ( (degree <= 2).and.(xorvec(k) /= 0_8) ) then degree = degree + popcnt(xorvec(k)) endif enddo @@ -844,17 +844,17 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec -! select case (Nint) -! case (1) -! call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) -! return -! case (2) -! call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) -! return + select case (Nint) + case (1) + call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) + return + case (2) + call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) + return ! case (3) ! call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) ! return -! end select + end select n_doubles = 1 !DIR$ VECTOR ALIGNED @@ -916,12 +916,51 @@ BEGIN_PROVIDER [ integer, singles_alpha_size ] singles_alpha_size = elec_alpha_num * (mo_tot_num - elec_alpha_num) END_PROVIDER -BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_unique) ] + BEGIN_PROVIDER [ integer*8, singles_alpha_csc_idx, (N_det_alpha_unique+1) ] +&BEGIN_PROVIDER [ integer*8, singles_alpha_csc_size ] implicit none BEGIN_DOC ! Dimension of the singles_alpha array END_DOC - integer :: i + integer :: i,j + integer, allocatable :: idx0(:), s(:) + allocate (idx0(N_det_alpha_unique)) + do i=1, N_det_alpha_unique + idx0(i) = i + enddo + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, & + !$OMP singles_alpha_size, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,s,j) + allocate (s(singles_alpha_size)) + !$OMP DO SCHEDULE(static,1) + do i=1, N_det_alpha_unique + call get_all_spin_singles( & + psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & + N_det_alpha_unique, s, j) + singles_alpha_csc_idx(i+1) = int(j,8) + enddo + !$OMP END DO + deallocate(s) + !$OMP END PARALLEL + deallocate(idx0) + + singles_alpha_csc_idx(1) = 1_8 + do i=2, N_det_alpha_unique+1 + singles_alpha_csc_idx(i) = singles_alpha_csc_idx(i) + singles_alpha_csc_idx(i-1) + enddo + singles_alpha_csc_size = singles_alpha_csc_idx(N_det_alpha_unique+1) +END_PROVIDER + + +BEGIN_PROVIDER [ integer, singles_alpha_csc, (singles_alpha_csc_size) ] + implicit none + BEGIN_DOC + ! Dimension of the singles_alpha array + END_DOC + integer :: i, k integer, allocatable :: idx0(:) allocate (idx0(N_det_alpha_unique)) do i=1, N_det_alpha_unique @@ -929,16 +968,295 @@ BEGIN_PROVIDER [ integer, singles_alpha, (0:singles_alpha_size, N_det_alpha_uniq enddo !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(singles_alpha, N_det_alpha_unique, psi_det_alpha_unique, & - !$OMP idx0, N_int) & - !$OMP PRIVATE(i) SCHEDULE(static,1) + !$OMP SHARED(N_det_alpha_unique, psi_det_alpha_unique, & + !$OMP idx0, N_int, singles_alpha_csc, singles_alpha_csc_idx) & + !$OMP PRIVATE(i,k) SCHEDULE(static,1) do i=1, N_det_alpha_unique call get_all_spin_singles( & psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & - N_det_alpha_unique, singles_alpha(1,i), singles_alpha(0,i)) + N_det_alpha_unique, singles_alpha_csc(singles_alpha_csc_idx(i)), & + k) enddo !$OMP END PARALLEL DO - deallocate(idx0) + END_PROVIDER + + + +subroutine get_all_spin_singles_and_doubles_1(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt( xor( spindet, buffer(i) ) ) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + + +subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + n_singles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_1(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(size_buffer) + integer(bit_kind), intent(in) :: spindet + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + integer :: i + include 'Utils/constants.include.F' + integer :: degree + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + degree = popcnt(xor( spindet, buffer(i) )) + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + enddo + n_doubles = n_doubles-1 + +end + + + + +subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single and double excitations in the list of +! unique alpha determinants. +! +! /!\ : The buffer is transposed ! +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_singles + integer, intent(out) :: n_doubles + + integer :: i + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + integer :: degree + + integer, external :: align_double + + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree + + n_singles = 1 + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + else if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + n_doubles = n_doubles-1 + +end + + +subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the single excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: singles(size_buffer) + integer, intent(out) :: n_singles + + integer :: i + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + integer :: degree + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + + n_singles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + if (degree > 2) cycle + + if ( xorvec(2) /= 0_8 ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 2 ) then + singles(n_singles) = idx(i) + n_singles = n_singles+1 + endif + + enddo + n_singles = n_singles-1 + +end + + +subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) + use bitmasks + implicit none + BEGIN_DOC +! +! Returns the indices of all the double excitations in the list of +! unique alpha determinants. +! + END_DOC + integer, intent(in) :: size_buffer, idx(size_buffer) + integer(bit_kind), intent(in) :: buffer(2,size_buffer) + integer(bit_kind), intent(in) :: spindet(2) + integer, intent(out) :: doubles(size_buffer) + integer, intent(out) :: n_doubles + + integer :: i, degree + include 'Utils/constants.include.F' + integer(bit_kind) :: xorvec(2) + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + + n_doubles = 1 + !DIR$ VECTOR ALIGNED + do i=1,size_buffer + + xorvec(1) = xor( spindet(1), buffer(1,i) ) + xorvec(2) = xor( spindet(2), buffer(2,i) ) + + if (xorvec(1) /= 0_8) then + degree = popcnt(xorvec(1)) + else + degree = 0 + endif + + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then + degree = degree + popcnt(xorvec(2)) + endif + + if ( degree == 4 ) then + doubles(n_doubles) = idx(i) + n_doubles = n_doubles+1 + endif + + enddo + + n_doubles = n_doubles-1 + +end + From fd2f7f3447aac266c0a36175c271afc63e557324 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 00:32:22 +0200 Subject: [PATCH 21/48] Changed defaults in Davidson --- src/Davidson/EZFIO.cfg | 4 ++-- src/Davidson/diagonalization_hs2.irp.f | 10 ++++++---- src/Determinants/spindeterminants.irp.f | 1 + 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 20113732..49a0f778 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -7,13 +7,13 @@ default: 1.e-12 [n_states_diag] type: States_number doc: Number of states to consider during the Davdison diagonalization -default: 10 +default: 4 interface: ezfio,provider,ocaml [davidson_sze_max] type: Strictly_positive_int doc: Number of micro-iterations before re-contracting -default: 10 +default: 8 interface: ezfio,provider,ocaml [state_following] diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 8754fb29..535eddad 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -126,7 +126,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s sze_8 = align_double(sze) itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) - PROVIDE nuclear_repulsion expected_s2 + PROVIDE nuclear_repulsion expected_s2 singles_alpha_csc call write_time(iunit) call wall_time(wall) @@ -138,8 +138,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call write_int(iunit,N_st,'Number of states') call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') - r1 = 8.d0*(3.d0*dble(sze_8*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & - + 4.d0*(N_st_diag*itermax))/(1024.d0**3)) + r1 = 8.d0*(size(singles_alpha_csc)+3.d0*dble(sze_8*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & + + 4.d0*(N_st_diag*itermax)+nproc*(4.d0*N_det_alpha_unique+2.d0*N_st_diag*sze_8)))/(1024.d0**3) call write_double(iunit, r1, 'Memory(Gb)') write(iunit,'(A)') '' write_buffer = '===== ' @@ -452,6 +452,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s y, s_, s_tmp, & lambda & ) + FREE singles_alpha_csc end subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) @@ -519,7 +520,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz stop -1 endif - PROVIDE nuclear_repulsion expected_s2 + PROVIDE nuclear_repulsion expected_s2 singles_alpha_csc call write_time(iunit) call wall_time(wall) @@ -891,5 +892,6 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz y, s_, s_tmp, & lambda & ) + FREE singles_alpha_csc end diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 1768bac3..8a5350e6 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -941,6 +941,7 @@ END_PROVIDER psi_det_alpha_unique, idx0, psi_det_alpha_unique(1,i), N_int, & N_det_alpha_unique, s, j) singles_alpha_csc_idx(i+1) = int(j,8) + enddo !$OMP END DO deallocate(s) !$OMP END PARALLEL From ae0815bfac86d5e6f31c8b1cab2a95a218ed9396 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 14:52:23 +0200 Subject: [PATCH 22/48] Removed CSC array --- src/Davidson/diagonalization_hs2.irp.f | 8 ++-- src/Davidson/u0Hu0.irp.f | 52 ++++++++++++++------------ 2 files changed, 31 insertions(+), 29 deletions(-) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 535eddad..853e5cf7 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -126,7 +126,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s sze_8 = align_double(sze) itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) - PROVIDE nuclear_repulsion expected_s2 singles_alpha_csc + PROVIDE nuclear_repulsion expected_s2 call write_time(iunit) call wall_time(wall) @@ -138,7 +138,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s call write_int(iunit,N_st,'Number of states') call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') - r1 = 8.d0*(size(singles_alpha_csc)+3.d0*dble(sze_8*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & + r1 = 8.d0*(3.d0*dble(sze_8*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & + 4.d0*(N_st_diag*itermax)+nproc*(4.d0*N_det_alpha_unique+2.d0*N_st_diag*sze_8)))/(1024.d0**3) call write_double(iunit, r1, 'Memory(Gb)') write(iunit,'(A)') '' @@ -452,7 +452,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s y, s_, s_tmp, & lambda & ) - FREE singles_alpha_csc end subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) @@ -520,7 +519,7 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz stop -1 endif - PROVIDE nuclear_repulsion expected_s2 singles_alpha_csc + PROVIDE nuclear_repulsion expected_s2 call write_time(iunit) call wall_time(wall) @@ -892,6 +891,5 @@ subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sz y, s_, s_tmp, & lambda & ) - FREE singles_alpha_csc end diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index b963cf32..4ecd0158 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -104,9 +104,10 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif integer :: n_singles, n_doubles integer, allocatable :: singles(:), doubles(:) integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) integer, allocatable :: idx(:), idx0(:) logical, allocatable :: is_single_a(:) - integer :: maxab, n_singles_a, kcol_prev, nmax + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax integer*8 :: k8 double precision, allocatable :: v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t @@ -138,7 +139,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP lcol, lrow, is_single_a,l_a, l_b, nmax, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & - !$OMP singles_a, n_singles_a, s_t, k8) + !$OMP singles_a, n_singles_a, singles_b, & + !$OMP n_singles_b, s_t, k8) ! Alpha/Beta double excitations ! ============================= @@ -146,6 +148,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif allocate( buffer(N_int,maxab), & singles(maxab), & singles_a(maxab), & + singles_b(maxab), & doubles(maxab), & idx(maxab), & v_t(N_st,N_det), s_t(N_st,N_det), & @@ -166,38 +169,42 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif 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) - do k8=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 - is_single_a( singles_alpha_csc(k8) ) = .True. - enddo - if (kcol /= kcol_prev) then call get_all_spin_singles( & - psi_det_beta_unique, idx0, tmp_det(1,2), N_int, N_det_beta_unique,& - singles_a, n_singles_a) + psi_det_beta_unique(1,kcol+1), idx0(kcol+1), tmp_det(1,2), N_int, N_det_beta_unique-kcol+2,& + singles_b, n_singles_b) endif kcol_prev = kcol - ! Loop over singly excited beta columns - ! ------------------------------------- + ! Loop over singly excited beta columns > current column + ! ------------------------------------------------------ - do i=1,n_singles_a - lcol = singles_a(i) - if (lcol <= kcol) cycle + 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) + nmax = psi_bilinear_matrix_columns_loc(lcol+1) - l_a + do j=1,nmax + lrow = psi_bilinear_matrix_rows(l_a) + buffer(1:N_int,j) = psi_det_alpha_unique(1:N_int, lrow) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles( & + buffer, idx, tmp_det(1,1), N_int, j, & + singles_a, n_singles_a ) + ! Loop over alpha singles ! ----------------------- - do while ( l_a < psi_bilinear_matrix_columns_loc(lcol+1) ) - do l=l_a,psi_bilinear_matrix_columns_loc(lcol+1)-1 - lrow = psi_bilinear_matrix_rows(l) - if (is_single_a(lrow)) exit - enddo - if (l >= psi_bilinear_matrix_columns_loc(lcol+1)) exit - l_a = l + do k = 1,n_singles_a + l_a = singles_a(k) + lrow = psi_bilinear_matrix_rows(l_a) 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) call get_s2(tmp_det,tmp_det2,N_int,sij) @@ -207,11 +214,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) enddo - l_a = l_a+1 enddo - enddo - do k8=singles_alpha_csc_idx(krow), singles_alpha_csc_idx(krow+1)-1 - is_single_a( singles_alpha_csc(k8) ) = .False. + enddo enddo From 6b49eb59065741b8ca7d75aa766f3fb5898d3212 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 15:27:26 +0200 Subject: [PATCH 23/48] Fixed Davidson --- src/Davidson/u0Hu0.irp.f | 9 +++------ src/Determinants/spindeterminants.irp.f | 7 ++++--- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 4ecd0158..c17e2b49 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -106,7 +106,6 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif integer, allocatable :: singles_a(:) integer, allocatable :: singles_b(:) integer, allocatable :: idx(:), idx0(:) - logical, allocatable :: is_single_a(:) integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax integer*8 :: k8 double precision, allocatable :: v_t(:,:), s_t(:,:) @@ -136,7 +135,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP singles_alpha_size, sze_8, istart, iend, istep, & !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & - !$OMP lcol, lrow, is_single_a,l_a, l_b, nmax, & + !$OMP lcol, lrow, l_a, l_b, nmax, & !$OMP buffer, singles, doubles, n_singles, n_doubles, & !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & !$OMP singles_a, n_singles_a, singles_b, & @@ -151,9 +150,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif singles_b(maxab), & doubles(maxab), & idx(maxab), & - v_t(N_st,N_det), s_t(N_st,N_det), & - is_single_a(N_det_alpha_unique)) - is_single_a = .False. + v_t(N_st,N_det), s_t(N_st,N_det)) kcol_prev=-1 v_t = 0.d0 @@ -171,7 +168,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif if (kcol /= kcol_prev) then call get_all_spin_singles( & - psi_det_beta_unique(1,kcol+1), idx0(kcol+1), tmp_det(1,2), N_int, N_det_beta_unique-kcol+2,& + psi_det_beta_unique(1,kcol+1), idx0(kcol+1), tmp_det(1,2), N_int, N_det_beta_unique-kcol,& singles_b, n_singles_b) endif kcol_prev = kcol diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 8a5350e6..c7195601 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -1043,12 +1043,13 @@ subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_ integer(bit_kind), intent(in) :: spindet integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i - include 'Utils/constants.include.F' + integer :: i + integer(bit_kind) :: xorvec integer :: degree + !DIR$ ATTRIBUTES ALIGN : 64 :: xorvec + include 'Utils/constants.include.F' n_singles = 1 - !DIR$ VECTOR ALIGNED do i=1,size_buffer degree = popcnt(xor( spindet, buffer(i) )) if ( degree == 2 ) then From dc5e5f024df3fc635a8ecfddac1664294bcd7698 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 16:25:37 +0200 Subject: [PATCH 24/48] fixed Davidson --- src/Determinants/spindeterminants.irp.f | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index c7195601..2c08d64a 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -1043,17 +1043,15 @@ subroutine get_all_spin_singles_1(buffer, idx, spindet, size_buffer, singles, n_ integer(bit_kind), intent(in) :: spindet integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i - integer(bit_kind) :: xorvec + integer :: i integer :: degree - !DIR$ ATTRIBUTES ALIGN : 64 :: xorvec include 'Utils/constants.include.F' n_singles = 1 do i=1,size_buffer - degree = popcnt(xor( spindet, buffer(i) )) - if ( degree == 2 ) then - singles(n_singles) = idx(i) + degree = popcnt(xor( spindet, buffer(i) )) + singles(n_singles) = idx(i) + if (degree == 2) then n_singles = n_singles+1 endif enddo From 6d3a801d0e4b06b75e0b8cd4897cbe63c6d5e7f4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 16:46:08 +0200 Subject: [PATCH 25/48] Parallelization of Davidson --- src/Davidson/davidson_parallel.irp.f | 37 ++++++---------------------- src/Davidson/u0Hu0.irp.f | 4 +-- src/ZMQ/utils.irp.f | 5 ++++ 3 files changed, 14 insertions(+), 32 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 51863c1e..e11a5fdf 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -208,13 +208,12 @@ end subroutine -subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LDA) +subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, LDA) use f77_zmq implicit none integer :: LDA integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull double precision ,intent(inout) :: v0(LDA, N_states_diag) double precision ,intent(inout) :: s0(LDA, N_states_diag) @@ -223,11 +222,14 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LD double precision, allocatable :: v_0(:,:), s_0(:,:) integer :: i,j + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull allocate(v_0(N_det,N_states_diag), s_0(N_det,N_states_diag)) v0 = 0.d0 s0 = 0.d0 more = 1 + zmq_socket_pull = new_zmq_pull_socket() do while (more == 1) call davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) do j=1,N_states_diag @@ -239,38 +241,13 @@ subroutine davidson_collector(zmq_to_qp_run_socket, zmq_socket_pull , v0, s0, LD call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) end do deallocate(v_0,s_0) - -end subroutine - - -subroutine davidson_run(zmq_to_qp_run_socket , v0, s0, LDA) - use f77_zmq - implicit none - - integer :: LDA - integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_collector - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: i - integer, external :: omp_get_thread_num - - double precision , intent(inout) :: v0(LDA, N_states_diag) - double precision , intent(inout) :: s0(LDA, N_states_diag) - - - zmq_collector = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - call davidson_collector(zmq_collector, zmq_socket_pull , v0, s0, LDA) - call end_zmq_to_qp_run_socket(zmq_collector) call end_zmq_pull_socket(zmq_socket_pull) end subroutine + subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) use omp_lib use bitmasks @@ -361,7 +338,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) integer :: istep, imin, imax, ishift - istep=1 + istep=2 do imin=1,N_det, 524288 do ishift=0,istep-1 imax = min(N_det, imin+524288-1) @@ -378,7 +355,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) ithread = omp_get_thread_num() if (ithread == 0 ) then call zmq_set_running(zmq_to_qp_run_socket) - call davidson_run(zmq_to_qp_run_socket, v_0, s_0, size(v_0,1)) + call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, size(v_0,1)) else call davidson_slave_inproc(1) endif diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index c17e2b49..ac70ec7a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -157,7 +157,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif s_t = 0.d0 - !$OMP DO SCHEDULE(static,1) + !$OMP DO SCHEDULE(static,1024) do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) @@ -217,7 +217,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif enddo - !$OMP DO SCHEDULE(static,1) + !$OMP DO SCHEDULE(static,1024) do k_a=istart+ishift,iend,istep diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 91ed9200..e61cf92a 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -445,6 +445,11 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) integer :: rc character*(8), external :: zmq_port + rc = f77_zmq_setsockopt(zmq_socket_pull,ZMQ_LINGER,0,4) + if (rc /= 0) then + stop 'Unable to set ZMQ_LINGER on pull socket' + endif + call omp_set_lock(zmq_lock) rc = f77_zmq_close(zmq_socket_pull) call omp_unset_lock(zmq_lock) From df95c1af1c76abffeec0c34cab901a02880d127c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 17:50:49 +0200 Subject: [PATCH 26/48] Corrected memory leak in Davidson --- src/Davidson/davidson_parallel.irp.f | 23 +- src/Davidson/diagonalization_hs2.irp.f | 465 +------------------------ src/Davidson/u0Hu0.irp.f | 26 +- 3 files changed, 38 insertions(+), 476 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index e11a5fdf..4c0bfb4c 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -338,15 +338,22 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) integer :: istep, imin, imax, ishift - istep=2 - do imin=1,N_det, 524288 - do ishift=0,istep-1 - imax = min(N_det, imin+524288-1) - write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) - enddo - enddo +! istep=1 +! do imin=1,N_det, 524288 +! do ishift=0,istep-1 +! imax = min(N_det, imin+524288-1) +! write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' +! call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) +! enddo +! enddo + istep=N_det/131072+1 + imin=1 + imax=N_det + do ishift=0,istep-1 + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo v_0 = 0.d0 s_0 = 0.d0 diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 853e5cf7..d68d8a68 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -23,7 +23,7 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag), s2_out(N_st_diag) - double precision, allocatable :: H_jj(:), S2_jj(:) + double precision, allocatable :: H_jj(:) double precision :: diag_H_mat_elem, diag_S_mat_elem integer :: i @@ -32,32 +32,24 @@ subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_d ASSERT (Nint > 0) ASSERT (Nint == N_int) PROVIDE mo_bielec_integrals_in_map - allocate(H_jj(sze), S2_jj(sze)) + allocate(H_jj(sze) ) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint) & + !$OMP SHARED(sze,H_jj, dets_in,Nint) & !$OMP PRIVATE(i) !$OMP DO SCHEDULE(static) do i=1,sze H_jj(i) = diag_H_mat_elem(dets_in(1,1,i),Nint) - S2_jj(i) = diag_S_mat_elem(dets_in(1,1,i),Nint) enddo !$OMP END DO !$OMP END PARALLEL - if (disk_based_davidson) then - call davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - else - call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - endif - do i=1,N_st_diag - s2_out(i) = S2_jj(i) - enddo - deallocate (H_jj,S2_jj) + call davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) + deallocate (H_jj) end -subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) +subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) use bitmasks implicit none BEGIN_DOC @@ -65,7 +57,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ! ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson ! - ! S2_jj : specific diagonal S^2 matrix elements + ! S2_out : Output : s^2 ! ! dets_in : bitmasks corresponding to determinants ! @@ -87,7 +79,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) + double precision, intent(inout) :: s2_out(N_st_diag) integer, intent(in) :: iunit double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) @@ -434,7 +426,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s do k=1,N_st_diag energies(k) = lambda(k) - S2_jj(k) = s2(k) + s2_out(k) = s2(k) enddo write_buffer = '===== ' do i=1,N_st @@ -454,442 +446,3 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_s ) end -subroutine davidson_diag_hjj_sjj_mmap(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit) - use bitmasks - use mmap_module - implicit none - BEGIN_DOC - ! Davidson diagonalization with specific diagonal elements of the H matrix - ! - ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson - ! - ! S2_jj : specific diagonal S^2 matrix elements - ! - ! dets_in : bitmasks corresponding to determinants - ! - ! u_in : guess coefficients on the various states. Overwritten - ! on exit - ! - ! dim_in : leftmost dimension of u_in - ! - ! sze : Number of determinants - ! - ! N_st : Number of eigenstates - ! - ! N_st_diag : Number of states in which H is diagonalized. Assumed > sze - ! - ! iunit : Unit for the I/O - ! - ! Initial guess vectors are not necessarily orthonormal - END_DOC - integer, intent(in) :: dim_in, sze, N_st, N_st_diag, Nint - integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) - double precision, intent(in) :: H_jj(sze) - double precision, intent(inout) :: S2_jj(sze) - integer, intent(in) :: iunit - double precision, intent(inout) :: u_in(dim_in,N_st_diag) - double precision, intent(out) :: energies(N_st_diag) - - integer :: sze_8 - integer :: iter - integer :: i,j,k,l,m - logical :: converged - - double precision :: u_dot_v, u_dot_u - - integer :: k_pairs, kl - - integer :: iter2 - double precision, pointer :: W(:,:), U(:,:), S(:,:), overlap(:,:) - double precision, allocatable :: y(:,:), h(:,:), lambda(:), s2(:) - double precision, allocatable :: c(:), s_(:,:), s_tmp(:,:) - double precision :: diag_h_mat_elem - double precision, allocatable :: residual_norm(:) - character*(16384) :: write_buffer - double precision :: to_print(3,N_st) - double precision :: cpu, wall - logical :: state_ok(N_st_diag*davidson_sze_max) - integer :: shift, shift2, itermax - include 'constants.include.F' - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, h, lambda - if (N_st_diag*3 > sze) then - print *, 'error in Davidson :' - print *, 'Increase n_det_max_jacobi to ', N_st_diag*3 - stop -1 - endif - - PROVIDE nuclear_repulsion expected_s2 - - call write_time(iunit) - call wall_time(wall) - call cpu_time(cpu) - write(iunit,'(A)') '' - write(iunit,'(A)') 'Davidson Diagonalization' - write(iunit,'(A)') '------------------------' - write(iunit,'(A)') '' - call write_int(iunit,N_st,'Number of states') - call write_int(iunit,N_st_diag,'Number of states in diagonalization') - call write_int(iunit,sze,'Number of determinants') - write(iunit,'(A)') '' - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = ' Iter' - do i=1,N_st - write_buffer = trim(write_buffer)//' Energy S^2 Residual ' - enddo - write(iunit,'(A)') trim(write_buffer) - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - - integer, external :: align_double - integer :: fd(3) - type(c_ptr) :: c_pointer(3) - sze_8 = align_double(sze) - - itermax = min(davidson_sze_max, sze/N_st_diag) - - call mmap( & - trim(ezfio_work_dir)//'U', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), .False., c_pointer(1)) - call c_f_pointer(c_pointer(1), W, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'W', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), .False., c_pointer(2)) - call c_f_pointer(c_pointer(2), U, (/ sze_8,N_st_diag*itermax /) ) - - call mmap( & - trim(ezfio_work_dir)//'S', & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), .False., c_pointer(3)) - call c_f_pointer(c_pointer(3), S, (/ sze_8,N_st_diag*itermax /) ) - - allocate( & - h(N_st_diag*itermax,N_st_diag*itermax), & - y(N_st_diag*itermax,N_st_diag*itermax), & - s_(N_st_diag*itermax,N_st_diag*itermax), & - s_tmp(N_st_diag*itermax,N_st_diag*itermax), & - overlap(N_st_diag*itermax, N_st_diag*itermax), & - residual_norm(N_st_diag), & - c(N_st_diag*itermax), & - s2(N_st_diag*itermax), & - lambda(N_st_diag*itermax)) - - h = 0.d0 - U = 0.d0 - W = 0.d0 - S = 0.d0 - y = 0.d0 - s_ = 0.d0 - s_tmp = 0.d0 - - - ASSERT (N_st > 0) - ASSERT (N_st_diag >= N_st) - ASSERT (sze > 0) - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - ! Davidson iterations - ! =================== - - converged = .False. - - double precision :: r1, r2 - do k=N_st+1,N_st_diag - u_in(k,k) = 10.d0 - do i=1,sze - call random_number(r1) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - u_in(i,k) = r1*dcos(r2) - enddo - enddo - do k=1,N_st_diag - call normalize(u_in(1,k),sze) - enddo - - - do while (.not.converged) - - do k=1,N_st_diag - do i=1,sze - U(i,k) = u_in(i,k) - enddo - enddo - - do iter=1,itermax-1 - - shift = N_st_diag*(iter-1) - shift2 = N_st_diag*iter - - call ortho_qr(U,size(U,1),sze,shift2) - - ! Compute |W_k> = \sum_i |i> - ! ----------------------------------------- - - - if (distributed_davidson) then - call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) - else - call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) - endif - - - ! Compute h_kl = = - ! ------------------------------------------- - - do k=1,iter - shift = N_st_diag*(k-1) - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), W, size(W,1), & - 0.d0, h(shift+1,1), size(h,1)) - - call dgemm('T','N', N_st_diag, shift2, sze, & - 1.d0, U(1,shift+1), size(U,1), S, size(S,1), & - 0.d0, s_(shift+1,1), size(s_,1)) - enddo - -! ! Diagonalize S^2 -! ! --------------- -! -! call lapack_diag(s2,y,s_,size(s_,1),shift2) -! -! -! ! Rotate H in the basis of eigenfunctions of s2 -! ! --------------------------------------------- -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('T','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) -! -! ! Damp interaction between different spin states -! ! ------------------------------------------------ -! -! do k=1,shift2 -! do l=1,shift2 -! if (dabs(s2(k) - s2(l)) > 1.d0) then -! h(k,l) = h(k,l)*(max(0.d0,1.d0 - dabs(s2(k) - s2(l)))) -! endif -! enddo -! enddo -! -! ! Rotate back H -! ! ------------- -! -! call dgemm('N','T',shift2,shift2,shift2, & -! 1.d0, h, size(h,1), y, size(y,1), & -! 0.d0, s_tmp, size(s_tmp,1)) -! -! call dgemm('N','N',shift2,shift2,shift2, & -! 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & -! 0.d0, h, size(h,1)) - - - ! Diagonalize h - ! ------------- - call lapack_diag(lambda,y,h,size(h,1),shift2) - - ! Compute S2 for each eigenvector - ! ------------------------------- - - call dgemm('N','N',shift2,shift2,shift2, & - 1.d0, s_, size(s_,1), y, size(y,1), & - 0.d0, s_tmp, size(s_tmp,1)) - - call dgemm('T','N',shift2,shift2,shift2, & - 1.d0, y, size(y,1), s_tmp, size(s_tmp,1), & - 0.d0, s_, size(s_,1)) - - - - do k=1,shift2 - s2(k) = s_(k,k) + S_z2_Sz - enddo - - - if (s2_eig) then - do k=1,shift2 - state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0) - enddo - else - state_ok(k) = .True. - endif - - do k=1,shift2 - if (.not. state_ok(k)) then - do l=k+1,shift2 - if (state_ok(l)) then - call dswap(shift2, y(1,k), 1, y(1,l), 1) - call dswap(1, s2(k), 1, s2(l), 1) - call dswap(1, lambda(k), 1, lambda(l), 1) - state_ok(k) = .True. - state_ok(l) = .False. - exit - endif - enddo - endif - enddo - - if (state_following) then - - ! Compute overlap with U_in - ! ------------------------- - - integer :: order(N_st_diag) - double precision :: cmax - overlap = -1.d0 - do k=1,shift2 - do i=1,shift2 - overlap(k,i) = dabs(y(k,i)) - enddo - enddo - do k=1,N_st - cmax = -1.d0 - do i=1,shift2 - if (overlap(i,k) > cmax) then - cmax = overlap(i,k) - order(k) = i - endif - enddo - do i=1,shift2 - overlap(order(k),i) = -1.d0 - enddo - enddo - overlap = y - do k=1,N_st - l = order(k) - if (k /= l) then - y(1:shift2,k) = overlap(1:shift2,l) - endif - enddo - do k=1,N_st - overlap(k,1) = lambda(k) - overlap(k,2) = s2(k) - enddo - do k=1,N_st - l = order(k) - if (k /= l) then - lambda(k) = overlap(l,1) - s2(k) = overlap(l,2) - endif - enddo - - endif - - - ! Express eigenvectors of h in the determinant basis - ! -------------------------------------------------- - - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) - call dgemm('N','N', sze, N_st_diag, shift2, & - 1.d0, S, size(S,1), y, size(y,1), 0.d0, S(1,shift2+1), size(S,1)) - - ! Compute residual vector and davidson step - ! ----------------------------------------- - - do k=1,N_st_diag - if (state_ok(k)) then - do i=1,sze - U(i,shift2+k) = (lambda(k) * U(i,shift2+k) - W(i,shift2+k) ) & - * (1.d0 + s2(k) * U(i,shift2+k) - S(i,shift2+k) - S_z2_Sz & - )/max(H_jj(i) - lambda (k),1.d-2) - enddo - else - ! Randomize components with bad - do i=1,sze-2,2 - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - U(i+1,shift2+k) = r1*dsin(r2) - enddo - do i=sze-2+1,sze - call random_number(r1) - call random_number(r2) - r1 = dsqrt(-2.d0*dlog(r1)) - r2 = dtwo_pi*r2 - U(i,shift2+k) = r1*dcos(r2) - enddo - endif - - if (k <= N_st) then - residual_norm(k) = u_dot_u(U(1,shift2+k),sze) - to_print(1,k) = lambda(k) + nuclear_repulsion - to_print(2,k) = s2(k) - to_print(3,k) = residual_norm(k) - endif - enddo - - write(iunit,'(1X,I3,1X,100(1X,F16.10,1X,F11.6,1X,E11.3))') iter, to_print(1:3,1:N_st) - call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) - do k=1,N_st - if (residual_norm(k) > 1.e8) then - print *, '' - stop 'Davidson failed' - endif - enddo - if (converged) then - exit - endif - - enddo - - ! Re-contract to u_in - ! ----------- - - call dgemm('N','N', sze, N_st_diag, shift2, 1.d0, & - U, size(U,1), y, size(y,1), 0.d0, u_in, size(u_in,1)) - - enddo - - do k=1,N_st_diag - energies(k) = lambda(k) - S2_jj(k) = s2(k) - enddo - write_buffer = '===== ' - do i=1,N_st - write_buffer = trim(write_buffer)//' ================ =========== ===========' - enddo - write(iunit,'(A)') trim(write_buffer) - write(iunit,'(A)') '' - call write_time(iunit) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(1), c_pointer(1)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(2), c_pointer(2)) - - call munmap( & - (/ int(sze_8,8),int(N_st_diag*itermax,8) /), & - 8, fd(3), c_pointer(3)) - - deallocate ( & - residual_norm, & - c, overlap, & - h, & - y, s_, s_tmp, & - lambda & - ) -end - diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index ac70ec7a..6cb7de45 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -101,8 +101,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif integer(bit_kind) :: tmp_det2(N_int,2) integer(bit_kind) :: tmp_det3(N_int,2) integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_singles, n_doubles - integer, allocatable :: singles(:), doubles(:) + integer :: n_doubles + integer, allocatable :: doubles(:) integer, allocatable :: singles_a(:) integer, allocatable :: singles_b(:) integer, allocatable :: idx(:), idx0(:) @@ -136,7 +136,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, l_a, l_b, nmax, & - !$OMP buffer, singles, doubles, n_singles, n_doubles, & + !$OMP buffer, doubles, n_doubles, & !$OMP tmp_det2, hij, sij, idx, l, kcol_prev, v_t, & !$OMP singles_a, n_singles_a, singles_b, & !$OMP n_singles_b, s_t, k8) @@ -145,7 +145,6 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif ! ============================= allocate( buffer(N_int,maxab), & - singles(maxab), & singles_a(maxab), & singles_b(maxab), & doubles(maxab), & @@ -157,7 +156,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif s_t = 0.d0 - !$OMP DO SCHEDULE(static,1024) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) @@ -216,8 +215,9 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif enddo enddo + !$OMP END DO NOWAIT - !$OMP DO SCHEDULE(static,1024) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep @@ -256,14 +256,14 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif call get_all_spin_singles_and_doubles( & buffer, idx, spindet, N_int, i, & - singles, doubles, n_singles, n_doubles ) + 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 - l_a = singles(i) + do i=1,n_singles_a + l_a = singles_a(i) lrow = psi_bilinear_matrix_rows(l_a) tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) @@ -326,14 +326,14 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif call get_all_spin_singles_and_doubles( & buffer, idx, spindet, N_int, i, & - singles, doubles, n_singles, n_doubles ) + 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 - l_b = singles(i) + do i=1,n_singles_b + l_b = singles_b(i) lcol = psi_bilinear_matrix_transp_columns(l_b) tmp_det2(1:N_int,2) = psi_det_beta_unique (1:N_int, lcol) call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) @@ -385,6 +385,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif end do !$OMP END DO NOWAIT + deallocate(buffer, singles_a, singles_b, doubles, idx) !$OMP CRITICAL do l=1,N_st @@ -394,6 +395,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif enddo enddo !$OMP END CRITICAL + deallocate(v_t, s_t) !$OMP BARRIER !$OMP END PARALLEL From b4aef21b50e44efe5d58d09d242fa6c4663d7a29 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 18:41:07 +0200 Subject: [PATCH 27/48] Tuned davidson --- src/Davidson/davidson_parallel.irp.f | 30 ++++++++++++++-------------- src/Davidson/davidson_slave.irp.f | 2 +- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 4c0bfb4c..16ea5847 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -338,22 +338,22 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) integer :: istep, imin, imax, ishift -! istep=1 -! do imin=1,N_det, 524288 -! do ishift=0,istep-1 -! imax = min(N_det, imin+524288-1) -! write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' -! call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) -! enddo -! enddo - - istep=N_det/131072+1 - imin=1 - imax=N_det - do ishift=0,istep-1 - write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + istep=2 + do imin=1,N_det, 262144 + do ishift=0,istep-1 + imax = min(N_det, imin+262144-1) + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo enddo + +! istep=2 +! imin=1 +! imax=N_det +! do ishift=0,istep-1 +! write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' +! call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) +! enddo v_0 = 0.d0 s_0 = 0.d0 diff --git a/src/Davidson/davidson_slave.irp.f b/src/Davidson/davidson_slave.irp.f index d0be9a37..e917c664 100644 --- a/src/Davidson/davidson_slave.irp.f +++ b/src/Davidson/davidson_slave.irp.f @@ -26,6 +26,6 @@ program davidson_slave end subroutine provide_everything - PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context + PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context ref_bitmask_energy end subroutine From 0af043390cc579b251cab7c67f5e5da1222fb503 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 18 Apr 2017 18:55:51 +0200 Subject: [PATCH 28/48] Tuned davidson --- src/Davidson/davidson_parallel.irp.f | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 16ea5847..08f90639 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -106,7 +106,8 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ endif if (N_det_read /= N_det) then - stop 'error : N_det' + N_det = N_det_read + TOUCH N_det endif rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) @@ -339,9 +340,9 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) integer :: istep, imin, imax, ishift istep=2 - do imin=1,N_det, 262144 + do imin=1,N_det, 1048576 do ishift=0,istep-1 - imax = min(N_det, imin+262144-1) + imax = min(N_det, imin+1048576-1) write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo From dd5933808341cbeeddb656c99d610db5fbcab17c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 12:08:17 +0200 Subject: [PATCH 29/48] Working on davidson --- src/Davidson/davidson_parallel.irp.f | 53 ++++++++++++-------------- src/Davidson/diagonalization_hs2.irp.f | 4 +- src/Davidson/u0Hu0.irp.f | 14 +++++-- 3 files changed, 36 insertions(+), 35 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 08f90639..aa761a38 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -70,8 +70,6 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ double precision, allocatable :: v_0(:,:), s_0(:,:), u_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_0, s_0 - allocate(v_0(N_det,N_st), s_0(N_det,N_st),u_t(N_st,N_det)) - ! Get wave function (u_t) ! ----------------------- @@ -92,21 +90,27 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ integer :: N_states_read, N_det_read, psi_det_size_read integer :: N_det_selectors_read, N_det_generators_read - double precision :: energy(N_states_diag) + double precision :: energy(N_st) - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read,& + + allocate(v_0(sze_8,N_st), s_0(sze_8,N_st),u_t(N_st,N_det)) + + read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read + if (rc /= worker_id) then print *, 'Wrong worker ID' stop 'error' endif if (N_states_read /= N_st) then + print *, N_st stop 'error : N_st' endif if (N_det_read /= N_det) then N_det = N_det_read + stop 'N_det_read /= N_det' TOUCH N_det endif @@ -123,9 +127,9 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ stop 'error' endif - rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,N_states_diag*8,0) - if (rc /= N_states_diag*8) then - print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,N_states_diag*8,0)' + rc = f77_zmq_recv(zmq_to_qp_run_socket,energy,N_st*8,0) + if (rc /= N_st*8) then + print *, '77_zmq_recv(zmq_to_qp_run_socket,energy,N_st*8,0)' stop 'error' endif @@ -142,6 +146,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call davidson_push_results(zmq_socket_push, v_0, s_0, task_id) end do + deallocate(v_0, s_0, u_t) end subroutine @@ -189,11 +194,11 @@ subroutine davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) integer :: rc - rc = f77_zmq_recv( zmq_socket_pull, v_0, 8*size(v_0), 0) - if(rc /= 8*size(s_0)) stop "davidson_push_results failed to pull v_0" + rc = f77_zmq_recv( zmq_socket_pull, v_0, 8*N_det*N_states_diag, 0) + if(rc /= 8*N_det*N_states_diag) stop "davidson_push_results failed to pull v_0" - rc = f77_zmq_recv( zmq_socket_pull, s_0, 8*size(s_0), 0) - if(rc /= 8*size(s_0)) stop "davidson_push_results failed to pull s_0" + rc = f77_zmq_recv( zmq_socket_pull, s_0, 8*N_det*N_states_diag, 0) + if(rc /= 8*N_det*N_states_diag) stop "davidson_push_results failed to pull s_0" rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) if(rc /= 4) stop "davidson_pull_results failed to pull task_id" @@ -209,15 +214,15 @@ end subroutine -subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, LDA) +subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, sze_8, N_st) use f77_zmq implicit none - integer :: LDA + integer, intent(in) :: sze_8, N_st integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - double precision ,intent(inout) :: v0(LDA, N_states_diag) - double precision ,intent(inout) :: s0(LDA, N_states_diag) + double precision ,intent(inout) :: v0(sze_8, N_st) + double precision ,intent(inout) :: s0(sze_8, N_st) integer :: more, task_id @@ -226,14 +231,14 @@ subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, LDA) integer(ZMQ_PTR), external :: new_zmq_pull_socket integer(ZMQ_PTR) :: zmq_socket_pull - allocate(v_0(N_det,N_states_diag), s_0(N_det,N_states_diag)) + allocate(v_0(N_det,N_st), s_0(N_det,N_st)) v0 = 0.d0 s0 = 0.d0 more = 1 zmq_socket_pull = new_zmq_pull_socket() do while (more == 1) call davidson_pull_results(zmq_socket_pull, v_0, s_0, task_id) - do j=1,N_states_diag + do j=1,N_st do i=1,N_det v0(i,j) = v0(i,j) + v_0(i,j) s0(i,j) = s0(i,j) + s_0(i,j) @@ -292,9 +297,6 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) ASSERT (n>0) PROVIDE ref_bitmask_energy nproc - v_0 = 0.d0 - s_0 = 0.d0 - call new_parallel_job(zmq_to_qp_run_socket,'davidson') character*(512) :: task @@ -348,22 +350,15 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) enddo enddo -! istep=2 -! imin=1 -! imax=N_det -! do ishift=0,istep-1 -! write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' -! call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) -! enddo v_0 = 0.d0 s_0 = 0.d0 call omp_set_nested(.True.) + call zmq_set_running(zmq_to_qp_run_socket) !$OMP PARALLEL NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then - call zmq_set_running(zmq_to_qp_run_socket) - call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, size(v_0,1)) + call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, sze_8, N_st) else call davidson_slave_inproc(1) endif diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index d68d8a68..2a8272da 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -118,7 +118,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ sze_8 = align_double(sze) itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) - PROVIDE nuclear_repulsion expected_s2 + PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse call write_time(iunit) call wall_time(wall) @@ -223,7 +223,7 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ if (distributed_davidson) then - call H_S2_u_0_nstates_zmq(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) + call H_S2_u_0_nstates_zmq (W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) else call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) endif diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 6cb7de45..14b32da8 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -156,7 +156,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif s_t = 0.d0 - !$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(static,64) do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) @@ -206,8 +206,10 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif call get_s2(tmp_det,tmp_det2,N_int,sij) do l=1,N_st v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) - v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) + !$OMP ATOMIC + v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) + !$OMP ATOMIC s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) enddo enddo @@ -215,9 +217,9 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif enddo enddo - !$OMP END DO NOWAIT + !$OMP END DO - !$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(static,64) do k_a=istart+ishift,iend,istep @@ -283,6 +285,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif lrow = psi_bilinear_matrix_rows(l_a) call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), N_int, hij) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 @@ -339,6 +342,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) l_a = psi_bilinear_matrix_transp_order(l_b) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 @@ -354,6 +358,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), N_int, hij) l_a = psi_bilinear_matrix_transp_order(l_b) do l=1,N_st + !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 @@ -379,6 +384,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif hij = diag_H_mat_elem(tmp_det,N_int) sij = diag_S_mat_elem(tmp_det,N_int) do l=1,N_st + !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) enddo From 48f51a71ce3fb62fae7b80a75c5177a6ee25b9cc Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 12:24:09 +0200 Subject: [PATCH 30/48] Fixed Davidson --- src/Davidson/davidson_parallel.irp.f | 34 ++++++++++++-------------- src/Davidson/diagonalization.irp.f | 10 +++----- src/Davidson/diagonalization_hs2.irp.f | 16 ++++++------ src/Davidson/u0Hu0.irp.f | 26 ++++++++++---------- src/Davidson/u0Hu0_old.irp.f | 24 +++++++++--------- 5 files changed, 51 insertions(+), 59 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index aa761a38..7a9ff73c 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -44,11 +44,7 @@ subroutine davidson_run_slave(thread,iproc) return end if - integer :: sze_8 - integer, external :: align_double - sze_8 = align_double(N_det) - - call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_states_diag, sze_8, worker_id) + call davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_states_diag, N_det, worker_id) call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) @@ -56,13 +52,13 @@ end subroutine -subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_8, worker_id) +subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, worker_id) use f77_zmq implicit none integer(ZMQ_PTR),intent(in) :: zmq_to_qp_run_socket integer(ZMQ_PTR),intent(in) :: zmq_socket_push - integer,intent(in) :: worker_id, N_st, sze_8 + integer,intent(in) :: worker_id, N_st, sze integer :: task_id character*(512) :: msg integer :: imin, imax, ishift, istep @@ -93,7 +89,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ double precision :: energy(N_st) - allocate(v_0(sze_8,N_st), s_0(sze_8,N_st),u_t(N_st,N_det)) + allocate(v_0(sze,N_st), s_0(sze,N_st),u_t(N_st,N_det)) read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read @@ -142,7 +138,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze_ call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) if(task_id == 0) exit read (msg,*) imin, imax, ishift, istep - call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,imin,imax,ishift,istep) + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,N_det,imin,imax,ishift,istep) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call davidson_push_results(zmq_socket_push, v_0, s_0, task_id) end do @@ -214,15 +210,15 @@ end subroutine -subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, sze_8, N_st) +subroutine davidson_collector(zmq_to_qp_run_socket, v0, s0, sze, N_st) use f77_zmq implicit none - integer, intent(in) :: sze_8, N_st + integer, intent(in) :: sze, N_st integer(ZMQ_PTR), intent(in) :: zmq_to_qp_run_socket - double precision ,intent(inout) :: v0(sze_8, N_st) - double precision ,intent(inout) :: s0(sze_8, N_st) + double precision ,intent(inout) :: v0(sze, N_st) + double precision ,intent(inout) :: s0(sze, N_st) integer :: more, task_id @@ -254,7 +250,7 @@ end subroutine -subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) +subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) use omp_lib use bitmasks use f77_zmq @@ -268,9 +264,9 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) ! ! S2_jj : array of END_DOC - integer, intent(in) :: N_st, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(inout):: u_0(sze_8,N_st) + integer, intent(in) :: N_st, sze + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(inout):: u_0(sze,N_st) integer :: i,j,k integer :: ithread double precision, allocatable :: u_t(:,:) @@ -290,7 +286,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) integer(ZMQ_PTR) :: zmq_to_qp_run_socket - if(N_st /= N_states_diag .or. sze_8 < N_det) stop "assert fail in H_S2_u_0_nstates" + if(N_st /= N_states_diag .or. sze < N_det) stop "assert fail in H_S2_u_0_nstates" ASSERT (Nint > 0) ASSERT (Nint == N_int) @@ -358,7 +354,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze_8) !$OMP PARALLEL NUM_THREADS(2) PRIVATE(ithread) ithread = omp_get_thread_num() if (ithread == 0 ) then - call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, sze_8, N_st) + call davidson_collector(zmq_to_qp_run_socket, v_0, s_0, N_det, N_st) else call davidson_slave_inproc(1) endif diff --git a/src/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index fe82a8fb..51728851 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -302,7 +302,6 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) - integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged @@ -365,13 +364,12 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia write(iunit,'(A)') trim(write_buffer) integer, external :: align_double - sze_8 = align_double(sze) allocate( & kl_pairs(2,N_st_diag*(N_st_diag+1)/2), & - W(sze_8,N_st_diag,davidson_sze_max), & - U(sze_8,N_st_diag,davidson_sze_max), & - R(sze_8,N_st_diag), & + W(sze,N_st_diag,davidson_sze_max), & + U(sze,N_st_diag,davidson_sze_max), & + R(sze,N_st_diag), & h(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & y(N_st_diag,davidson_sze_max,N_st_diag,davidson_sze_max), & residual_norm(N_st_diag), & @@ -426,7 +424,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia ! Compute |W_k> = \sum_i |i> ! ----------------------------------------- - call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze_8) + call H_u_0_nstates(W(1,1,iter),U(1,1,iter),H_jj,sze,dets_in,Nint,N_st_diag,sze) ! do k=1,N_st ! if(store_full_H_mat.and.sze.le.n_det_max_stored)then ! call H_u_0_stored(W(1,k,iter),U(1,k,iter),H_matrix_all_dets,sze) diff --git a/src/Davidson/diagonalization_hs2.irp.f b/src/Davidson/diagonalization_hs2.irp.f index 2a8272da..54672609 100644 --- a/src/Davidson/diagonalization_hs2.irp.f +++ b/src/Davidson/diagonalization_hs2.irp.f @@ -84,7 +84,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ double precision, intent(inout) :: u_in(dim_in,N_st_diag) double precision, intent(out) :: energies(N_st_diag) - integer :: sze_8 integer :: iter integer :: i,j,k,l,m logical :: converged @@ -115,7 +114,6 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ endif integer, external :: align_double - sze_8 = align_double(sze) itermax = max(3,min(davidson_sze_max, sze/N_st_diag)) PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse @@ -130,8 +128,8 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ call write_int(iunit,N_st,'Number of states') call write_int(iunit,N_st_diag,'Number of states in diagonalization') call write_int(iunit,sze,'Number of determinants') - r1 = 8.d0*(3.d0*dble(sze_8*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & - + 4.d0*(N_st_diag*itermax)+nproc*(4.d0*N_det_alpha_unique+2.d0*N_st_diag*sze_8)))/(1024.d0**3) + r1 = 8.d0*(3.d0*dble(sze*N_st_diag*itermax+5.d0*(N_st_diag*itermax)**2 & + + 4.d0*(N_st_diag*itermax)+nproc*(4.d0*N_det_alpha_unique+2.d0*N_st_diag*sze)))/(1024.d0**3) call write_double(iunit, r1, 'Memory(Gb)') write(iunit,'(A)') '' write_buffer = '===== ' @@ -153,9 +151,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ allocate( & ! Large - W(sze_8,N_st_diag*itermax), & - U(sze_8,N_st_diag*itermax), & - S(sze_8,N_st_diag*itermax), & + W(sze,N_st_diag*itermax), & + U(sze,N_st_diag*itermax), & + S(sze,N_st_diag*itermax), & ! Small h(N_st_diag*itermax,N_st_diag*itermax), & @@ -223,9 +221,9 @@ subroutine davidson_diag_hjj_sjj(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_ if (distributed_davidson) then - call H_S2_u_0_nstates_zmq (W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) + call H_S2_u_0_nstates_zmq (W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze) else - call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze_8) + call H_S2_u_0_nstates_openmp(W(1,shift+1),S(1,shift+1),U(1,shift+1),N_st_diag,sze) endif diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 14b32da8..73c5784b 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -1,4 +1,4 @@ -subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) +subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -7,16 +7,16 @@ subroutine u_0_H_u_0(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8) ! n : number of determinants ! END_DOC - integer, intent(in) :: n,Nint, N_st, sze_8 + integer, intent(in) :: n,Nint, N_st, sze double precision, intent(out) :: e_0(N_st) - double precision, intent(inout):: u_0(sze_8,N_st) + double precision, intent(inout):: u_0(sze,N_st) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) double precision, allocatable :: v_0(:,:), s_0(:,:) double precision :: u_dot_u,u_dot_v,diag_H_mat_elem integer :: i,j - allocate (v_0(sze_8,N_st),s_0(sze_8,N_st)) - call H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) + allocate (v_0(sze,N_st),s_0(sze,N_st)) + call H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze) do i=1,N_st e_0(i) = u_dot_v(v_0(1,i),u_0(1,i),n)/u_dot_u(u_0(1,i),n) enddo @@ -33,7 +33,7 @@ END_PROVIDER -subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) +subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -43,8 +43,8 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) ! ! istart, iend, ishift, istep are used in ZMQ parallelization. END_DOC - integer, intent(in) :: N_st,sze_8 - double precision, intent(inout) :: v_0(sze_8,N_st), s_0(sze_8,N_st), u_0(sze_8,N_st) + integer, intent(in) :: N_st,sze + double precision, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st), u_0(sze,N_st) integer :: k double precision, allocatable :: u_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t @@ -61,7 +61,7 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze_8) size(u_t, 1), & N_det, N_st) - call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,1,N_det,0,1) + call H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -74,7 +74,7 @@ end -subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishift,istep) +subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -82,9 +82,9 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif ! ! Default should be 1,N_det,0,1 END_DOC - integer, intent(in) :: N_st,sze_8,istart,iend,ishift,istep + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep double precision, intent(in) :: u_t(N_st,N_det) - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) PROVIDE ref_bitmask_energy @@ -132,7 +132,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze_8,istart,iend,ishif !$OMP psi_bilinear_matrix_order_transp_reverse, & !$OMP singles_alpha_csc, singles_alpha_csc_idx, & !$OMP psi_bilinear_matrix_columns_loc, & - !$OMP singles_alpha_size, sze_8, istart, iend, istep, & + !$OMP singles_alpha_size, istart, iend, istep, & !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, l_a, l_b, nmax, & diff --git a/src/Davidson/u0Hu0_old.irp.f b/src/Davidson/u0Hu0_old.irp.f index 42587e5b..783fd952 100644 --- a/src/Davidson/u0Hu0_old.irp.f +++ b/src/Davidson/u0Hu0_old.irp.f @@ -1,5 +1,5 @@ -subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -10,9 +10,9 @@ subroutine H_u_0_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,N_st,sze_8) ! H_jj : array of ! END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) + integer, intent(in) :: N_st,n,Nint, sze + double precision, intent(out) :: v_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) double precision, intent(in) :: H_jj(n) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) double precision :: hij,s2 @@ -228,7 +228,7 @@ end -subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -240,9 +240,9 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) ! ! S2_jj : array of END_DOC - integer, intent(in) :: N_st,n,Nint, sze_8 - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) + integer, intent(in) :: N_st,n,Nint, sze + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) double precision, intent(in) :: H_jj(n), S2_jj(n) integer(bit_kind),intent(in) :: keys_tmp(Nint,2,n) double precision :: hij,s2 @@ -457,13 +457,13 @@ subroutine H_S2_u_0_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) deallocate (shortcut, sort_idx, sorted, version, ut) end -subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze_8) +subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze) use bitmasks implicit none - integer, intent(in) :: N_st,n,Nint, sze_8 + integer, intent(in) :: N_st,n,Nint, sze integer(bit_kind), intent(in) :: keys_tmp(Nint,2,n) - double precision, intent(out) :: v_0(sze_8,N_st), s_0(sze_8,N_st) - double precision, intent(in) :: u_0(sze_8,N_st) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(in) :: u_0(sze,N_st) double precision, intent(in) :: H_jj(n), S2_jj(n) PROVIDE ref_bitmask_energy From 69a747fde0800b361156575d69af588417d9244f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 12:49:11 +0200 Subject: [PATCH 31/48] Tuned N_int --- src/Davidson/u0Hu0.irp.f | 130 +++++++----- src/Davidson/u0Hu0_old.irp.f | 2 +- src/Determinants/spindeterminants.irp.f | 256 ++++++++---------------- 3 files changed, 159 insertions(+), 229 deletions(-) diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index 73c5784b..cc1ba224 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -73,7 +73,6 @@ subroutine H_S2_u_0_nstates_openmp(v_0,s_0,u_0,N_st,sze) end - subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none @@ -89,6 +88,33 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, PROVIDE ref_bitmask_energy + select case (N_int) + case (1) + call H_S2_u_0_nstates_openmp_work_1(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call H_S2_u_0_nstates_openmp_work_2(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call H_S2_u_0_nstates_openmp_work_3(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call H_S2_u_0_nstates_openmp_work_4(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call H_S2_u_0_nstates_openmp_work_N_int(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end +BEGIN_TEMPLATE + +subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_0,s_0,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! 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) + double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision :: hij, sij integer :: i,j,k,l integer :: k_a, k_b, l_a, l_b, m_a, m_b @@ -96,10 +122,10 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, 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) :: 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(:) @@ -110,6 +136,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, integer*8 :: k8 double precision, allocatable :: v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t + PROVIDE N_int maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 allocate(idx0(maxab)) @@ -144,7 +171,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, ! Alpha/Beta double excitations ! ============================= - allocate( buffer(N_int,maxab), & + allocate( buffer($N_int,maxab), & singles_a(maxab), & singles_b(maxab), & doubles(maxab), & @@ -156,18 +183,19 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, s_t = 0.d0 - !$OMP DO SCHEDULE(static,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep 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) + 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( & - psi_det_beta_unique(1,kcol+1), idx0(kcol+1), tmp_det(1,2), N_int, N_det_beta_unique-kcol,& + call get_all_spin_singles_$N_int( & + psi_det_beta_unique(1,kcol+1), idx0(kcol+1), & + tmp_det(1,2), N_det_beta_unique-kcol, & singles_b, n_singles_b) endif kcol_prev = kcol @@ -178,21 +206,21 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, do i=1,n_singles_b lcol = singles_b(i) - tmp_det2(1:N_int,2) = psi_det_beta_unique(1:N_int, lcol) + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) l_a = psi_bilinear_matrix_columns_loc(lcol) nmax = psi_bilinear_matrix_columns_loc(lcol+1) - l_a do j=1,nmax lrow = psi_bilinear_matrix_rows(l_a) - buffer(1:N_int,j) = psi_det_alpha_unique(1:N_int, lrow) + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) idx(j) = l_a l_a = l_a+1 enddo j = j-1 - call get_all_spin_singles( & - buffer, idx, tmp_det(1,1), N_int, j, & + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & singles_a, n_singles_a ) ! Loop over alpha singles @@ -201,15 +229,13 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, do k = 1,n_singles_a l_a = singles_a(k) lrow = psi_bilinear_matrix_rows(l_a) - 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) - call get_s2(tmp_det,tmp_det2,N_int,sij) + 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) + call get_s2(tmp_det,tmp_det2,$N_int,sij) do l=1,N_st v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,l_a) - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) - !$OMP ATOMIC s_t(l,l_a) = s_t(l,l_a) + sij * u_t(l,k_a) enddo enddo @@ -219,7 +245,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, enddo !$OMP END DO - !$OMP DO SCHEDULE(static,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep @@ -233,15 +259,15 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, 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) + 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) + spindet(1:$N_int) = tmp_det(1:$N_int,1) ! Loop inside the beta column to gather all the connected alphas l_a = k_a+1 @@ -250,25 +276,25 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, lcol = psi_bilinear_matrix_columns(l_a) if (lcol /= kcol) exit lrow = psi_bilinear_matrix_rows(l_a) - buffer(1:N_int,i) = psi_det_alpha_unique(1:N_int, lrow) + 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( & - buffer, idx, spindet, N_int, i, & + 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) + 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) lrow = psi_bilinear_matrix_rows(l_a) - tmp_det2(1:N_int,1) = psi_det_alpha_unique(1:N_int, lrow) - call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 1, hij) + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 1, hij) do l=1,N_st v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) @@ -283,9 +309,8 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, do i=1,n_doubles l_a = doubles(i) lrow = psi_bilinear_matrix_rows(l_a) - call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), N_int, hij) + call i_H_j_double_spin( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 @@ -304,10 +329,10 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, 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) + 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) + spindet(1:$N_int) = tmp_det(1:$N_int,2) ! Initial determinant is at k_b in beta-major representation ! ----------------------------------------------------------------------- @@ -321,28 +346,27 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, lrow = psi_bilinear_matrix_transp_rows(l_b) if (lrow /= krow) exit lcol = psi_bilinear_matrix_transp_columns(l_b) - buffer(1:N_int,i) = psi_det_beta_unique(1:N_int, lcol) + 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( & - buffer, idx, spindet, N_int, i, & + 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) + 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) lcol = psi_bilinear_matrix_transp_columns(l_b) - tmp_det2(1:N_int,2) = psi_det_beta_unique (1:N_int, lcol) - call i_H_j_mono_spin( tmp_det, tmp_det2, N_int, 2, hij) + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + call i_H_j_mono_spin( tmp_det, tmp_det2, $N_int, 2, hij) l_a = psi_bilinear_matrix_transp_order(l_b) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! single => sij = 0 @@ -355,10 +379,9 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, do i=1,n_doubles l_b = doubles(i) lcol = psi_bilinear_matrix_transp_columns(l_b) - call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), N_int, hij) + call i_H_j_double_spin( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) l_a = psi_bilinear_matrix_transp_order(l_b) do l=1,N_st - !$OMP ATOMIC v_t(l,l_a) = v_t(l,l_a) + hij * u_t(l,k_a) v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) ! same spin => sij = 0 @@ -376,15 +399,14 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, 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) + 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, diag_S_mat_elem - hij = diag_H_mat_elem(tmp_det,N_int) - sij = diag_S_mat_elem(tmp_det,N_int) + hij = diag_H_mat_elem(tmp_det,$N_int) + sij = diag_S_mat_elem(tmp_det,$N_int) do l=1,N_st - !$OMP ATOMIC v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a) s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a) enddo @@ -408,6 +430,14 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, end - +SUBST [ N_int ] + +1;; +2;; +3;; +4;; +N_int;; + +END_TEMPLATE diff --git a/src/Davidson/u0Hu0_old.irp.f b/src/Davidson/u0Hu0_old.irp.f index 783fd952..70aea449 100644 --- a/src/Davidson/u0Hu0_old.irp.f +++ b/src/Davidson/u0Hu0_old.irp.f @@ -462,7 +462,7 @@ subroutine H_S2_u_0_nstates_test(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,N_st,sze implicit none integer, intent(in) :: N_st,n,Nint, sze integer(bit_kind), intent(in) :: keys_tmp(Nint,2,n) - double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) + double precision, intent(inout) :: v_0(sze,N_st), s_0(sze,N_st) double precision, intent(in) :: u_0(sze,N_st) double precision, intent(in) :: H_jj(n), S2_jj(n) diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 2c08d64a..03ae031c 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -696,63 +696,19 @@ subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buf integer, intent(out) :: n_singles integer, intent(out) :: n_doubles - integer :: i,k - include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(N_int_max) - integer :: degree - - integer, external :: align_double - - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - select case (Nint) case (1) call get_all_spin_singles_and_doubles_1(buffer, idx, spindet(1), size_buffer, singles, doubles, n_singles, n_doubles) - return -! case (2) -! call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) -! return -! case (3) -! call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) -! return + case (2) + call get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case (3) + call get_all_spin_singles_and_doubles_3(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case (4) + call get_all_spin_singles_and_doubles_4(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) + case default + call get_all_spin_singles_and_doubles_N_int(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) end select - - n_singles = 1 - n_doubles = 1 - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - - do k=1,Nint - xorvec(k) = xor( spindet(k), buffer(k,i) ) - enddo - - if (xorvec(1) /= 0_8) then - degree = popcnt(xorvec(1)) - else - degree = 0 - endif - - do k=2,Nint - !DIR$ VECTOR ALIGNED - if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then - degree = degree + popcnt(xorvec(k)) - endif - enddo - - if ( degree == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - else if ( degree == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - - enddo - n_singles = n_singles-1 - n_doubles = n_doubles-1 - end @@ -771,54 +727,19 @@ subroutine get_all_spin_singles(buffer, idx, spindet, Nint, size_buffer, singles integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i,k - include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(N_int_max) - integer :: degree - - integer, external :: align_double - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec - - select case (Nint) + select case (N_int) case (1) call get_all_spin_singles_1(buffer, idx, spindet(1), size_buffer, singles, n_singles) return -! case (2) -! call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) -! return -! case (3) -! call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) -! return + case (2) + call get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) + case (3) + call get_all_spin_singles_3(buffer, idx, spindet, size_buffer, singles, n_singles) + case (4) + call get_all_spin_singles_4(buffer, idx, spindet, size_buffer, singles, n_singles) + case default + call get_all_spin_singles_N_int(buffer, idx, spindet, size_buffer, singles, n_singles) end select - - n_singles = 1 - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - - do k=1,Nint - xorvec(k) = xor( spindet(k), buffer(k,i) ) - enddo - - if (xorvec(1) /= 0_8) then - degree = popcnt(xorvec(1)) - else - degree = 0 - endif - - do k=2,Nint - if ( (degree <= 2).and.(xorvec(k) /= 0_8) ) then - degree = degree + popcnt(xorvec(k)) - endif - enddo - - if ( degree == 2 ) then - singles(n_singles) = idx(i) - n_singles = n_singles+1 - endif - - enddo - n_singles = n_singles-1 end @@ -838,54 +759,19 @@ subroutine get_all_spin_doubles(buffer, idx, spindet, Nint, size_buffer, doubles integer, intent(out) :: doubles(size_buffer) integer, intent(out) :: n_doubles - integer :: i,k, degree - include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(N_int_max) - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec - - select case (Nint) + select case (N_int) case (1) call get_all_spin_doubles_1(buffer, idx, spindet(1), size_buffer, doubles, n_doubles) - return case (2) call get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) - return -! case (3) -! call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) -! return + case (3) + call get_all_spin_doubles_3(buffer, idx, spindet, size_buffer, doubles, n_doubles) + case (4) + call get_all_spin_doubles_4(buffer, idx, spindet, size_buffer, doubles, n_doubles) + case default + call get_all_spin_doubles_N_int(buffer, idx, spindet, size_buffer, doubles, n_doubles) end select - n_doubles = 1 - !DIR$ VECTOR ALIGNED - do i=1,size_buffer - - do k=1,Nint - xorvec(k) = xor( spindet(k), buffer(k,i) ) - enddo - - if (xorvec(1) /= 0_8) then - degree = popcnt(xorvec(1)) - else - degree = 0 - endif - - do k=2,Nint - !DIR$ VECTOR ALIGNED - if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then - degree = degree + popcnt(xorvec(k)) - endif - enddo - - if ( degree == 4 ) then - doubles(n_doubles) = idx(i) - n_doubles = n_doubles+1 - endif - - enddo - - n_doubles = n_doubles-1 - end @@ -1093,8 +979,9 @@ end +BEGIN_TEMPLATE -subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) +subroutine get_all_spin_singles_and_doubles_$N_int(buffer, idx, spindet, size_buffer, singles, doubles, n_singles, n_doubles) use bitmasks implicit none BEGIN_DOC @@ -1106,30 +993,28 @@ subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, ! END_DOC integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) integer, intent(out) :: singles(size_buffer) integer, intent(out) :: doubles(size_buffer) integer, intent(out) :: n_singles integer, intent(out) :: n_doubles - integer :: i - include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(2) + integer :: i,k + integer(bit_kind) :: xorvec($N_int) integer :: degree integer, external :: align_double - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec, degree - n_singles = 1 n_doubles = 1 !DIR$ VECTOR ALIGNED do i=1,size_buffer - xorvec(1) = xor( spindet(1), buffer(1,i) ) - xorvec(2) = xor( spindet(2), buffer(2,i) ) + do k=1,$N_int + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo if (xorvec(1) /= 0_8) then degree = popcnt(xorvec(1)) @@ -1137,10 +1022,12 @@ subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, degree = 0 endif - !DIR$ VECTOR ALIGNED - if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then - degree = degree + popcnt(xorvec(2)) - endif + do k=2,$N_int + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo if ( degree == 4 ) then doubles(n_doubles) = idx(i) @@ -1157,7 +1044,7 @@ subroutine get_all_spin_singles_and_doubles_2(buffer, idx, spindet, size_buffer, end -subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_singles) +subroutine get_all_spin_singles_$N_int(buffer, idx, spindet, size_buffer, singles, n_singles) use bitmasks implicit none BEGIN_DOC @@ -1167,24 +1054,27 @@ subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_ ! END_DOC integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) integer, intent(out) :: singles(size_buffer) integer, intent(out) :: n_singles - integer :: i + integer :: i,k include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(2) + integer(bit_kind) :: xorvec($N_int) integer :: degree + integer, external :: align_double + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec n_singles = 1 !DIR$ VECTOR ALIGNED do i=1,size_buffer - xorvec(1) = xor( spindet(1), buffer(1,i) ) - xorvec(2) = xor( spindet(2), buffer(2,i) ) + do k=1,$N_int + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo if (xorvec(1) /= 0_8) then degree = popcnt(xorvec(1)) @@ -1192,11 +1082,11 @@ subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_ degree = 0 endif - if (degree > 2) cycle - - if ( xorvec(2) /= 0_8 ) then - degree = degree + popcnt(xorvec(2)) - endif + do k=2,$N_int + if ( (degree <= 2).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo if ( degree == 2 ) then singles(n_singles) = idx(i) @@ -1209,7 +1099,7 @@ subroutine get_all_spin_singles_2(buffer, idx, spindet, size_buffer, singles, n_ end -subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_doubles) +subroutine get_all_spin_doubles_$N_int(buffer, idx, spindet, size_buffer, doubles, n_doubles) use bitmasks implicit none BEGIN_DOC @@ -1219,34 +1109,35 @@ subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_ ! END_DOC integer, intent(in) :: size_buffer, idx(size_buffer) - integer(bit_kind), intent(in) :: buffer(2,size_buffer) - integer(bit_kind), intent(in) :: spindet(2) + integer(bit_kind), intent(in) :: buffer($N_int,size_buffer) + integer(bit_kind), intent(in) :: spindet($N_int) integer, intent(out) :: doubles(size_buffer) integer, intent(out) :: n_doubles - integer :: i, degree + integer :: i,k, degree include 'Utils/constants.include.F' - integer(bit_kind) :: xorvec(2) - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: xorvec + integer(bit_kind) :: xorvec($N_int) n_doubles = 1 !DIR$ VECTOR ALIGNED do i=1,size_buffer - xorvec(1) = xor( spindet(1), buffer(1,i) ) - xorvec(2) = xor( spindet(2), buffer(2,i) ) - + do k=1,$N_int + xorvec(k) = xor( spindet(k), buffer(k,i) ) + enddo + if (xorvec(1) /= 0_8) then degree = popcnt(xorvec(1)) else degree = 0 endif - !DIR$ VECTOR ALIGNED - if ( (degree <= 4).and.(xorvec(2) /= 0_8) ) then - degree = degree + popcnt(xorvec(2)) - endif + do k=2,$N_int + !DIR$ VECTOR ALIGNED + if ( (degree <= 4).and.(xorvec(k) /= 0_8) ) then + degree = degree + popcnt(xorvec(k)) + endif + enddo if ( degree == 4 ) then doubles(n_doubles) = idx(i) @@ -1259,3 +1150,12 @@ subroutine get_all_spin_doubles_2(buffer, idx, spindet, size_buffer, doubles, n_ end +SUBST [ N_int ] +2;; +3;; +4;; +N_int;; + +END_TEMPLATE + + From 1ac36ab762f0f42834a915a5cfd72764e6052d18 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 15:31:12 +0200 Subject: [PATCH 32/48] Accelerated selection --- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 3 +- plugins/Full_CI_ZMQ/selection_buffer.irp.f | 19 ++---- src/Utils/sort.irp.f | 58 ++++++++++++++----- 3 files changed, 50 insertions(+), 30 deletions(-) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 85b52c30..9ea942a5 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -45,7 +45,7 @@ subroutine run_selection_slave(thread,iproc,energy) if(buf%N == 0) then ! Only first time call create_selection_buffer(N, N*2, buf) - call create_selection_buffer(N, N*3, buf2) + call create_selection_buffer(N, N*2, buf2) else if(N /= buf%N) stop "N changed... wtf man??" end if @@ -62,7 +62,6 @@ subroutine run_selection_slave(thread,iproc,energy) do i=1,buf%cur call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) enddo - call sort_selection_buffer(buf2) buf%mini = buf2%mini pt2 = 0d0 buf%cur = 0 diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 84992449..28ceaae3 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -41,7 +41,6 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b - double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) double precision, pointer :: vals(:) integer(bit_kind), pointer :: detmp(:,:,:) @@ -49,29 +48,23 @@ subroutine sort_selection_buffer(b) logical, external :: detEq nmwen = min(b%N, b%cur) - - allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) - absval = -dabs(b%val(:b%cur)) + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), vals(size(b%val))) do i=1,b%cur iorder(i) = i end do - ! Optimal for almost sorted data -! call sorted_dnumber(absval, b%cur, i) -! if (b%cur/i > -! call insertion_dsort(absval, iorder, b%cur) - call dsort(absval, iorder, b%cur) + call dsort(b%val, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) vals(i) = b%val(iorder(i)) end do - do i=nmwen+1, size(vals) - vals(i) = 0.d0 - enddo + if (nmwen < b%N) then + vals(nmwen+1) = 0.d0 + endif deallocate(b%det, b%val) b%det => detmp b%val => vals - b%mini = max(b%mini,dabs(b%val(b%N))) + b%mini = min(b%mini,b%val(1)) b%cur = nmwen end subroutine diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index ba27c0f7..1e271fc0 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -12,23 +12,20 @@ BEGIN_TEMPLATE $type :: xtmp integer :: i, i0, j, jmax - do i=1,isize + do i=2,isize xtmp = x(i) i0 = iorder(i) - j = i-1 - do j=i-1,1,-1 - if ( x(j) > xtmp ) then - x(j+1) = x(j) - iorder(j+1) = iorder(j) - else - exit - endif + do j = i-1,1,-1 + if ((x(j) <= xtmp)) exit + x(j+1) = x(j) + iorder(j+1) = iorder(j) enddo x(j+1) = xtmp iorder(j+1) = i0 enddo end subroutine insertion_$Xsort + subroutine heap_$Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -179,7 +176,7 @@ BEGIN_TEMPLATE endif do i=2,isize - if (x(i-1) >= x(i)) then + if (x(i-1) <= x(i)) then n=n+1 endif enddo @@ -194,6 +191,31 @@ SUBST [ X, type ] i2 ; integer*2 ;; END_TEMPLATE +!BEGIN_TEMPLATE +! subroutine $Xsort(x,iorder,isize) +! implicit none +! BEGIN_DOC +! ! Sort array x(isize). +! ! iorder in input should be (1,2,3,...,isize), and in output +! ! contains the new order of the elements. +! END_DOC +! integer,intent(in) :: isize +! $type,intent(inout) :: x(isize) +! integer,intent(inout) :: iorder(isize) +! integer :: n +! call sorted_$Xnumber(x,isize,n) +! if ( isize-n < 1000) then +! call insertion_$Xsort(x,iorder,isize) +! else +! call heap_$Xsort(x,iorder,isize) +! endif +! end subroutine $Xsort +! +!SUBST [ X, type ] +! ; real ;; +! d ; double precision ;; +!END_TEMPLATE + BEGIN_TEMPLATE subroutine $Xsort(x,iorder,isize) implicit none @@ -207,16 +229,19 @@ BEGIN_TEMPLATE integer,intent(inout) :: iorder(isize) integer :: n call sorted_$Xnumber(x,isize,n) - if ( isize-n < 1000) then + if (isize == n) then + return + endif + if ( isize < 512+n) then call insertion_$Xsort(x,iorder,isize) else - call heap_$Xsort(x,iorder,isize) + call $Yradix_sort(x,iorder,isize,-1) endif end subroutine $Xsort -SUBST [ X, type ] - ; real ;; - d ; double precision ;; +SUBST [ X, type, Y ] + ; real ; i ;; + d ; double precision ; i8 ;; END_TEMPLATE BEGIN_TEMPLATE @@ -422,6 +447,9 @@ BEGIN_TEMPLATE i0 = 0_$int_type i4 = maxval(x) + if (i4 == 0_$type) then + return + endif iradix_new = $integer_size-1-leadz(i4) mask = ibset(0_$type,iradix_new) From 9b4131139b24b62c4c1081fe8648068eed9081c9 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 15:44:24 +0200 Subject: [PATCH 33/48] Fixed selection sort --- src/Utils/sort.irp.f | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index 1e271fc0..f31627f0 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -318,13 +318,11 @@ BEGIN_TEMPLATE xtmp = x(i) i0 = iorder(i) j = i-1_8 - do j=i-1_8,1_8,-1_8 - if ( x(j) > xtmp ) then - x(j+1_8) = x(j) - iorder(j+1_8) = iorder(j) - else - exit - endif + do while (x(j) Date: Wed, 19 Apr 2017 15:56:04 +0200 Subject: [PATCH 34/48] Fixed selection --- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 3 +++ plugins/Full_CI_ZMQ/selection_buffer.irp.f | 15 +++++++++------ src/Utils/sort.irp.f | 11 ++++++----- 3 files changed, 18 insertions(+), 11 deletions(-) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 9ea942a5..bfc099e2 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -61,6 +61,9 @@ subroutine run_selection_slave(thread,iproc,energy) call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) do i=1,buf%cur call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + if (buf2%cur == buf2%N) then + call sort_selection_buffer(buf2) + endif enddo buf%mini = buf2%mini pt2 = 0d0 diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 28ceaae3..8a067357 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -41,6 +41,7 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b + double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) double precision, pointer :: vals(:) integer(bit_kind), pointer :: detmp(:,:,:) @@ -48,23 +49,25 @@ subroutine sort_selection_buffer(b) logical, external :: detEq nmwen = min(b%N, b%cur) - allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), vals(size(b%val))) + + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) + absval = -dabs(b%val(:b%cur)) do i=1,b%cur iorder(i) = i end do - call dsort(b%val, iorder, b%cur) + call dsort(absval, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) vals(i) = b%val(iorder(i)) end do - if (nmwen < b%N) then - vals(nmwen+1) = 0.d0 - endif + do i=nmwen+1, size(vals) + vals(i) = 0.d0 + enddo deallocate(b%det, b%val) b%det => detmp b%val => vals - b%mini = min(b%mini,b%val(1)) + b%mini = max(b%mini,dabs(b%val(b%N))) b%cur = nmwen end subroutine diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index f31627f0..7572bc27 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -15,17 +15,18 @@ BEGIN_TEMPLATE do i=2,isize xtmp = x(i) i0 = iorder(i) - do j = i-1,1,-1 + j=i-1 + do while (j>0) if ((x(j) <= xtmp)) exit x(j+1) = x(j) iorder(j+1) = iorder(j) + j=j-1 enddo x(j+1) = xtmp iorder(j+1) = i0 enddo end subroutine insertion_$Xsort - subroutine heap_$Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -314,15 +315,15 @@ BEGIN_TEMPLATE $type :: xtmp integer*8 :: i, i0, j, jmax - do i=1_8,isize + do i=2_8,isize xtmp = x(i) i0 = iorder(i) j = i-1_8 - do while (x(j)0_8) + if (x(j)<=xtmp) exit x(j+1_8) = x(j) iorder(j+1_8) = iorder(j) j = j-1_8 - if (j<1_8) exit enddo x(j+1_8) = xtmp iorder(j+1_8) = i0 From b12e898b116b930b6497edf003a4cfae9a1575e3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 15:56:04 +0200 Subject: [PATCH 35/48] Fixed selection --- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 3 + plugins/Full_CI_ZMQ/selection_buffer.irp.f | 15 +++-- src/Utils/sort.irp.f | 59 +++++-------------- 3 files changed, 27 insertions(+), 50 deletions(-) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 9ea942a5..bfc099e2 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -61,6 +61,9 @@ subroutine run_selection_slave(thread,iproc,energy) call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) do i=1,buf%cur call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + if (buf2%cur == buf2%N) then + call sort_selection_buffer(buf2) + endif enddo buf%mini = buf2%mini pt2 = 0d0 diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 28ceaae3..8a067357 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -41,6 +41,7 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b + double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) double precision, pointer :: vals(:) integer(bit_kind), pointer :: detmp(:,:,:) @@ -48,23 +49,25 @@ subroutine sort_selection_buffer(b) logical, external :: detEq nmwen = min(b%N, b%cur) - allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), vals(size(b%val))) + + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) + absval = -dabs(b%val(:b%cur)) do i=1,b%cur iorder(i) = i end do - call dsort(b%val, iorder, b%cur) + call dsort(absval, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) vals(i) = b%val(iorder(i)) end do - if (nmwen < b%N) then - vals(nmwen+1) = 0.d0 - endif + do i=nmwen+1, size(vals) + vals(i) = 0.d0 + enddo deallocate(b%det, b%val) b%det => detmp b%val => vals - b%mini = min(b%mini,b%val(1)) + b%mini = max(b%mini,dabs(b%val(b%N))) b%cur = nmwen end subroutine diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index f31627f0..e7b40a04 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -15,17 +15,18 @@ BEGIN_TEMPLATE do i=2,isize xtmp = x(i) i0 = iorder(i) - do j = i-1,1,-1 + j=i-1 + do while (j>0) if ((x(j) <= xtmp)) exit x(j+1) = x(j) iorder(j+1) = iorder(j) + j=j-1 enddo x(j+1) = xtmp iorder(j+1) = i0 enddo end subroutine insertion_$Xsort - subroutine heap_$Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -164,15 +165,10 @@ BEGIN_TEMPLATE $type, intent(in) :: x(isize) integer, intent(out) :: n integer :: i - if (isize < 2) then - n = 1 - return - endif + n=1 - if (x(1) >= x(2)) then - n=1 - else - n=0 + if (isize < 2) then + return endif do i=2,isize @@ -191,31 +187,6 @@ SUBST [ X, type ] i2 ; integer*2 ;; END_TEMPLATE -!BEGIN_TEMPLATE -! subroutine $Xsort(x,iorder,isize) -! implicit none -! BEGIN_DOC -! ! Sort array x(isize). -! ! iorder in input should be (1,2,3,...,isize), and in output -! ! contains the new order of the elements. -! END_DOC -! integer,intent(in) :: isize -! $type,intent(inout) :: x(isize) -! integer,intent(inout) :: iorder(isize) -! integer :: n -! call sorted_$Xnumber(x,isize,n) -! if ( isize-n < 1000) then -! call insertion_$Xsort(x,iorder,isize) -! else -! call heap_$Xsort(x,iorder,isize) -! endif -! end subroutine $Xsort -! -!SUBST [ X, type ] -! ; real ;; -! d ; double precision ;; -!END_TEMPLATE - BEGIN_TEMPLATE subroutine $Xsort(x,iorder,isize) implicit none @@ -228,14 +199,17 @@ BEGIN_TEMPLATE $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) integer :: n + if (isize < 2) then + return + endif call sorted_$Xnumber(x,isize,n) if (isize == n) then return endif - if ( isize < 512+n) then + if ( isize < 64+n) then call insertion_$Xsort(x,iorder,isize) else - call $Yradix_sort(x,iorder,isize,-1) + call heap_$Xsort(x,iorder,isize) endif end subroutine $Xsort @@ -314,15 +288,15 @@ BEGIN_TEMPLATE $type :: xtmp integer*8 :: i, i0, j, jmax - do i=1_8,isize + do i=2_8,isize xtmp = x(i) i0 = iorder(i) j = i-1_8 - do while (x(j)0_8) + if (x(j)<=xtmp) exit x(j+1_8) = x(j) iorder(j+1_8) = iorder(j) j = j-1_8 - if (j<1_8) exit enddo x(j+1_8) = xtmp iorder(j+1_8) = i0 @@ -445,11 +419,8 @@ BEGIN_TEMPLATE i0 = 0_$int_type i4 = maxval(x) - if (i4 == 0_$type) then - return - endif - iradix_new = $integer_size-1-leadz(i4) + iradix_new = max($integer_size-1-leadz(i4),1) mask = ibset(0_$type,iradix_new) allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err) From 225afd19e6072b1760d55454403bd1240c7f71bd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 16:38:05 +0200 Subject: [PATCH 36/48] Tuning --- src/Utils/sort.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index e7b40a04..bb93d44f 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -206,7 +206,7 @@ BEGIN_TEMPLATE if (isize == n) then return endif - if ( isize < 64+n) then + if ( isize < 32+n) then call insertion_$Xsort(x,iorder,isize) else call heap_$Xsort(x,iorder,isize) From 27d07d7676b07ed2c14c5b7fea19886fec61dbb0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 16:44:34 +0200 Subject: [PATCH 37/48] Fixed distributed Davdison --- src/Davidson/davidson_parallel.irp.f | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 7a9ff73c..402cc561 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -88,9 +88,6 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, integer :: N_det_selectors_read, N_det_generators_read double precision :: energy(N_st) - - allocate(v_0(sze,N_st), s_0(sze,N_st),u_t(N_st,N_det)) - read(msg(14:rc),*) rc, N_states_read, N_det_read, psi_det_size_read, & N_det_generators_read, N_det_selectors_read @@ -106,10 +103,12 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, if (N_det_read /= N_det) then N_det = N_det_read - stop 'N_det_read /= N_det' TOUCH N_det endif + + allocate(v_0(sze,N_st), s_0(sze,N_st),u_t(N_st,N_det)) + rc = f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0) if (rc /= N_int*2*N_det*bit_kind) then print *, 'f77_zmq_recv(zmq_to_qp_run_socket,psi_det,N_int*2*N_det*bit_kind,0)' From cbf8c54d707dac50d54c7ecc5f9262df1b79f53c Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 19:45:18 +0200 Subject: [PATCH 38/48] Parallelization of Davidson --- src/Davidson/davidson_parallel.irp.f | 38 +++++++++++++++++++++---- src/Davidson/u0Hu0.irp.f | 7 ++--- src/Determinants/spindeterminants.irp.f | 2 +- 3 files changed, 37 insertions(+), 10 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 402cc561..6c16a1fa 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -271,6 +271,11 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) double precision, allocatable :: u_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique + PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc + PROVIDE ref_bitmask_energy nproc + + 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) @@ -290,7 +295,6 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) ASSERT (Nint > 0) ASSERT (Nint == N_int) ASSERT (n>0) - PROVIDE ref_bitmask_energy nproc call new_parallel_job(zmq_to_qp_run_socket,'davidson') @@ -335,15 +339,39 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) deallocate(u_t) + ! Create tasks + ! ============ + integer :: istep, imin, imax, ishift - istep=2 - do imin=1,N_det, 1048576 + double precision :: w, max_workload, N_det_inv, di + max_workload = N_det_beta_unique+N_det_alpha_unique + w = 0.d0 + istep=4 + ishift=0 + imin=1 + N_det_inv = 1.d0/dble(N_det) + di = dble(N_det) + do imax=1,N_det + di = di-1.d0 + w = w + (di*N_det_inv)**2 + if (w > max_workload) then + do ishift=0,istep-1 + write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo + istep = max(istep-1,1) + imin = imax+1 + w = 0.d0 + endif + enddo + if (w > 0.d0) then + imax = N_det do ishift=0,istep-1 - imax = min(N_det, imin+1048576-1) write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo - enddo + endif + v_0 = 0.d0 s_0 = 0.d0 diff --git a/src/Davidson/u0Hu0.irp.f b/src/Davidson/u0Hu0.irp.f index cc1ba224..4f68f85a 100644 --- a/src/Davidson/u0Hu0.irp.f +++ b/src/Davidson/u0Hu0.irp.f @@ -86,7 +86,7 @@ subroutine H_S2_u_0_nstates_openmp_work(v_0,s_0,u_t,N_st,sze,istart,iend,ishift, double precision, intent(out) :: v_0(sze,N_st), s_0(sze,N_st) - PROVIDE ref_bitmask_energy + PROVIDE ref_bitmask_energy N_int select case (N_int) case (1) @@ -136,7 +136,6 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_0,s_0,u_t,N_st,sze,istart,iend, integer*8 :: k8 double precision, allocatable :: v_t(:,:), s_t(:,:) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: v_t, s_t - PROVIDE N_int maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 allocate(idx0(maxab)) @@ -148,6 +147,7 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_0,s_0,u_t,N_st,sze,istart,iend, ! Prepare the array of all alpha single excitations ! ------------------------------------------------- + PROVIDE N_int !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & !$OMP psi_bilinear_matrix_columns, & @@ -157,9 +157,8 @@ subroutine H_S2_u_0_nstates_openmp_work_$N_int(v_0,s_0,u_t,N_st,sze,istart,iend, !$OMP psi_bilinear_matrix_transp_columns, & !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & - !$OMP singles_alpha_csc, singles_alpha_csc_idx, & !$OMP psi_bilinear_matrix_columns_loc, & - !$OMP singles_alpha_size, istart, iend, istep, & + !$OMP istart, iend, istep, & !$OMP ishift, idx0, u_t, maxab, v_0, s_0) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & !$OMP lcol, lrow, l_a, l_b, nmax, & diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 03ae031c..aa7fde29 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -541,7 +541,7 @@ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows_loc, (N_det_alpha_uniq psi_bilinear_matrix_transp_rows_loc(l) = k endif enddo - psi_bilinear_matrix_transp_rows_loc(N_det_beta_unique+1) = N_det+1 + psi_bilinear_matrix_transp_rows_loc(N_det_alpha_unique+1) = N_det+1 END_PROVIDER BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order_transp_reverse , (N_det) ] From a28a9d7d33260df4a955421421d9b41a3f763b8e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 19:56:38 +0200 Subject: [PATCH 39/48] Better load balancing in Davidson --- src/Davidson/davidson_parallel.irp.f | 2 +- src/Integrals_Bielec/ao_bi_integrals.irp.f | 2 +- src/Integrals_Bielec/mo_bi_integrals.irp.f | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 6c16a1fa..1afcb00a 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -344,7 +344,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) integer :: istep, imin, imax, ishift double precision :: w, max_workload, N_det_inv, di - max_workload = N_det_beta_unique+N_det_alpha_unique + max_workload = 200000.d0 w = 0.d0 istep=4 ishift=0 diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 196bfce4..4750d5a0 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -350,7 +350,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integral = ao_bielec_integral(1,1,1,1) - real :: map_mb + double precision :: map_mb PROVIDE read_ao_integrals disk_access_ao_integrals if (read_ao_integrals) then print*,'Reading the AO integrals' diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 68c44210..05eb8dff 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -198,7 +198,7 @@ subroutine add_integrals_to_map(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -505,7 +505,7 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -819,7 +819,7 @@ subroutine add_integrals_to_map_no_exit_34(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb + double precision :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 From 99572799678ee32eb65b87d004b68841393e1c01 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 20:22:37 +0200 Subject: [PATCH 40/48] Better load balancing in Davidson --- src/Davidson/davidson_parallel.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 1afcb00a..6a314ceb 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -353,7 +353,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) di = dble(N_det) do imax=1,N_det di = di-1.d0 - w = w + (di*N_det_inv)**2 + w = w + di*N_det_inv if (w > max_workload) then do ishift=0,istep-1 write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' From a9414b4a643a320a130158ece434a21df030c0a5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 20:46:09 +0200 Subject: [PATCH 41/48] Better load balancing in Davidson --- src/Davidson/davidson_parallel.irp.f | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 6a314ceb..68db35da 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -344,9 +344,9 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) integer :: istep, imin, imax, ishift double precision :: w, max_workload, N_det_inv, di - max_workload = 200000.d0 + max_workload = 1000000.d0 w = 0.d0 - istep=4 + istep=8 ishift=0 imin=1 N_det_inv = 1.d0/dble(N_det) @@ -359,7 +359,6 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) write(task,'(4(I9,1X),1A)') imin, imax, ishift, istep, '|' call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo - istep = max(istep-1,1) imin = imax+1 w = 0.d0 endif From 94f01c0892f031055bce8f519795d940b0b6ae97 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 08:36:11 +0200 Subject: [PATCH 42/48] Bugs to fix (#50) * Add config for knl * Add mising readme * Add .gitignore * Add pseudo to qp_convert * Working pseudo * Dressed matrix for pt2 works for one state * now eigenfunction of S^2 * minor modifs in printing * Fixed the perturbation with psi_ref instead of psi_det * Trying do really fo sin free multiple excitations * Beginning to merge MRCC and MRPT * final version of MRPT, at least I hope * Fix 404: Update Zlib Url. * Delete ifort_knl.cfg * Update module_handler.py * Update pot_ao_pseudo_ints.irp.f * Update map_module.f90 * Restaure map_module.f90 * Update configure * Update configure * Update sort.irp.f * Update sort.irp.f * Update selection.irp.f * Update selection.irp.f * Update dressing.irp.f * TApplencourt IRPF90 -> LCPQ * Remove `irpf90.make` in dependency * Update configure * Missing PROVIDE * Missing PROVIDE * Missing PROVIDE * Missing PROVIDE * Update configure * pouet * density based mrpt2 * debugging FOBOCI * Added SCF_density * New version of FOBOCI * added density.irp.f * minor changes in plugins/FOBOCI/SC2_1h1p.irp.f * added track_orb.irp.f * minor changes * minor modifs in FOBOCI * med * Minor changes * minor changes * strange things in MRPT * minor modifs mend * Fix #185 (Graphviz API / Python 2.6) * beginning to debug dft * fixed the factor 2 in lebedev * DFT integration works for non overlapping densities * DFT begins to work with lda * KS LDA is okay * added core integrals * mend * Beginning logn range integrals * Trying to handle two sets of integrals * beginning to clean erf integrals * Handling of two different mo and ao integrals map --- config/gfortran.cfg | 4 +- config/ifort.cfg | 2 +- plugins/All_singles/.gitignore | 5 + plugins/CAS_SD_ZMQ/selection.irp.f | 1 + plugins/DDCI_selected/NEEDED_CHILDREN_MODULES | 2 +- plugins/DDCI_selected/ddci.irp.f | 2 +- plugins/DFT_Utils/EZFIO.cfg | 4 - plugins/DFT_Utils/angular.f | 6951 +++++++++++++++++ plugins/DFT_Utils/functional.irp.f | 54 + plugins/DFT_Utils/grid_density.irp.f | 119 +- plugins/DFT_Utils/integration_3d.irp.f | 9 +- plugins/DFT_Utils/integration_radial.irp.f | 11 +- .../test_integration_3d_density.irp.f | 54 + plugins/FCIdump/NEEDED_CHILDREN_MODULES | 2 +- plugins/FCIdump/fcidump.irp.f | 48 +- plugins/FOBOCI/NEEDED_CHILDREN_MODULES | 2 +- plugins/FOBOCI/SC2_1h1p.irp.f | 2 +- plugins/FOBOCI/all_singles.irp.f | 1 + plugins/FOBOCI/create_1h_or_1p.irp.f | 133 +- plugins/FOBOCI/density.irp.f | 16 + plugins/FOBOCI/density_matrix.irp.f | 44 +- plugins/FOBOCI/dress_simple.irp.f | 59 +- plugins/FOBOCI/fobo_scf.irp.f | 7 +- .../foboci_lmct_mlct_threshold_old.irp.f | 23 +- plugins/FOBOCI/generators_restart_save.irp.f | 35 +- plugins/FOBOCI/routines_foboci.irp.f | 162 +- plugins/FOBOCI/track_orb.irp.f | 57 + plugins/Full_CI/H_apply.irp.f | 5 - plugins/Full_CI/NEEDED_CHILDREN_MODULES | 2 +- plugins/Full_CI_ZMQ/.gitignore | 5 + plugins/Full_CI_ZMQ/selection.irp.f | 1113 +++ .../Generators_CAS/Generators_full/.gitignore | 25 + .../Generators_full/NEEDED_CHILDREN_MODULES | 1 + .../Generators_CAS/Generators_full/README.rst | 61 + .../Generators_full/generators.irp.f | 75 + .../Generators_full/tree_dependency.png | Bin 0 -> 82663 bytes plugins/Generators_CAS/generators.irp.f | 16 +- plugins/Integrals_erf/EZFIO.cfg | 34 + plugins/Integrals_erf/NEEDED_CHILDREN_MODULES | 1 + .../Integrals_erf/ao_bi_integrals_erf.irp.f | 570 ++ ...ao_bielec_integrals_erf_in_map_slave.irp.f | 175 + .../Integrals_erf/integrals_3_index_erf.irp.f | 22 + plugins/Integrals_erf/map_integrals_erf.irp.f | 626 ++ .../Integrals_erf/mo_bi_integrals_erf.irp.f | 616 ++ plugins/Integrals_erf/providers_ao_erf.irp.f | 119 + plugins/Integrals_erf/qp_ao_erf_ints.irp.f | 32 + plugins/Integrals_erf/read_write.irp.f | 47 + .../NEEDED_CHILDREN_MODULES | 1 + plugins/Integrals_restart_DFT/README.rst | 12 + .../short_range_coulomb.irp.f | 79 + .../write_integrals_restart_dft.irp.f | 18 + plugins/Kohn_Sham/EZFIO.cfg | 54 + plugins/Kohn_Sham/Fock_matrix.irp.f | 468 ++ plugins/Kohn_Sham/HF_density_matrix_ao.irp.f | 41 + plugins/Kohn_Sham/KS_SCF.irp.f | 54 + plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES | 1 + plugins/Kohn_Sham/damping_SCF.irp.f | 132 + plugins/Kohn_Sham/diagonalize_fock.irp.f | 119 + plugins/Kohn_Sham/potential_functional.irp.f | 31 + plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES | 2 +- plugins/MRCC_Utils/amplitudes.irp.f | 7 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 55 +- plugins/MRPT/MRPT_Utils.main.irp.f | 46 +- plugins/MRPT/NEEDED_CHILDREN_MODULES | 2 +- plugins/MRPT/print_1h2p.irp.f | 77 +- plugins/MRPT_Utils/EZFIO.cfg | 7 + plugins/MRPT_Utils/H_apply.irp.f | 8 + plugins/MRPT_Utils/MRMP2_density.irp.f | 46 + plugins/MRPT_Utils/density_matrix_based.irp.f | 193 + plugins/MRPT_Utils/energies_cas.irp.f | 770 +- plugins/MRPT_Utils/excitations_cas.irp.f | 319 +- plugins/MRPT_Utils/fock_like_operators.irp.f | 2 +- plugins/MRPT_Utils/mrpt_dress.irp.f | 119 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 213 +- plugins/MRPT_Utils/new_way.irp.f | 315 +- .../new_way_second_order_coef.irp.f | 8 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 11 +- .../pt2_new.irp.f | 0 plugins/MRPT_Utils/second_order_new.irp.f | 8 +- plugins/MRPT_Utils/second_order_new_2p.irp.f | 4 +- plugins/Perturbation/NEEDED_CHILDREN_MODULES | 2 +- plugins/Perturbation/pt2_equations.irp.f | 30 - plugins/Psiref_CAS/psi_ref.irp.f | 21 + plugins/SCF_density/.gitignore | 25 + plugins/SCF_density/EZFIO.cfg | 35 + plugins/SCF_density/Fock_matrix.irp.f | 437 ++ .../SCF_density/HF_density_matrix_ao.irp.f | 66 + plugins/SCF_density/NEEDED_CHILDREN_MODULES | 1 + plugins/SCF_density/README.rst | 175 + plugins/SCF_density/damping_SCF.irp.f | 132 + plugins/SCF_density/diagonalize_fock.irp.f | 124 + plugins/SCF_density/huckel.irp.f | 32 + .../Slater_rules_DFT/NEEDED_CHILDREN_MODULES | 1 + plugins/Slater_rules_DFT/README.rst | 12 + .../Slater_rules_DFT.main.irp.f | 38 + plugins/Slater_rules_DFT/energy.irp.f | 7 + .../Slater_rules_DFT/slater_rules_erf.irp.f | 445 ++ plugins/core_integrals/.gitignore | 5 + .../core_integrals/NEEDED_CHILDREN_MODULES | 1 + plugins/core_integrals/README.rst | 12 + .../core_integrals/core_integrals.main.irp.f | 7 + plugins/core_integrals/core_quantities.irp.f | 32 + plugins/loc_cele/loc.f | 2 +- plugins/loc_cele/loc_cele.irp.f | 43 +- plugins/loc_cele/loc_exchange_int.irp.f | 27 +- plugins/loc_cele/loc_exchange_int_act.irp.f | 9 +- plugins/mrcepa0/.gitignore | 5 + plugins/mrcepa0/NEEDED_CHILDREN_MODULES | 2 +- plugins/mrcepa0/dressing.irp.f | 8 +- scripts/compilation/qp_create_ninja.py | 2 +- .../qp_convert_output_to_ezfio.py | 12 +- scripts/generate_h_apply.py | 6 +- scripts/module/module_handler.py | 4 + src/AO_Basis/ao_overlap.irp.f | 45 + src/AO_Basis/aos_value.irp.f | 1 + src/Bitmask/bitmask_cas_routines.irp.f | 21 + ...ze_restart_and_save_all_nstates_diag.irp.f | 16 + ...gonalize_restart_and_save_all_states.irp.f | 2 +- src/Determinants/EZFIO.cfg | 6 + src/Determinants/H_apply.irp.f | 76 + src/Determinants/H_apply_nozmq.template.f | 2 +- src/Determinants/H_apply_zmq.template.f | 2 +- src/Determinants/density_matrix.irp.f | 109 +- ...gonalize_restart_and_save_two_states.irp.f | 27 - src/Determinants/print_wf.irp.f | 41 +- src/Determinants/slater_rules.irp.f | 20 +- src/Determinants/truncate_wf.irp.f | 46 +- src/Determinants/two_body_dm_map.irp.f | 199 +- src/Integrals_Bielec/EZFIO.cfg | 1 + src/Integrals_Monoelec/EZFIO.cfg | 8 + src/Integrals_Monoelec/mo_mono_ints.irp.f | 26 +- src/Integrals_Monoelec/pot_ao_ints.irp.f | 2 +- .../pot_ao_pseudo_ints.irp.f | 3 +- src/Integrals_Monoelec/read_write.irp.f | 9 +- src/MO_Basis/cholesky_mo.irp.f | 92 +- src/MO_Basis/mos.irp.f | 122 + src/MO_Basis/rotate_mos.irp.f | 8 + src/MO_Basis/utils.irp.f | 10 +- src/Pseudo/EZFIO.cfg | 12 + src/Utils/LinearAlgebra.irp.f | 4 + src/Utils/angular_integration.irp.f | 18 +- src/Utils/constants.include.F | 5 + src/Utils/invert.irp.f | 19 + tests/input/h2o.xyz | 2 +- 144 files changed, 15878 insertions(+), 1412 deletions(-) create mode 100644 plugins/All_singles/.gitignore delete mode 100644 plugins/DFT_Utils/EZFIO.cfg create mode 100644 plugins/DFT_Utils/angular.f create mode 100644 plugins/DFT_Utils/functional.irp.f create mode 100644 plugins/FOBOCI/density.irp.f create mode 100644 plugins/FOBOCI/track_orb.irp.f create mode 100644 plugins/Full_CI_ZMQ/.gitignore create mode 100644 plugins/Generators_CAS/Generators_full/.gitignore create mode 100644 plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Generators_CAS/Generators_full/README.rst create mode 100644 plugins/Generators_CAS/Generators_full/generators.irp.f create mode 100644 plugins/Generators_CAS/Generators_full/tree_dependency.png create mode 100644 plugins/Integrals_erf/EZFIO.cfg create mode 100644 plugins/Integrals_erf/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Integrals_erf/ao_bi_integrals_erf.irp.f create mode 100644 plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f create mode 100644 plugins/Integrals_erf/integrals_3_index_erf.irp.f create mode 100644 plugins/Integrals_erf/map_integrals_erf.irp.f create mode 100644 plugins/Integrals_erf/mo_bi_integrals_erf.irp.f create mode 100644 plugins/Integrals_erf/providers_ao_erf.irp.f create mode 100644 plugins/Integrals_erf/qp_ao_erf_ints.irp.f create mode 100644 plugins/Integrals_erf/read_write.irp.f create mode 100644 plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Integrals_restart_DFT/README.rst create mode 100644 plugins/Integrals_restart_DFT/short_range_coulomb.irp.f create mode 100644 plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f create mode 100644 plugins/Kohn_Sham/EZFIO.cfg create mode 100644 plugins/Kohn_Sham/Fock_matrix.irp.f create mode 100644 plugins/Kohn_Sham/HF_density_matrix_ao.irp.f create mode 100644 plugins/Kohn_Sham/KS_SCF.irp.f create mode 100644 plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Kohn_Sham/damping_SCF.irp.f create mode 100644 plugins/Kohn_Sham/diagonalize_fock.irp.f create mode 100644 plugins/Kohn_Sham/potential_functional.irp.f create mode 100644 plugins/MRPT_Utils/MRMP2_density.irp.f create mode 100644 plugins/MRPT_Utils/density_matrix_based.irp.f rename plugins/{Perturbation => MRPT_Utils}/pt2_new.irp.f (100%) create mode 100644 plugins/SCF_density/.gitignore create mode 100644 plugins/SCF_density/EZFIO.cfg create mode 100644 plugins/SCF_density/Fock_matrix.irp.f create mode 100644 plugins/SCF_density/HF_density_matrix_ao.irp.f create mode 100644 plugins/SCF_density/NEEDED_CHILDREN_MODULES create mode 100644 plugins/SCF_density/README.rst create mode 100644 plugins/SCF_density/damping_SCF.irp.f create mode 100644 plugins/SCF_density/diagonalize_fock.irp.f create mode 100644 plugins/SCF_density/huckel.irp.f create mode 100644 plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES create mode 100644 plugins/Slater_rules_DFT/README.rst create mode 100644 plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f create mode 100644 plugins/Slater_rules_DFT/energy.irp.f create mode 100644 plugins/Slater_rules_DFT/slater_rules_erf.irp.f create mode 100644 plugins/core_integrals/.gitignore create mode 100644 plugins/core_integrals/NEEDED_CHILDREN_MODULES create mode 100644 plugins/core_integrals/README.rst create mode 100644 plugins/core_integrals/core_integrals.main.irp.f create mode 100644 plugins/core_integrals/core_quantities.irp.f create mode 100644 plugins/mrcepa0/.gitignore create mode 100644 src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f delete mode 100644 src/Determinants/diagonalize_restart_and_save_two_states.irp.f create mode 100644 src/MO_Basis/rotate_mos.irp.f create mode 100644 src/Utils/invert.irp.f diff --git a/config/gfortran.cfg b/config/gfortran.cfg index c0aa875f..60e32235 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : -Ofast +FCFLAGS : # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : -Ofast +FCFLAGS : # Debugging flags ################# diff --git a/config/ifort.cfg b/config/ifort.cfg index 843e887b..ed3108c5 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0 ################# # [OPENMP] -FC : -qopenmp +FC : -openmp IRPF90_FLAGS : --openmp diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore new file mode 100644 index 00000000..7ac9fbf6 --- /dev/null +++ b/plugins/All_singles/.gitignore @@ -0,0 +1,5 @@ +IRPF90_temp/ +IRPF90_man/ +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 3692710d..f18ba774 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1332,3 +1332,4 @@ subroutine selection_collector(b, pt2) call sort_selection_buffer(b) end subroutine + diff --git a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES index 0b7ce8a9..d212e150 100644 --- a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES +++ b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_CAS Davidson +Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS diff --git a/plugins/DDCI_selected/ddci.irp.f b/plugins/DDCI_selected/ddci.irp.f index 0bfb324f..a1824857 100644 --- a/plugins/DDCI_selected/ddci.irp.f +++ b/plugins/DDCI_selected/ddci.irp.f @@ -5,7 +5,7 @@ program ddci double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) integer :: N_st, degree - N_st = N_states_diag + N_st = N_states allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) character*(64) :: perturbation diff --git a/plugins/DFT_Utils/EZFIO.cfg b/plugins/DFT_Utils/EZFIO.cfg deleted file mode 100644 index 21cc5b98..00000000 --- a/plugins/DFT_Utils/EZFIO.cfg +++ /dev/null @@ -1,4 +0,0 @@ -[energy] -type: double precision -doc: Calculated energy -interface: ezfio diff --git a/plugins/DFT_Utils/angular.f b/plugins/DFT_Utils/angular.f new file mode 100644 index 00000000..a5052a32 --- /dev/null +++ b/plugins/DFT_Utils/angular.f @@ -0,0 +1,6951 @@ + subroutine gen_oh(code, num, x, y, z, w, a, b, v) + implicit logical(a-z) + double precision x(*),y(*),z(*),w(*) + double precision a,b,v + integer code + integer num + double precision c +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated from C to fortran77 by hand. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd +cvw +cvw Given a point on a sphere (specified by a and b), generate all +cvw the equivalent points under Oh symmetry, making grid points with +cvw weight v. +cvw The variable num is increased by the number of different points +cvw generated. +cvw +cvw Depending on code, there are 6...48 different but equivalent +cvw points. +cvw +cvw code=1: (0,0,1) etc ( 6 points) +cvw code=2: (0,a,a) etc, a=1/sqrt(2) ( 12 points) +cvw code=3: (a,a,a) etc, a=1/sqrt(3) ( 8 points) +cvw code=4: (a,a,b) etc, b=sqrt(1-2 a^2) ( 24 points) +cvw code=5: (a,b,0) etc, b=sqrt(1-a^2), a input ( 24 points) +cvw code=6: (a,b,c) etc, c=sqrt(1-a^2-b^2), a/b input ( 48 points) +cvw + goto (1,2,3,4,5,6) code + write (6,*) 'Gen_Oh: Invalid Code' + stop + 1 continue + a=1.0d0 + x(1) = a + y(1) = 0.0d0 + z(1) = 0.0d0 + w(1) = v + x(2) = -a + y(2) = 0.0d0 + z(2) = 0.0d0 + w(2) = v + x(3) = 0.0d0 + y(3) = a + z(3) = 0.0d0 + w(3) = v + x(4) = 0.0d0 + y(4) = -a + z(4) = 0.0d0 + w(4) = v + x(5) = 0.0d0 + y(5) = 0.0d0 + z(5) = a + w(5) = v + x(6) = 0.0d0 + y(6) = 0.0d0 + z(6) = -a + w(6) = v + num=num+6 + return +cvw + 2 continue + a=sqrt(0.5d0) + x( 1) = 0d0 + y( 1) = a + z( 1) = a + w( 1) = v + x( 2) = 0d0 + y( 2) = -a + z( 2) = a + w( 2) = v + x( 3) = 0d0 + y( 3) = a + z( 3) = -a + w( 3) = v + x( 4) = 0d0 + y( 4) = -a + z( 4) = -a + w( 4) = v + x( 5) = a + y( 5) = 0d0 + z( 5) = a + w( 5) = v + x( 6) = -a + y( 6) = 0d0 + z( 6) = a + w( 6) = v + x( 7) = a + y( 7) = 0d0 + z( 7) = -a + w( 7) = v + x( 8) = -a + y( 8) = 0d0 + z( 8) = -a + w( 8) = v + x( 9) = a + y( 9) = a + z( 9) = 0d0 + w( 9) = v + x(10) = -a + y(10) = a + z(10) = 0d0 + w(10) = v + x(11) = a + y(11) = -a + z(11) = 0d0 + w(11) = v + x(12) = -a + y(12) = -a + z(12) = 0d0 + w(12) = v + num=num+12 + return +cvw + 3 continue + a = sqrt(1d0/3d0) + x(1) = a + y(1) = a + z(1) = a + w(1) = v + x(2) = -a + y(2) = a + z(2) = a + w(2) = v + x(3) = a + y(3) = -a + z(3) = a + w(3) = v + x(4) = -a + y(4) = -a + z(4) = a + w(4) = v + x(5) = a + y(5) = a + z(5) = -a + w(5) = v + x(6) = -a + y(6) = a + z(6) = -a + w(6) = v + x(7) = a + y(7) = -a + z(7) = -a + w(7) = v + x(8) = -a + y(8) = -a + z(8) = -a + w(8) = v + num=num+8 + return +cvw + 4 continue + b = sqrt(1d0 - 2d0*a*a) + x( 1) = a + y( 1) = a + z( 1) = b + w( 1) = v + x( 2) = -a + y( 2) = a + z( 2) = b + w( 2) = v + x( 3) = a + y( 3) = -a + z( 3) = b + w( 3) = v + x( 4) = -a + y( 4) = -a + z( 4) = b + w( 4) = v + x( 5) = a + y( 5) = a + z( 5) = -b + w( 5) = v + x( 6) = -a + y( 6) = a + z( 6) = -b + w( 6) = v + x( 7) = a + y( 7) = -a + z( 7) = -b + w( 7) = v + x( 8) = -a + y( 8) = -a + z( 8) = -b + w( 8) = v + x( 9) = a + y( 9) = b + z( 9) = a + w( 9) = v + x(10) = -a + y(10) = b + z(10) = a + w(10) = v + x(11) = a + y(11) = -b + z(11) = a + w(11) = v + x(12) = -a + y(12) = -b + z(12) = a + w(12) = v + x(13) = a + y(13) = b + z(13) = -a + w(13) = v + x(14) = -a + y(14) = b + z(14) = -a + w(14) = v + x(15) = a + y(15) = -b + z(15) = -a + w(15) = v + x(16) = -a + y(16) = -b + z(16) = -a + w(16) = v + x(17) = b + y(17) = a + z(17) = a + w(17) = v + x(18) = -b + y(18) = a + z(18) = a + w(18) = v + x(19) = b + y(19) = -a + z(19) = a + w(19) = v + x(20) = -b + y(20) = -a + z(20) = a + w(20) = v + x(21) = b + y(21) = a + z(21) = -a + w(21) = v + x(22) = -b + y(22) = a + z(22) = -a + w(22) = v + x(23) = b + y(23) = -a + z(23) = -a + w(23) = v + x(24) = -b + y(24) = -a + z(24) = -a + w(24) = v + num=num+24 + return +cvw + 5 continue + b=sqrt(1d0-a*a) + x( 1) = a + y( 1) = b + z( 1) = 0d0 + w( 1) = v + x( 2) = -a + y( 2) = b + z( 2) = 0d0 + w( 2) = v + x( 3) = a + y( 3) = -b + z( 3) = 0d0 + w( 3) = v + x( 4) = -a + y( 4) = -b + z( 4) = 0d0 + w( 4) = v + x( 5) = b + y( 5) = a + z( 5) = 0d0 + w( 5) = v + x( 6) = -b + y( 6) = a + z( 6) = 0d0 + w( 6) = v + x( 7) = b + y( 7) = -a + z( 7) = 0d0 + w( 7) = v + x( 8) = -b + y( 8) = -a + z( 8) = 0d0 + w( 8) = v + x( 9) = a + y( 9) = 0d0 + z( 9) = b + w( 9) = v + x(10) = -a + y(10) = 0d0 + z(10) = b + w(10) = v + x(11) = a + y(11) = 0d0 + z(11) = -b + w(11) = v + x(12) = -a + y(12) = 0d0 + z(12) = -b + w(12) = v + x(13) = b + y(13) = 0d0 + z(13) = a + w(13) = v + x(14) = -b + y(14) = 0d0 + z(14) = a + w(14) = v + x(15) = b + y(15) = 0d0 + z(15) = -a + w(15) = v + x(16) = -b + y(16) = 0d0 + z(16) = -a + w(16) = v + x(17) = 0d0 + y(17) = a + z(17) = b + w(17) = v + x(18) = 0d0 + y(18) = -a + z(18) = b + w(18) = v + x(19) = 0d0 + y(19) = a + z(19) = -b + w(19) = v + x(20) = 0d0 + y(20) = -a + z(20) = -b + w(20) = v + x(21) = 0d0 + y(21) = b + z(21) = a + w(21) = v + x(22) = 0d0 + y(22) = -b + z(22) = a + w(22) = v + x(23) = 0d0 + y(23) = b + z(23) = -a + w(23) = v + x(24) = 0d0 + y(24) = -b + z(24) = -a + w(24) = v + num=num+24 + return +cvw + 6 continue + c=sqrt(1d0 - a*a - b*b) + x( 1) = a + y( 1) = b + z( 1) = c + w( 1) = v + x( 2) = -a + y( 2) = b + z( 2) = c + w( 2) = v + x( 3) = a + y( 3) = -b + z( 3) = c + w( 3) = v + x( 4) = -a + y( 4) = -b + z( 4) = c + w( 4) = v + x( 5) = a + y( 5) = b + z( 5) = -c + w( 5) = v + x( 6) = -a + y( 6) = b + z( 6) = -c + w( 6) = v + x( 7) = a + y( 7) = -b + z( 7) = -c + w( 7) = v + x( 8) = -a + y( 8) = -b + z( 8) = -c + w( 8) = v + x( 9) = a + y( 9) = c + z( 9) = b + w( 9) = v + x(10) = -a + y(10) = c + z(10) = b + w(10) = v + x(11) = a + y(11) = -c + z(11) = b + w(11) = v + x(12) = -a + y(12) = -c + z(12) = b + w(12) = v + x(13) = a + y(13) = c + z(13) = -b + w(13) = v + x(14) = -a + y(14) = c + z(14) = -b + w(14) = v + x(15) = a + y(15) = -c + z(15) = -b + w(15) = v + x(16) = -a + y(16) = -c + z(16) = -b + w(16) = v + x(17) = b + y(17) = a + z(17) = c + w(17) = v + x(18) = -b + y(18) = a + z(18) = c + w(18) = v + x(19) = b + y(19) = -a + z(19) = c + w(19) = v + x(20) = -b + y(20) = -a + z(20) = c + w(20) = v + x(21) = b + y(21) = a + z(21) = -c + w(21) = v + x(22) = -b + y(22) = a + z(22) = -c + w(22) = v + x(23) = b + y(23) = -a + z(23) = -c + w(23) = v + x(24) = -b + y(24) = -a + z(24) = -c + w(24) = v + x(25) = b + y(25) = c + z(25) = a + w(25) = v + x(26) = -b + y(26) = c + z(26) = a + w(26) = v + x(27) = b + y(27) = -c + z(27) = a + w(27) = v + x(28) = -b + y(28) = -c + z(28) = a + w(28) = v + x(29) = b + y(29) = c + z(29) = -a + w(29) = v + x(30) = -b + y(30) = c + z(30) = -a + w(30) = v + x(31) = b + y(31) = -c + z(31) = -a + w(31) = v + x(32) = -b + y(32) = -c + z(32) = -a + w(32) = v + x(33) = c + y(33) = a + z(33) = b + w(33) = v + x(34) = -c + y(34) = a + z(34) = b + w(34) = v + x(35) = c + y(35) = -a + z(35) = b + w(35) = v + x(36) = -c + y(36) = -a + z(36) = b + w(36) = v + x(37) = c + y(37) = a + z(37) = -b + w(37) = v + x(38) = -c + y(38) = a + z(38) = -b + w(38) = v + x(39) = c + y(39) = -a + z(39) = -b + w(39) = v + x(40) = -c + y(40) = -a + z(40) = -b + w(40) = v + x(41) = c + y(41) = b + z(41) = a + w(41) = v + x(42) = -c + y(42) = b + z(42) = a + w(42) = v + x(43) = c + y(43) = -b + z(43) = a + w(43) = v + x(44) = -c + y(44) = -b + z(44) = a + w(44) = v + x(45) = c + y(45) = b + z(45) = -a + w(45) = v + x(46) = -c + y(46) = b + z(46) = -a + w(46) = v + x(47) = c + y(47) = -b + z(47) = -a + w(47) = v + x(48) = -c + y(48) = -b + z(48) = -a + w(48) = v + num=num+48 + return + end + SUBROUTINE LD0006(X,Y,Z,W,N) + DOUBLE PRECISION X( 6) + DOUBLE PRECISION Y( 6) + DOUBLE PRECISION Z( 6) + DOUBLE PRECISION W( 6) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 6-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1666666666666667D+0 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0014(X,Y,Z,W,N) + DOUBLE PRECISION X( 14) + DOUBLE PRECISION Y( 14) + DOUBLE PRECISION Z( 14) + DOUBLE PRECISION W( 14) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 14-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.6666666666666667D-1 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.7500000000000000D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0026(X,Y,Z,W,N) + DOUBLE PRECISION X( 26) + DOUBLE PRECISION Y( 26) + DOUBLE PRECISION Z( 26) + DOUBLE PRECISION W( 26) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 26-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.4761904761904762D-1 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3809523809523810D-1 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3214285714285714D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0038(X,Y,Z,W,N) + DOUBLE PRECISION X( 38) + DOUBLE PRECISION Y( 38) + DOUBLE PRECISION Z( 38) + DOUBLE PRECISION W( 38) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 38-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.9523809523809524D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3214285714285714D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4597008433809831D+0 + V=0.2857142857142857D-1 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0050(X,Y,Z,W,N) + DOUBLE PRECISION X( 50) + DOUBLE PRECISION Y( 50) + DOUBLE PRECISION Z( 50) + DOUBLE PRECISION W( 50) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 50-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1269841269841270D-1 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2257495590828924D-1 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2109375000000000D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3015113445777636D+0 + V=0.2017333553791887D-1 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0074(X,Y,Z,W,N) + DOUBLE PRECISION X( 74) + DOUBLE PRECISION Y( 74) + DOUBLE PRECISION Z( 74) + DOUBLE PRECISION W( 74) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 74-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.5130671797338464D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1660406956574204D-1 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=-0.2958603896103896D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4803844614152614D+0 + V=0.2657620708215946D-1 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3207726489807764D+0 + V=0.1652217099371571D-1 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0086(X,Y,Z,W,N) + DOUBLE PRECISION X( 86) + DOUBLE PRECISION Y( 86) + DOUBLE PRECISION Z( 86) + DOUBLE PRECISION W( 86) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 86-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1154401154401154D-1 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1194390908585628D-1 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3696028464541502D+0 + V=0.1111055571060340D-1 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6943540066026664D+0 + V=0.1187650129453714D-1 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3742430390903412D+0 + V=0.1181230374690448D-1 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0110(X,Y,Z,W,N) + DOUBLE PRECISION X( 110) + DOUBLE PRECISION Y( 110) + DOUBLE PRECISION Z( 110) + DOUBLE PRECISION W( 110) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 110-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.3828270494937162D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.9793737512487512D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1851156353447362D+0 + V=0.8211737283191111D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6904210483822922D+0 + V=0.9942814891178103D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3956894730559419D+0 + V=0.9595471336070963D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4783690288121502D+0 + V=0.9694996361663028D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0146(X,Y,Z,W,N) + DOUBLE PRECISION X( 146) + DOUBLE PRECISION Y( 146) + DOUBLE PRECISION Z( 146) + DOUBLE PRECISION W( 146) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 146-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.5996313688621381D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.7372999718620756D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.7210515360144488D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6764410400114264D+0 + V=0.7116355493117555D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4174961227965453D+0 + V=0.6753829486314477D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1574676672039082D+0 + V=0.7574394159054034D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1403553811713183D+0 + B=0.4493328323269557D+0 + V=0.6991087353303262D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0170(X,Y,Z,W,N) + DOUBLE PRECISION X( 170) + DOUBLE PRECISION Y( 170) + DOUBLE PRECISION Z( 170) + DOUBLE PRECISION W( 170) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 170-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.5544842902037365D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.6071332770670752D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.6383674773515093D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2551252621114134D+0 + V=0.5183387587747790D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6743601460362766D+0 + V=0.6317929009813725D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4318910696719410D+0 + V=0.6201670006589077D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2613931360335988D+0 + V=0.5477143385137348D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4990453161796037D+0 + B=0.1446630744325115D+0 + V=0.5968383987681156D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0194(X,Y,Z,W,N) + DOUBLE PRECISION X( 194) + DOUBLE PRECISION Y( 194) + DOUBLE PRECISION Z( 194) + DOUBLE PRECISION W( 194) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 194-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1782340447244611D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.5716905949977102D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.5573383178848738D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6712973442695226D+0 + V=0.5608704082587997D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2892465627575439D+0 + V=0.5158237711805383D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4446933178717437D+0 + V=0.5518771467273614D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1299335447650067D+0 + V=0.4106777028169394D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3457702197611283D+0 + V=0.5051846064614808D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1590417105383530D+0 + B=0.8360360154824589D+0 + V=0.5530248916233094D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0230(X,Y,Z,W,N) + DOUBLE PRECISION X( 230) + DOUBLE PRECISION Y( 230) + DOUBLE PRECISION Z( 230) + DOUBLE PRECISION W( 230) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 230-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=-0.5522639919727325D-1 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.4450274607445226D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4492044687397611D+0 + V=0.4496841067921404D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2520419490210201D+0 + V=0.5049153450478750D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6981906658447242D+0 + V=0.3976408018051883D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6587405243460960D+0 + V=0.4401400650381014D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4038544050097660D-1 + V=0.1724544350544401D-1 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5823842309715585D+0 + V=0.4231083095357343D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3545877390518688D+0 + V=0.5198069864064399D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2272181808998187D+0 + B=0.4864661535886647D+0 + V=0.4695720972568883D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0266(X,Y,Z,W,N) + DOUBLE PRECISION X( 266) + DOUBLE PRECISION Y( 266) + DOUBLE PRECISION Z( 266) + DOUBLE PRECISION W( 266) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 266-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=-0.1313769127326952D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=-0.2522728704859336D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.4186853881700583D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7039373391585475D+0 + V=0.5315167977810885D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1012526248572414D+0 + V=0.4047142377086219D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4647448726420539D+0 + V=0.4112482394406990D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3277420654971629D+0 + V=0.3595584899758782D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6620338663699974D+0 + V=0.4256131351428158D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8506508083520399D+0 + V=0.4229582700647240D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3233484542692899D+0 + B=0.1153112011009701D+0 + V=0.4080914225780505D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2314790158712601D+0 + B=0.5244939240922365D+0 + V=0.4071467593830964D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0302(X,Y,Z,W,N) + DOUBLE PRECISION X( 302) + DOUBLE PRECISION Y( 302) + DOUBLE PRECISION Z( 302) + DOUBLE PRECISION W( 302) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 302-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.8545911725128148D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3599119285025571D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3515640345570105D+0 + V=0.3449788424305883D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6566329410219612D+0 + V=0.3604822601419882D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4729054132581005D+0 + V=0.3576729661743367D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9618308522614784D-1 + V=0.2352101413689164D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2219645236294178D+0 + V=0.3108953122413675D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7011766416089545D+0 + V=0.3650045807677255D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2644152887060663D+0 + V=0.2982344963171804D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5718955891878961D+0 + V=0.3600820932216460D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2510034751770465D+0 + B=0.8000727494073952D+0 + V=0.3571540554273387D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1233548532583327D+0 + B=0.4127724083168531D+0 + V=0.3392312205006170D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0350(X,Y,Z,W,N) + DOUBLE PRECISION X( 350) + DOUBLE PRECISION Y( 350) + DOUBLE PRECISION Z( 350) + DOUBLE PRECISION W( 350) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 350-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.3006796749453936D-2 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3050627745650771D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7068965463912316D+0 + V=0.1621104600288991D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4794682625712025D+0 + V=0.3005701484901752D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1927533154878019D+0 + V=0.2990992529653774D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6930357961327123D+0 + V=0.2982170644107595D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3608302115520091D+0 + V=0.2721564237310992D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6498486161496169D+0 + V=0.3033513795811141D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1932945013230339D+0 + V=0.3007949555218533D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3800494919899303D+0 + V=0.2881964603055307D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2899558825499574D+0 + B=0.7934537856582316D+0 + V=0.2958357626535696D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9684121455103957D-1 + B=0.8280801506686862D+0 + V=0.3036020026407088D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1833434647041659D+0 + B=0.9074658265305127D+0 + V=0.2832187403926303D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0434(X,Y,Z,W,N) + DOUBLE PRECISION X( 434) + DOUBLE PRECISION Y( 434) + DOUBLE PRECISION Z( 434) + DOUBLE PRECISION W( 434) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 434-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.5265897968224436D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2548219972002607D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2512317418927307D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6909346307509111D+0 + V=0.2530403801186355D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1774836054609158D+0 + V=0.2014279020918528D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4914342637784746D+0 + V=0.2501725168402936D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6456664707424256D+0 + V=0.2513267174597564D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2861289010307638D+0 + V=0.2302694782227416D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7568084367178018D-1 + V=0.1462495621594614D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3927259763368002D+0 + V=0.2445373437312980D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8818132877794288D+0 + V=0.2417442375638981D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9776428111182649D+0 + V=0.1910951282179532D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2054823696403044D+0 + B=0.8689460322872412D+0 + V=0.2416930044324775D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5905157048925271D+0 + B=0.7999278543857286D+0 + V=0.2512236854563495D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5550152361076807D+0 + B=0.7717462626915901D+0 + V=0.2496644054553086D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9371809858553722D+0 + B=0.3344363145343455D+0 + V=0.2236607760437849D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0590(X,Y,Z,W,N) + DOUBLE PRECISION X( 590) + DOUBLE PRECISION Y( 590) + DOUBLE PRECISION Z( 590) + DOUBLE PRECISION W( 590) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 590-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.3095121295306187D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1852379698597489D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7040954938227469D+0 + V=0.1871790639277744D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6807744066455243D+0 + V=0.1858812585438317D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6372546939258752D+0 + V=0.1852028828296213D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5044419707800358D+0 + V=0.1846715956151242D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4215761784010967D+0 + V=0.1818471778162769D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3317920736472123D+0 + V=0.1749564657281154D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2384736701421887D+0 + V=0.1617210647254411D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1459036449157763D+0 + V=0.1384737234851692D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6095034115507196D-1 + V=0.9764331165051050D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6116843442009876D+0 + V=0.1857161196774078D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3964755348199858D+0 + V=0.1705153996395864D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1724782009907724D+0 + V=0.1300321685886048D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5610263808622060D+0 + B=0.3518280927733519D+0 + V=0.1842866472905286D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4742392842551980D+0 + B=0.2634716655937950D+0 + V=0.1802658934377451D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5984126497885380D+0 + B=0.1816640840360209D+0 + V=0.1849830560443660D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3791035407695563D+0 + B=0.1720795225656878D+0 + V=0.1713904507106709D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2778673190586244D+0 + B=0.8213021581932511D-1 + V=0.1555213603396808D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5033564271075117D+0 + B=0.8999205842074875D-1 + V=0.1802239128008525D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0770(X,Y,Z,W,N) + DOUBLE PRECISION X( 770) + DOUBLE PRECISION Y( 770) + DOUBLE PRECISION Z( 770) + DOUBLE PRECISION W( 770) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 770-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.2192942088181184D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1436433617319080D-2 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1421940344335877D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5087204410502360D-1 + V=0.6798123511050502D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1228198790178831D+0 + V=0.9913184235294912D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2026890814408786D+0 + V=0.1180207833238949D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2847745156464294D+0 + V=0.1296599602080921D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3656719078978026D+0 + V=0.1365871427428316D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4428264886713469D+0 + V=0.1402988604775325D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5140619627249735D+0 + V=0.1418645563595609D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6306401219166803D+0 + V=0.1421376741851662D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6716883332022612D+0 + V=0.1423996475490962D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6979792685336881D+0 + V=0.1431554042178567D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1446865674195309D+0 + V=0.9254401499865368D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3390263475411216D+0 + V=0.1250239995053509D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5335804651263506D+0 + V=0.1394365843329230D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6944024393349413D-1 + B=0.2355187894242326D+0 + V=0.1127089094671749D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2269004109529460D+0 + B=0.4102182474045730D+0 + V=0.1345753760910670D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8025574607775339D-1 + B=0.6214302417481605D+0 + V=0.1424957283316783D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1467999527896572D+0 + B=0.3245284345717394D+0 + V=0.1261523341237750D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1571507769824727D+0 + B=0.5224482189696630D+0 + V=0.1392547106052696D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2365702993157246D+0 + B=0.6017546634089558D+0 + V=0.1418761677877656D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7714815866765732D-1 + B=0.4346575516141163D+0 + V=0.1338366684479554D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3062936666210730D+0 + B=0.4908826589037616D+0 + V=0.1393700862676131D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3822477379524787D+0 + B=0.5648768149099500D+0 + V=0.1415914757466932D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD0974(X,Y,Z,W,N) + DOUBLE PRECISION X( 974) + DOUBLE PRECISION Y( 974) + DOUBLE PRECISION Z( 974) + DOUBLE PRECISION W( 974) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 974-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1438294190527431D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1125772288287004D-2 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4292963545341347D-1 + V=0.4948029341949241D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1051426854086404D+0 + V=0.7357990109125470D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1750024867623087D+0 + V=0.8889132771304384D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2477653379650257D+0 + V=0.9888347838921435D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3206567123955957D+0 + V=0.1053299681709471D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3916520749849983D+0 + V=0.1092778807014578D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4590825874187624D+0 + V=0.1114389394063227D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5214563888415861D+0 + V=0.1123724788051555D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6253170244654199D+0 + V=0.1125239325243814D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6637926744523170D+0 + V=0.1126153271815905D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6910410398498301D+0 + V=0.1130286931123841D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7052907007457760D+0 + V=0.1134986534363955D-2 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1236686762657990D+0 + V=0.6823367927109931D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2940777114468387D+0 + V=0.9454158160447096D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4697753849207649D+0 + V=0.1074429975385679D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6334563241139567D+0 + V=0.1129300086569132D-2 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5974048614181342D-1 + B=0.2029128752777523D+0 + V=0.8436884500901954D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1375760408473636D+0 + B=0.4602621942484054D+0 + V=0.1075255720448885D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3391016526336286D+0 + B=0.5030673999662036D+0 + V=0.1108577236864462D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1271675191439820D+0 + B=0.2817606422442134D+0 + V=0.9566475323783357D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2693120740413512D+0 + B=0.4331561291720157D+0 + V=0.1080663250717391D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1419786452601918D+0 + B=0.6256167358580814D+0 + V=0.1126797131196295D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6709284600738255D-1 + B=0.3798395216859157D+0 + V=0.1022568715358061D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7057738183256172D-1 + B=0.5517505421423520D+0 + V=0.1108960267713108D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2783888477882155D+0 + B=0.6029619156159187D+0 + V=0.1122790653435766D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1979578938917407D+0 + B=0.3589606329589096D+0 + V=0.1032401847117460D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2087307061103274D+0 + B=0.5348666438135476D+0 + V=0.1107249382283854D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4055122137872836D+0 + B=0.5674997546074373D+0 + V=0.1121780048519972D-2 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD1202(X,Y,Z,W,N) + DOUBLE PRECISION X(1202) + DOUBLE PRECISION Y(1202) + DOUBLE PRECISION Z(1202) + DOUBLE PRECISION W(1202) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 1202-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1105189233267572D-3 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.9205232738090741D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.9133159786443561D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3712636449657089D-1 + V=0.3690421898017899D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9140060412262223D-1 + V=0.5603990928680660D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1531077852469906D+0 + V=0.6865297629282609D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2180928891660612D+0 + V=0.7720338551145630D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2839874532200175D+0 + V=0.8301545958894795D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3491177600963764D+0 + V=0.8686692550179628D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4121431461444309D+0 + V=0.8927076285846890D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4718993627149127D+0 + V=0.9060820238568219D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5273145452842337D+0 + V=0.9119777254940867D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6209475332444019D+0 + V=0.9128720138604181D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6569722711857291D+0 + V=0.9130714935691735D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6841788309070143D+0 + V=0.9152873784554116D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7012604330123631D+0 + V=0.9187436274321654D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1072382215478166D+0 + V=0.5176977312965694D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2582068959496968D+0 + V=0.7331143682101417D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4172752955306717D+0 + V=0.8463232836379928D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5700366911792503D+0 + V=0.9031122694253992D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9827986018263947D+0 + B=0.1771774022615325D+0 + V=0.6485778453163257D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9624249230326228D+0 + B=0.2475716463426288D+0 + V=0.7435030910982369D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9402007994128811D+0 + B=0.3354616289066489D+0 + V=0.7998527891839054D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9320822040143202D+0 + B=0.3173615246611977D+0 + V=0.8101731497468018D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9043674199393299D+0 + B=0.4090268427085357D+0 + V=0.8483389574594331D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8912407560074747D+0 + B=0.3854291150669224D+0 + V=0.8556299257311812D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8676435628462708D+0 + B=0.4932221184851285D+0 + V=0.8803208679738260D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8581979986041619D+0 + B=0.4785320675922435D+0 + V=0.8811048182425720D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8396753624049856D+0 + B=0.4507422593157064D+0 + V=0.8850282341265444D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8165288564022188D+0 + B=0.5632123020762100D+0 + V=0.9021342299040653D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8015469370783529D+0 + B=0.5434303569693900D+0 + V=0.9010091677105086D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7773563069070351D+0 + B=0.5123518486419871D+0 + V=0.9022692938426915D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7661621213900394D+0 + B=0.6394279634749102D+0 + V=0.9158016174693465D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7553584143533510D+0 + B=0.6269805509024392D+0 + V=0.9131578003189435D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7344305757559503D+0 + B=0.6031161693096310D+0 + V=0.9107813579482705D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7043837184021765D+0 + B=0.5693702498468441D+0 + V=0.9105760258970126D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD1454(X,Y,Z,W,N) + DOUBLE PRECISION X(1454) + DOUBLE PRECISION Y(1454) + DOUBLE PRECISION Z(1454) + DOUBLE PRECISION W(1454) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 1454-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.7777160743261247D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.7557646413004701D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3229290663413854D-1 + V=0.2841633806090617D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8036733271462222D-1 + V=0.4374419127053555D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1354289960531653D+0 + V=0.5417174740872172D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1938963861114426D+0 + V=0.6148000891358593D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2537343715011275D+0 + V=0.6664394485800705D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3135251434752570D+0 + V=0.7025039356923220D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3721558339375338D+0 + V=0.7268511789249627D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4286809575195696D+0 + V=0.7422637534208629D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4822510128282994D+0 + V=0.7509545035841214D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5320679333566263D+0 + V=0.7548535057718401D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6172998195394274D+0 + V=0.7554088969774001D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6510679849127481D+0 + V=0.7553147174442808D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6777315251687360D+0 + V=0.7564767653292297D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6963109410648741D+0 + V=0.7587991808518730D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7058935009831749D+0 + V=0.7608261832033027D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9955546194091857D+0 + V=0.4021680447874916D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9734115901794209D+0 + V=0.5804871793945964D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9275693732388626D+0 + V=0.6792151955945159D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8568022422795103D+0 + V=0.7336741211286294D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7623495553719372D+0 + V=0.7581866300989608D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5707522908892223D+0 + B=0.4387028039889501D+0 + V=0.7538257859800743D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5196463388403083D+0 + B=0.3858908414762617D+0 + V=0.7483517247053123D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4646337531215351D+0 + B=0.3301937372343854D+0 + V=0.7371763661112059D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4063901697557691D+0 + B=0.2725423573563777D+0 + V=0.7183448895756934D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3456329466643087D+0 + B=0.2139510237495250D+0 + V=0.6895815529822191D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2831395121050332D+0 + B=0.1555922309786647D+0 + V=0.6480105801792886D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2197682022925330D+0 + B=0.9892878979686097D-1 + V=0.5897558896594636D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1564696098650355D+0 + B=0.4598642910675510D-1 + V=0.5095708849247346D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6027356673721295D+0 + B=0.3376625140173426D+0 + V=0.7536906428909755D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5496032320255096D+0 + B=0.2822301309727988D+0 + V=0.7472505965575118D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4921707755234567D+0 + B=0.2248632342592540D+0 + V=0.7343017132279698D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4309422998598483D+0 + B=0.1666224723456479D+0 + V=0.7130871582177445D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3664108182313672D+0 + B=0.1086964901822169D+0 + V=0.6817022032112776D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2990189057758436D+0 + B=0.5251989784120085D-1 + V=0.6380941145604121D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6268724013144998D+0 + B=0.2297523657550023D+0 + V=0.7550381377920310D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5707324144834607D+0 + B=0.1723080607093800D+0 + V=0.7478646640144802D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5096360901960365D+0 + B=0.1140238465390513D+0 + V=0.7335918720601220D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4438729938312456D+0 + B=0.5611522095882537D-1 + V=0.7110120527658118D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6419978471082389D+0 + B=0.1164174423140873D+0 + V=0.7571363978689501D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5817218061802611D+0 + B=0.5797589531445219D-1 + V=0.7489908329079234D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD1730(X,Y,Z,W,N) + DOUBLE PRECISION X(1730) + DOUBLE PRECISION Y(1730) + DOUBLE PRECISION Z(1730) + DOUBLE PRECISION W(1730) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 1730-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.6309049437420976D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.6398287705571748D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.6357185073530720D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2860923126194662D-1 + V=0.2221207162188168D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7142556767711522D-1 + V=0.3475784022286848D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1209199540995559D+0 + V=0.4350742443589804D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1738673106594379D+0 + V=0.4978569136522127D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2284645438467734D+0 + V=0.5435036221998053D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2834807671701512D+0 + V=0.5765913388219542D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3379680145467339D+0 + V=0.6001200359226003D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3911355454819537D+0 + V=0.6162178172717512D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4422860353001403D+0 + V=0.6265218152438485D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4907781568726057D+0 + V=0.6323987160974212D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5360006153211468D+0 + V=0.6350767851540569D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6142105973596603D+0 + V=0.6354362775297107D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6459300387977504D+0 + V=0.6352302462706235D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6718056125089225D+0 + V=0.6358117881417972D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6910888533186254D+0 + V=0.6373101590310117D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7030467416823252D+0 + V=0.6390428961368665D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8354951166354646D-1 + V=0.3186913449946576D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2050143009099486D+0 + V=0.4678028558591711D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3370208290706637D+0 + V=0.5538829697598626D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4689051484233963D+0 + V=0.6044475907190476D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5939400424557334D+0 + V=0.6313575103509012D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1394983311832261D+0 + B=0.4097581162050343D-1 + V=0.4078626431855630D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1967999180485014D+0 + B=0.8851987391293348D-1 + V=0.4759933057812725D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2546183732548967D+0 + B=0.1397680182969819D+0 + V=0.5268151186413440D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3121281074713875D+0 + B=0.1929452542226526D+0 + V=0.5643048560507316D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3685981078502492D+0 + B=0.2467898337061562D+0 + V=0.5914501076613073D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4233760321547856D+0 + B=0.3003104124785409D+0 + V=0.6104561257874195D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4758671236059246D+0 + B=0.3526684328175033D+0 + V=0.6230252860707806D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5255178579796463D+0 + B=0.4031134861145713D+0 + V=0.6305618761760796D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5718025633734589D+0 + B=0.4509426448342351D+0 + V=0.6343092767597889D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2686927772723415D+0 + B=0.4711322502423248D-1 + V=0.5176268945737826D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3306006819904809D+0 + B=0.9784487303942695D-1 + V=0.5564840313313692D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3904906850594983D+0 + B=0.1505395810025273D+0 + V=0.5856426671038980D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4479957951904390D+0 + B=0.2039728156296050D+0 + V=0.6066386925777091D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5027076848919780D+0 + B=0.2571529941121107D+0 + V=0.6208824962234458D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5542087392260217D+0 + B=0.3092191375815670D+0 + V=0.6296314297822907D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6020850887375187D+0 + B=0.3593807506130276D+0 + V=0.6340423756791859D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4019851409179594D+0 + B=0.5063389934378671D-1 + V=0.5829627677107342D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4635614567449800D+0 + B=0.1032422269160612D+0 + V=0.6048693376081110D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5215860931591575D+0 + B=0.1566322094006254D+0 + V=0.6202362317732461D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5758202499099271D+0 + B=0.2098082827491099D+0 + V=0.6299005328403779D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6259893683876795D+0 + B=0.2618824114553391D+0 + V=0.6347722390609353D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5313795124811891D+0 + B=0.5263245019338556D-1 + V=0.6203778981238834D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5893317955931995D+0 + B=0.1061059730982005D+0 + V=0.6308414671239979D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6426246321215801D+0 + B=0.1594171564034221D+0 + V=0.6362706466959498D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6511904367376113D+0 + B=0.5354789536565540D-1 + V=0.6375414170333233D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD2030(X,Y,Z,W,N) + DOUBLE PRECISION X(2030) + DOUBLE PRECISION Y(2030) + DOUBLE PRECISION Z(2030) + DOUBLE PRECISION W(2030) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 2030-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.4656031899197431D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.5421549195295507D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2540835336814348D-1 + V=0.1778522133346553D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6399322800504915D-1 + V=0.2811325405682796D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1088269469804125D+0 + V=0.3548896312631459D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1570670798818287D+0 + V=0.4090310897173364D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2071163932282514D+0 + V=0.4493286134169965D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2578914044450844D+0 + V=0.4793728447962723D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3085687558169623D+0 + V=0.5015415319164265D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3584719706267024D+0 + V=0.5175127372677937D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4070135594428709D+0 + V=0.5285522262081019D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4536618626222638D+0 + V=0.5356832703713962D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4979195686463577D+0 + V=0.5397914736175170D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5393075111126999D+0 + V=0.5416899441599930D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6115617676843916D+0 + V=0.5419308476889938D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6414308435160159D+0 + V=0.5416936902030596D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6664099412721607D+0 + V=0.5419544338703164D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6859161771214913D+0 + V=0.5428983656630975D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6993625593503890D+0 + V=0.5442286500098193D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7062393387719380D+0 + V=0.5452250345057301D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7479028168349763D-1 + V=0.2568002497728530D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1848951153969366D+0 + V=0.3827211700292145D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3059529066581305D+0 + V=0.4579491561917824D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4285556101021362D+0 + V=0.5042003969083574D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5468758653496526D+0 + V=0.5312708889976025D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6565821978343439D+0 + V=0.5438401790747117D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1253901572367117D+0 + B=0.3681917226439641D-1 + V=0.3316041873197344D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1775721510383941D+0 + B=0.7982487607213301D-1 + V=0.3899113567153771D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2305693358216114D+0 + B=0.1264640966592335D+0 + V=0.4343343327201309D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2836502845992063D+0 + B=0.1751585683418957D+0 + V=0.4679415262318919D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3361794746232590D+0 + B=0.2247995907632670D+0 + V=0.4930847981631031D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3875979172264824D+0 + B=0.2745299257422246D+0 + V=0.5115031867540091D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4374019316999074D+0 + B=0.3236373482441118D+0 + V=0.5245217148457367D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4851275843340022D+0 + B=0.3714967859436741D+0 + V=0.5332041499895321D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5303391803806868D+0 + B=0.4175353646321745D+0 + V=0.5384583126021542D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5726197380596287D+0 + B=0.4612084406355461D+0 + V=0.5411067210798852D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2431520732564863D+0 + B=0.4258040133043952D-1 + V=0.4259797391468714D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3002096800895869D+0 + B=0.8869424306722721D-1 + V=0.4604931368460021D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3558554457457432D+0 + B=0.1368811706510655D+0 + V=0.4871814878255202D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4097782537048887D+0 + B=0.1860739985015033D+0 + V=0.5072242910074885D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4616337666067458D+0 + B=0.2354235077395853D+0 + V=0.5217069845235350D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5110707008417874D+0 + B=0.2842074921347011D+0 + V=0.5315785966280310D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5577415286163795D+0 + B=0.3317784414984102D+0 + V=0.5376833708758905D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6013060431366950D+0 + B=0.3775299002040700D+0 + V=0.5408032092069521D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3661596767261781D+0 + B=0.4599367887164592D-1 + V=0.4842744917904866D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4237633153506581D+0 + B=0.9404893773654421D-1 + V=0.5048926076188130D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4786328454658452D+0 + B=0.1431377109091971D+0 + V=0.5202607980478373D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5305702076789774D+0 + B=0.1924186388843570D+0 + V=0.5309932388325743D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5793436224231788D+0 + B=0.2411590944775190D+0 + V=0.5377419770895208D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6247069017094747D+0 + B=0.2886871491583605D+0 + V=0.5411696331677717D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4874315552535204D+0 + B=0.4804978774953206D-1 + V=0.5197996293282420D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5427337322059053D+0 + B=0.9716857199366665D-1 + V=0.5311120836622945D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5943493747246700D+0 + B=0.1465205839795055D+0 + V=0.5384309319956951D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6421314033564943D+0 + B=0.1953579449803574D+0 + V=0.5421859504051886D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6020628374713980D+0 + B=0.4916375015738108D-1 + V=0.5390948355046314D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6529222529856881D+0 + B=0.9861621540127005D-1 + V=0.5433312705027845D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD2354(X,Y,Z,W,N) + DOUBLE PRECISION X(2354) + DOUBLE PRECISION Y(2354) + DOUBLE PRECISION Z(2354) + DOUBLE PRECISION W(2354) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 2354-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.3922616270665292D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.4703831750854424D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.4678202801282136D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2290024646530589D-1 + V=0.1437832228979900D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5779086652271284D-1 + V=0.2303572493577644D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9863103576375984D-1 + V=0.2933110752447454D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1428155792982185D+0 + V=0.3402905998359838D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1888978116601463D+0 + V=0.3759138466870372D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2359091682970210D+0 + V=0.4030638447899798D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2831228833706171D+0 + V=0.4236591432242211D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3299495857966693D+0 + V=0.4390522656946746D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3758840802660796D+0 + V=0.4502523466626247D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4204751831009480D+0 + V=0.4580577727783541D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4633068518751051D+0 + V=0.4631391616615899D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5039849474507313D+0 + V=0.4660928953698676D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5421265793440747D+0 + V=0.4674751807936953D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6092660230557310D+0 + V=0.4676414903932920D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6374654204984869D+0 + V=0.4674086492347870D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6615136472609892D+0 + V=0.4674928539483207D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6809487285958127D+0 + V=0.4680748979686447D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6952980021665196D+0 + V=0.4690449806389040D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7041245497695400D+0 + V=0.4699877075860818D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6744033088306065D-1 + V=0.2099942281069176D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1678684485334166D+0 + V=0.3172269150712804D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2793559049539613D+0 + V=0.3832051358546523D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3935264218057639D+0 + V=0.4252193818146985D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5052629268232558D+0 + V=0.4513807963755000D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6107905315437531D+0 + V=0.4657797469114178D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1135081039843524D+0 + B=0.3331954884662588D-1 + V=0.2733362800522836D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1612866626099378D+0 + B=0.7247167465436538D-1 + V=0.3235485368463559D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2100786550168205D+0 + B=0.1151539110849745D+0 + V=0.3624908726013453D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2592282009459942D+0 + B=0.1599491097143677D+0 + V=0.3925540070712828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3081740561320203D+0 + B=0.2058699956028027D+0 + V=0.4156129781116235D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3564289781578164D+0 + B=0.2521624953502911D+0 + V=0.4330644984623263D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4035587288240703D+0 + B=0.2982090785797674D+0 + V=0.4459677725921312D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4491671196373903D+0 + B=0.3434762087235733D+0 + V=0.4551593004456795D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4928854782917489D+0 + B=0.3874831357203437D+0 + V=0.4613341462749918D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5343646791958988D+0 + B=0.4297814821746926D+0 + V=0.4651019618269806D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5732683216530990D+0 + B=0.4699402260943537D+0 + V=0.4670249536100625D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2214131583218986D+0 + B=0.3873602040643895D-1 + V=0.3549555576441708D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2741796504750071D+0 + B=0.8089496256902013D-1 + V=0.3856108245249010D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3259797439149485D+0 + B=0.1251732177620872D+0 + V=0.4098622845756882D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3765441148826891D+0 + B=0.1706260286403185D+0 + V=0.4286328604268950D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4255773574530558D+0 + B=0.2165115147300408D+0 + V=0.4427802198993945D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4727795117058430D+0 + B=0.2622089812225259D+0 + V=0.4530473511488561D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5178546895819012D+0 + B=0.3071721431296201D+0 + V=0.4600805475703138D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5605141192097460D+0 + B=0.3508998998801138D+0 + V=0.4644599059958017D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6004763319352512D+0 + B=0.3929160876166931D+0 + V=0.4667274455712508D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3352842634946949D+0 + B=0.4202563457288019D-1 + V=0.4069360518020356D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3891971629814670D+0 + B=0.8614309758870850D-1 + V=0.4260442819919195D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4409875565542281D+0 + B=0.1314500879380001D+0 + V=0.4408678508029063D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4904893058592484D+0 + B=0.1772189657383859D+0 + V=0.4518748115548597D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5375056138769549D+0 + B=0.2228277110050294D+0 + V=0.4595564875375116D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5818255708669969D+0 + B=0.2677179935014386D+0 + V=0.4643988774315846D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6232334858144959D+0 + B=0.3113675035544165D+0 + V=0.4668827491646946D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4489485354492058D+0 + B=0.4409162378368174D-1 + V=0.4400541823741973D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5015136875933150D+0 + B=0.8939009917748489D-1 + V=0.4514512890193797D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5511300550512623D+0 + B=0.1351806029383365D+0 + V=0.4596198627347549D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5976720409858000D+0 + B=0.1808370355053196D+0 + V=0.4648659016801781D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6409956378989354D+0 + B=0.2257852192301602D+0 + V=0.4675502017157673D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5581222330827514D+0 + B=0.4532173421637160D-1 + V=0.4598494476455523D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6074705984161695D+0 + B=0.9117488031840314D-1 + V=0.4654916955152048D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6532272537379033D+0 + B=0.1369294213140155D+0 + V=0.4684709779505137D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6594761494500487D+0 + B=0.4589901487275583D-1 + V=0.4691445539106986D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD2702(X,Y,Z,W,N) + DOUBLE PRECISION X(2702) + DOUBLE PRECISION Y(2702) + DOUBLE PRECISION Z(2702) + DOUBLE PRECISION W(2702) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 2702-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.2998675149888161D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.4077860529495355D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2065562538818703D-1 + V=0.1185349192520667D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5250918173022379D-1 + V=0.1913408643425751D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8993480082038376D-1 + V=0.2452886577209897D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1306023924436019D+0 + V=0.2862408183288702D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1732060388531418D+0 + V=0.3178032258257357D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2168727084820249D+0 + V=0.3422945667633690D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2609528309173586D+0 + V=0.3612790520235922D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3049252927938952D+0 + V=0.3758638229818521D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3483484138084404D+0 + V=0.3868711798859953D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3908321549106406D+0 + V=0.3949429933189938D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4320210071894814D+0 + V=0.4006068107541156D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4715824795890053D+0 + V=0.4043192149672723D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5091984794078453D+0 + V=0.4064947495808078D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5445580145650803D+0 + V=0.4075245619813152D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6072575796841768D+0 + V=0.4076423540893566D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6339484505755803D+0 + V=0.4074280862251555D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6570718257486958D+0 + V=0.4074163756012244D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6762557330090709D+0 + V=0.4077647795071246D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6911161696923790D+0 + V=0.4084517552782530D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7012841911659961D+0 + V=0.4092468459224052D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7064559272410020D+0 + V=0.4097872687240906D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6123554989894765D-1 + V=0.1738986811745028D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1533070348312393D+0 + V=0.2659616045280191D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2563902605244206D+0 + V=0.3240596008171533D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3629346991663361D+0 + V=0.3621195964432943D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4683949968987538D+0 + V=0.3868838330760539D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5694479240657952D+0 + V=0.4018911532693111D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6634465430993955D+0 + V=0.4089929432983252D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1033958573552305D+0 + B=0.3034544009063584D-1 + V=0.2279907527706409D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1473521412414395D+0 + B=0.6618803044247135D-1 + V=0.2715205490578897D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1924552158705967D+0 + B=0.1054431128987715D+0 + V=0.3057917896703976D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2381094362890328D+0 + B=0.1468263551238858D+0 + V=0.3326913052452555D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2838121707936760D+0 + B=0.1894486108187886D+0 + V=0.3537334711890037D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3291323133373415D+0 + B=0.2326374238761579D+0 + V=0.3700567500783129D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3736896978741460D+0 + B=0.2758485808485768D+0 + V=0.3825245372589122D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4171406040760013D+0 + B=0.3186179331996921D+0 + V=0.3918125171518296D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4591677985256915D+0 + B=0.3605329796303794D+0 + V=0.3984720419937579D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4994733831718418D+0 + B=0.4012147253586509D+0 + V=0.4029746003338211D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5377731830445096D+0 + B=0.4403050025570692D+0 + V=0.4057428632156627D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5737917830001331D+0 + B=0.4774565904277483D+0 + V=0.4071719274114857D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2027323586271389D+0 + B=0.3544122504976147D-1 + V=0.2990236950664119D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2516942375187273D+0 + B=0.7418304388646328D-1 + V=0.3262951734212878D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3000227995257181D+0 + B=0.1150502745727186D+0 + V=0.3482634608242413D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3474806691046342D+0 + B=0.1571963371209364D+0 + V=0.3656596681700892D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3938103180359209D+0 + B=0.1999631877247100D+0 + V=0.3791740467794218D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4387519590455703D+0 + B=0.2428073457846535D+0 + V=0.3894034450156905D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4820503960077787D+0 + B=0.2852575132906155D+0 + V=0.3968600245508371D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5234573778475101D+0 + B=0.3268884208674639D+0 + V=0.4019931351420050D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5627318647235282D+0 + B=0.3673033321675939D+0 + V=0.4052108801278599D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5996390607156954D+0 + B=0.4061211551830290D+0 + V=0.4068978613940934D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3084780753791947D+0 + B=0.3860125523100059D-1 + V=0.3454275351319704D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3589988275920223D+0 + B=0.7928938987104867D-1 + V=0.3629963537007920D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4078628415881973D+0 + B=0.1212614643030087D+0 + V=0.3770187233889873D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4549287258889735D+0 + B=0.1638770827382693D+0 + V=0.3878608613694378D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5000278512957279D+0 + B=0.2065965798260176D+0 + V=0.3959065270221274D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5429785044928199D+0 + B=0.2489436378852235D+0 + V=0.4015286975463570D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5835939850491711D+0 + B=0.2904811368946891D+0 + V=0.4050866785614717D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6216870353444856D+0 + B=0.3307941957666609D+0 + V=0.4069320185051913D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4151104662709091D+0 + B=0.4064829146052554D-1 + V=0.3760120964062763D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4649804275009218D+0 + B=0.8258424547294755D-1 + V=0.3870969564418064D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5124695757009662D+0 + B=0.1251841962027289D+0 + V=0.3955287790534055D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5574711100606224D+0 + B=0.1679107505976331D+0 + V=0.4015361911302668D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5998597333287227D+0 + B=0.2102805057358715D+0 + V=0.4053836986719548D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6395007148516600D+0 + B=0.2518418087774107D+0 + V=0.4073578673299117D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5188456224746252D+0 + B=0.4194321676077518D-1 + V=0.3954628379231406D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5664190707942778D+0 + B=0.8457661551921499D-1 + V=0.4017645508847530D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6110464353283153D+0 + B=0.1273652932519396D+0 + V=0.4059030348651293D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6526430302051563D+0 + B=0.1698173239076354D+0 + V=0.4080565809484880D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6167551880377548D+0 + B=0.4266398851548864D-1 + V=0.4063018753664651D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6607195418355383D+0 + B=0.8551925814238349D-1 + V=0.4087191292799671D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD3074(X,Y,Z,W,N) + DOUBLE PRECISION X(3074) + DOUBLE PRECISION Y(3074) + DOUBLE PRECISION Z(3074) + DOUBLE PRECISION W(3074) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 3074-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.2599095953754734D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3603134089687541D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3586067974412447D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1886108518723392D-1 + V=0.9831528474385880D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4800217244625303D-1 + V=0.1605023107954450D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8244922058397242D-1 + V=0.2072200131464099D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1200408362484023D+0 + V=0.2431297618814187D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1595773530809965D+0 + V=0.2711819064496707D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2002635973434064D+0 + V=0.2932762038321116D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2415127590139982D+0 + V=0.3107032514197368D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2828584158458477D+0 + V=0.3243808058921213D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3239091015338138D+0 + V=0.3349899091374030D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3643225097962194D+0 + V=0.3430580688505218D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4037897083691802D+0 + V=0.3490124109290343D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4420247515194127D+0 + V=0.3532148948561955D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4787572538464938D+0 + V=0.3559862669062833D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5137265251275234D+0 + V=0.3576224317551411D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5466764056654611D+0 + V=0.3584050533086076D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6054859420813535D+0 + V=0.3584903581373224D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6308106701764562D+0 + V=0.3582991879040586D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6530369230179584D+0 + V=0.3582371187963125D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6718609524611158D+0 + V=0.3584353631122350D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6869676499894013D+0 + V=0.3589120166517785D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6980467077240748D+0 + V=0.3595445704531601D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7048241721250522D+0 + V=0.3600943557111074D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5591105222058232D-1 + V=0.1456447096742039D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1407384078513916D+0 + V=0.2252370188283782D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2364035438976309D+0 + V=0.2766135443474897D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3360602737818170D+0 + V=0.3110729491500851D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4356292630054665D+0 + V=0.3342506712303391D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5321569415256174D+0 + V=0.3491981834026860D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6232956305040554D+0 + V=0.3576003604348932D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9469870086838469D-1 + B=0.2778748387309470D-1 + V=0.1921921305788564D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1353170300568141D+0 + B=0.6076569878628364D-1 + V=0.2301458216495632D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1771679481726077D+0 + B=0.9703072762711040D-1 + V=0.2604248549522893D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2197066664231751D+0 + B=0.1354112458524762D+0 + V=0.2845275425870697D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2624783557374927D+0 + B=0.1750996479744100D+0 + V=0.3036870897974840D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3050969521214442D+0 + B=0.2154896907449802D+0 + V=0.3188414832298066D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3472252637196021D+0 + B=0.2560954625740152D+0 + V=0.3307046414722089D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3885610219026360D+0 + B=0.2965070050624096D+0 + V=0.3398330969031360D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4288273776062765D+0 + B=0.3363641488734497D+0 + V=0.3466757899705373D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4677662471302948D+0 + B=0.3753400029836788D+0 + V=0.3516095923230054D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5051333589553359D+0 + B=0.4131297522144286D+0 + V=0.3549645184048486D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5406942145810492D+0 + B=0.4494423776081795D+0 + V=0.3570415969441392D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5742204122576457D+0 + B=0.4839938958841502D+0 + V=0.3581251798496118D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1865407027225188D+0 + B=0.3259144851070796D-1 + V=0.2543491329913348D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2321186453689432D+0 + B=0.6835679505297343D-1 + V=0.2786711051330776D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2773159142523882D+0 + B=0.1062284864451989D+0 + V=0.2985552361083679D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3219200192237254D+0 + B=0.1454404409323047D+0 + V=0.3145867929154039D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3657032593944029D+0 + B=0.1854018282582510D+0 + V=0.3273290662067609D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4084376778363622D+0 + B=0.2256297412014750D+0 + V=0.3372705511943501D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4499004945751427D+0 + B=0.2657104425000896D+0 + V=0.3448274437851510D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4898758141326335D+0 + B=0.3052755487631557D+0 + V=0.3503592783048583D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5281547442266309D+0 + B=0.3439863920645423D+0 + V=0.3541854792663162D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5645346989813992D+0 + B=0.3815229456121914D+0 + V=0.3565995517909428D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5988181252159848D+0 + B=0.4175752420966734D+0 + V=0.3578802078302898D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2850425424471603D+0 + B=0.3562149509862536D-1 + V=0.2958644592860982D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3324619433027876D+0 + B=0.7330318886871096D-1 + V=0.3119548129116835D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3785848333076282D+0 + B=0.1123226296008472D+0 + V=0.3250745225005984D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4232891028562115D+0 + B=0.1521084193337708D+0 + V=0.3355153415935208D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4664287050829722D+0 + B=0.1921844459223610D+0 + V=0.3435847568549328D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5078458493735726D+0 + B=0.2321360989678303D+0 + V=0.3495786831622488D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5473779816204180D+0 + B=0.2715886486360520D+0 + V=0.3537767805534621D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5848617133811376D+0 + B=0.3101924707571355D+0 + V=0.3564459815421428D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6201348281584888D+0 + B=0.3476121052890973D+0 + V=0.3578464061225468D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3852191185387871D+0 + B=0.3763224880035108D-1 + V=0.3239748762836212D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4325025061073423D+0 + B=0.7659581935637135D-1 + V=0.3345491784174287D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4778486229734490D+0 + B=0.1163381306083900D+0 + V=0.3429126177301782D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5211663693009000D+0 + B=0.1563890598752899D+0 + V=0.3492420343097421D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5623469504853703D+0 + B=0.1963320810149200D+0 + V=0.3537399050235257D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6012718188659246D+0 + B=0.2357847407258738D+0 + V=0.3566209152659172D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6378179206390117D+0 + B=0.2743846121244060D+0 + V=0.3581084321919782D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4836936460214534D+0 + B=0.3895902610739024D-1 + V=0.3426522117591512D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5293792562683797D+0 + B=0.7871246819312640D-1 + V=0.3491848770121379D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5726281253100033D+0 + B=0.1187963808202981D+0 + V=0.3539318235231476D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6133658776169068D+0 + B=0.1587914708061787D+0 + V=0.3570231438458694D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6515085491865307D+0 + B=0.1983058575227646D+0 + V=0.3586207335051714D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5778692716064976D+0 + B=0.3977209689791542D-1 + V=0.3541196205164025D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6207904288086192D+0 + B=0.7990157592981152D-1 + V=0.3574296911573953D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6608688171046802D+0 + B=0.1199671308754309D+0 + V=0.3591993279818963D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6656263089489130D+0 + B=0.4015955957805969D-1 + V=0.3595855034661997D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD3470(X,Y,Z,W,N) + DOUBLE PRECISION X(3470) + DOUBLE PRECISION Y(3470) + DOUBLE PRECISION Z(3470) + DOUBLE PRECISION W(3470) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 3470-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.2040382730826330D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.3178149703889544D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1721420832906233D-1 + V=0.8288115128076110D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4408875374981770D-1 + V=0.1360883192522954D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7594680813878681D-1 + V=0.1766854454542662D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1108335359204799D+0 + V=0.2083153161230153D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1476517054388567D+0 + V=0.2333279544657158D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1856731870860615D+0 + V=0.2532809539930247D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2243634099428821D+0 + V=0.2692472184211158D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2633006881662727D+0 + V=0.2819949946811885D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3021340904916283D+0 + V=0.2920953593973030D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3405594048030089D+0 + V=0.2999889782948352D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3783044434007372D+0 + V=0.3060292120496902D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4151194767407910D+0 + V=0.3105109167522192D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4507705766443257D+0 + V=0.3136902387550312D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4850346056573187D+0 + V=0.3157984652454632D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5176950817792470D+0 + V=0.3170516518425422D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5485384240820989D+0 + V=0.3176568425633755D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6039117238943308D+0 + V=0.3177198411207062D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6279956655573113D+0 + V=0.3175519492394733D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6493636169568952D+0 + V=0.3174654952634756D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6677644117704504D+0 + V=0.3175676415467654D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6829368572115624D+0 + V=0.3178923417835410D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6946195818184121D+0 + V=0.3183788287531909D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7025711542057026D+0 + V=0.3188755151918807D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7066004767140119D+0 + V=0.3191916889313849D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5132537689946062D-1 + V=0.1231779611744508D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1297994661331225D+0 + V=0.1924661373839880D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2188852049401307D+0 + V=0.2380881867403424D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3123174824903457D+0 + V=0.2693100663037885D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4064037620738195D+0 + V=0.2908673382834366D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4984958396944782D+0 + V=0.3053914619381535D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5864975046021365D+0 + V=0.3143916684147777D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6686711634580175D+0 + V=0.3187042244055363D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8715738780835950D-1 + B=0.2557175233367578D-1 + V=0.1635219535869790D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1248383123134007D+0 + B=0.5604823383376681D-1 + V=0.1968109917696070D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1638062693383378D+0 + B=0.8968568601900765D-1 + V=0.2236754342249974D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2035586203373176D+0 + B=0.1254086651976279D+0 + V=0.2453186687017181D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2436798975293774D+0 + B=0.1624780150162012D+0 + V=0.2627551791580541D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2838207507773806D+0 + B=0.2003422342683208D+0 + V=0.2767654860152220D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3236787502217692D+0 + B=0.2385628026255263D+0 + V=0.2879467027765895D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3629849554840691D+0 + B=0.2767731148783578D+0 + V=0.2967639918918702D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4014948081992087D+0 + B=0.3146542308245309D+0 + V=0.3035900684660351D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4389818379260225D+0 + B=0.3519196415895088D+0 + V=0.3087338237298308D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4752331143674377D+0 + B=0.3883050984023654D+0 + V=0.3124608838860167D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5100457318374018D+0 + B=0.4235613423908649D+0 + V=0.3150084294226743D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5432238388954868D+0 + B=0.4574484717196220D+0 + V=0.3165958398598402D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5745758685072442D+0 + B=0.4897311639255524D+0 + V=0.3174320440957372D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1723981437592809D+0 + B=0.3010630597881105D-1 + V=0.2182188909812599D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2149553257844597D+0 + B=0.6326031554204694D-1 + V=0.2399727933921445D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2573256081247422D+0 + B=0.9848566980258631D-1 + V=0.2579796133514652D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2993163751238106D+0 + B=0.1350835952384266D+0 + V=0.2727114052623535D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3407238005148000D+0 + B=0.1725184055442181D+0 + V=0.2846327656281355D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3813454978483264D+0 + B=0.2103559279730725D+0 + V=0.2941491102051334D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4209848104423343D+0 + B=0.2482278774554860D+0 + V=0.3016049492136107D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4594519699996300D+0 + B=0.2858099509982883D+0 + V=0.3072949726175648D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4965640166185930D+0 + B=0.3228075659915428D+0 + V=0.3114768142886460D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5321441655571562D+0 + B=0.3589459907204151D+0 + V=0.3143823673666223D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5660208438582166D+0 + B=0.3939630088864310D+0 + V=0.3162269764661535D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5980264315964364D+0 + B=0.4276029922949089D+0 + V=0.3172164663759821D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2644215852350733D+0 + B=0.3300939429072552D-1 + V=0.2554575398967435D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3090113743443063D+0 + B=0.6803887650078501D-1 + V=0.2701704069135677D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3525871079197808D+0 + B=0.1044326136206709D+0 + V=0.2823693413468940D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3950418005354029D+0 + B=0.1416751597517679D+0 + V=0.2922898463214289D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4362475663430163D+0 + B=0.1793408610504821D+0 + V=0.3001829062162428D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4760661812145854D+0 + B=0.2170630750175722D+0 + V=0.3062890864542953D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5143551042512103D+0 + B=0.2545145157815807D+0 + V=0.3108328279264746D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5509709026935597D+0 + B=0.2913940101706601D+0 + V=0.3140243146201245D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5857711030329428D+0 + B=0.3274169910910705D+0 + V=0.3160638030977130D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6186149917404392D+0 + B=0.3623081329317265D+0 + V=0.3171462882206275D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3586894569557064D+0 + B=0.3497354386450040D-1 + V=0.2812388416031796D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4035266610019441D+0 + B=0.7129736739757095D-1 + V=0.2912137500288045D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4467775312332510D+0 + B=0.1084758620193165D+0 + V=0.2993241256502206D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4883638346608543D+0 + B=0.1460915689241772D+0 + V=0.3057101738983822D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5281908348434601D+0 + B=0.1837790832369980D+0 + V=0.3105319326251432D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5661542687149311D+0 + B=0.2212075390874021D+0 + V=0.3139565514428167D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6021450102031452D+0 + B=0.2580682841160985D+0 + V=0.3161543006806366D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6360520783610050D+0 + B=0.2940656362094121D+0 + V=0.3172985960613294D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4521611065087196D+0 + B=0.3631055365867002D-1 + V=0.2989400336901431D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4959365651560963D+0 + B=0.7348318468484350D-1 + V=0.3054555883947677D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5376815804038283D+0 + B=0.1111087643812648D+0 + V=0.3104764960807702D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5773314480243768D+0 + B=0.1488226085145408D+0 + V=0.3141015825977616D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6148113245575056D+0 + B=0.1862892274135151D+0 + V=0.3164520621159896D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6500407462842380D+0 + B=0.2231909701714456D+0 + V=0.3176652305912204D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5425151448707213D+0 + B=0.3718201306118944D-1 + V=0.3105097161023939D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5841860556907931D+0 + B=0.7483616335067346D-1 + V=0.3143014117890550D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6234632186851500D+0 + B=0.1125990834266120D+0 + V=0.3168172866287200D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6602934551848843D+0 + B=0.1501303813157619D+0 + V=0.3181401865570968D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6278573968375105D+0 + B=0.3767559930245720D-1 + V=0.3170663659156037D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6665611711264577D+0 + B=0.7548443301360158D-1 + V=0.3185447944625510D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD3890(X,Y,Z,W,N) + DOUBLE PRECISION X(3890) + DOUBLE PRECISION Y(3890) + DOUBLE PRECISION Z(3890) + DOUBLE PRECISION W(3890) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 3890-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1807395252196920D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2848008782238827D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2836065837530581D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1587876419858352D-1 + V=0.7013149266673816D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4069193593751206D-1 + V=0.1162798021956766D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7025888115257997D-1 + V=0.1518728583972105D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1027495450028704D+0 + V=0.1798796108216934D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1371457730893426D+0 + V=0.2022593385972785D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1727758532671953D+0 + V=0.2203093105575464D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2091492038929037D+0 + V=0.2349294234299855D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2458813281751915D+0 + V=0.2467682058747003D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2826545859450066D+0 + V=0.2563092683572224D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3191957291799622D+0 + V=0.2639253896763318D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3552621469299578D+0 + V=0.2699137479265108D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3906329503406230D+0 + V=0.2745196420166739D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4251028614093031D+0 + V=0.2779529197397593D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4584777520111870D+0 + V=0.2803996086684265D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4905711358710193D+0 + V=0.2820302356715842D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5212011669847385D+0 + V=0.2830056747491068D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5501878488737995D+0 + V=0.2834808950776839D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6025037877479342D+0 + V=0.2835282339078929D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6254572689549016D+0 + V=0.2833819267065800D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6460107179528248D+0 + V=0.2832858336906784D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6639541138154251D+0 + V=0.2833268235451244D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6790688515667495D+0 + V=0.2835432677029253D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6911338580371512D+0 + V=0.2839091722743049D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6999385956126490D+0 + V=0.2843308178875841D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7053037748656896D+0 + V=0.2846703550533846D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4732224387180115D-1 + V=0.1051193406971900D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1202100529326803D+0 + V=0.1657871838796974D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2034304820664855D+0 + V=0.2064648113714232D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2912285643573002D+0 + V=0.2347942745819741D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3802361792726768D+0 + V=0.2547775326597726D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4680598511056146D+0 + V=0.2686876684847025D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5528151052155599D+0 + V=0.2778665755515867D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6329386307803041D+0 + V=0.2830996616782929D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8056516651369069D-1 + B=0.2363454684003124D-1 + V=0.1403063340168372D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1156476077139389D+0 + B=0.5191291632545936D-1 + V=0.1696504125939477D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1520473382760421D+0 + B=0.8322715736994519D-1 + V=0.1935787242745390D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1892986699745931D+0 + B=0.1165855667993712D+0 + V=0.2130614510521968D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2270194446777792D+0 + B=0.1513077167409504D+0 + V=0.2289381265931048D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2648908185093273D+0 + B=0.1868882025807859D+0 + V=0.2418630292816186D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3026389259574136D+0 + B=0.2229277629776224D+0 + V=0.2523400495631193D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3400220296151384D+0 + B=0.2590951840746235D+0 + V=0.2607623973449605D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3768217953335510D+0 + B=0.2951047291750847D+0 + V=0.2674441032689209D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4128372900921884D+0 + B=0.3307019714169930D+0 + V=0.2726432360343356D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4478807131815630D+0 + B=0.3656544101087634D+0 + V=0.2765787685924545D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4817742034089257D+0 + B=0.3997448951939695D+0 + V=0.2794428690642224D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5143472814653344D+0 + B=0.4327667110812024D+0 + V=0.2814099002062895D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5454346213905650D+0 + B=0.4645196123532293D+0 + V=0.2826429531578994D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5748739313170252D+0 + B=0.4948063555703345D+0 + V=0.2832983542550884D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1599598738286342D+0 + B=0.2792357590048985D-1 + V=0.1886695565284976D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1998097412500951D+0 + B=0.5877141038139065D-1 + V=0.2081867882748234D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2396228952566202D+0 + B=0.9164573914691377D-1 + V=0.2245148680600796D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2792228341097746D+0 + B=0.1259049641962687D+0 + V=0.2380370491511872D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3184251107546741D+0 + B=0.1610594823400863D+0 + V=0.2491398041852455D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3570481164426244D+0 + B=0.1967151653460898D+0 + V=0.2581632405881230D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3949164710492144D+0 + B=0.2325404606175168D+0 + V=0.2653965506227417D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4318617293970503D+0 + B=0.2682461141151439D+0 + V=0.2710857216747087D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4677221009931678D+0 + B=0.3035720116011973D+0 + V=0.2754434093903659D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5023417939270955D+0 + B=0.3382781859197439D+0 + V=0.2786579932519380D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5355701836636128D+0 + B=0.3721383065625942D+0 + V=0.2809011080679474D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5672608451328771D+0 + B=0.4049346360466055D+0 + V=0.2823336184560987D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5972704202540162D+0 + B=0.4364538098633802D+0 + V=0.2831101175806309D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2461687022333596D+0 + B=0.3070423166833368D-1 + V=0.2221679970354546D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2881774566286831D+0 + B=0.6338034669281885D-1 + V=0.2356185734270703D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3293963604116978D+0 + B=0.9742862487067941D-1 + V=0.2469228344805590D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3697303822241377D+0 + B=0.1323799532282290D+0 + V=0.2562726348642046D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4090663023135127D+0 + B=0.1678497018129336D+0 + V=0.2638756726753028D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4472819355411712D+0 + B=0.2035095105326114D+0 + V=0.2699311157390862D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4842513377231437D+0 + B=0.2390692566672091D+0 + V=0.2746233268403837D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5198477629962928D+0 + B=0.2742649818076149D+0 + V=0.2781225674454771D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5539453011883145D+0 + B=0.3088503806580094D+0 + V=0.2805881254045684D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5864196762401251D+0 + B=0.3425904245906614D+0 + V=0.2821719877004913D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6171484466668390D+0 + B=0.3752562294789468D+0 + V=0.2830222502333124D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3350337830565727D+0 + B=0.3261589934634747D-1 + V=0.2457995956744870D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3775773224758284D+0 + B=0.6658438928081572D-1 + V=0.2551474407503706D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4188155229848973D+0 + B=0.1014565797157954D+0 + V=0.2629065335195311D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4586805892009344D+0 + B=0.1368573320843822D+0 + V=0.2691900449925075D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4970895714224235D+0 + B=0.1724614851951608D+0 + V=0.2741275485754276D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5339505133960747D+0 + B=0.2079779381416412D+0 + V=0.2778530970122595D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5691665792531440D+0 + B=0.2431385788322288D+0 + V=0.2805010567646741D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6026387682680377D+0 + B=0.2776901883049853D+0 + V=0.2822055834031040D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6342676150163307D+0 + B=0.3113881356386632D+0 + V=0.2831016901243473D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4237951119537067D+0 + B=0.3394877848664351D-1 + V=0.2624474901131803D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4656918683234929D+0 + B=0.6880219556291447D-1 + V=0.2688034163039377D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5058857069185980D+0 + B=0.1041946859721635D+0 + V=0.2738932751287636D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5443204666713996D+0 + B=0.1398039738736393D+0 + V=0.2777944791242523D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5809298813759742D+0 + B=0.1753373381196155D+0 + V=0.2806011661660987D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6156416039447128D+0 + B=0.2105215793514010D+0 + V=0.2824181456597460D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6483801351066604D+0 + B=0.2450953312157051D+0 + V=0.2833585216577828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5103616577251688D+0 + B=0.3485560643800719D-1 + V=0.2738165236962878D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5506738792580681D+0 + B=0.7026308631512033D-1 + V=0.2778365208203180D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5889573040995292D+0 + B=0.1059035061296403D+0 + V=0.2807852940418966D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6251641589516930D+0 + B=0.1414823925236026D+0 + V=0.2827245949674705D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6592414921570178D+0 + B=0.1767207908214530D+0 + V=0.2837342344829828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5930314017533384D+0 + B=0.3542189339561672D-1 + V=0.2809233907610981D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6309812253390175D+0 + B=0.7109574040369549D-1 + V=0.2829930809742694D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6666296011353230D+0 + B=0.1067259792282730D+0 + V=0.2841097874111479D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6703715271049922D+0 + B=0.3569455268820809D-1 + V=0.2843455206008783D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD4334(X,Y,Z,W,N) + DOUBLE PRECISION X(4334) + DOUBLE PRECISION Y(4334) + DOUBLE PRECISION Z(4334) + DOUBLE PRECISION W(4334) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 4334-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.1449063022537883D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2546377329828424D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1462896151831013D-1 + V=0.6018432961087496D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3769840812493139D-1 + V=0.1002286583263673D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6524701904096891D-1 + V=0.1315222931028093D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9560543416134648D-1 + V=0.1564213746876724D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1278335898929198D+0 + V=0.1765118841507736D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1613096104466031D+0 + V=0.1928737099311080D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1955806225745371D+0 + V=0.2062658534263270D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2302935218498028D+0 + V=0.2172395445953787D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2651584344113027D+0 + V=0.2262076188876047D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2999276825183209D+0 + V=0.2334885699462397D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3343828669718798D+0 + V=0.2393355273179203D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3683265013750518D+0 + V=0.2439559200468863D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4015763206518108D+0 + V=0.2475251866060002D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4339612026399770D+0 + V=0.2501965558158773D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4653180651114582D+0 + V=0.2521081407925925D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4954893331080803D+0 + V=0.2533881002388081D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5243207068924930D+0 + V=0.2541582900848261D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5516590479041704D+0 + V=0.2545365737525860D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6012371927804176D+0 + V=0.2545726993066799D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6231574466449819D+0 + V=0.2544456197465555D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6429416514181271D+0 + V=0.2543481596881064D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6604124272943595D+0 + V=0.2543506451429194D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6753851470408250D+0 + V=0.2544905675493763D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6876717970626160D+0 + V=0.2547611407344429D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6970895061319234D+0 + V=0.2551060375448869D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7034746912553310D+0 + V=0.2554291933816039D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7067017217542295D+0 + V=0.2556255710686343D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4382223501131123D-1 + V=0.9041339695118195D-4 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1117474077400006D+0 + V=0.1438426330079022D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1897153252911440D+0 + V=0.1802523089820518D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2724023009910331D+0 + V=0.2060052290565496D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3567163308709902D+0 + V=0.2245002248967466D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4404784483028087D+0 + V=0.2377059847731150D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5219833154161411D+0 + V=0.2468118955882525D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5998179868977553D+0 + V=0.2525410872966528D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6727803154548222D+0 + V=0.2553101409933397D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7476563943166086D-1 + B=0.2193168509461185D-1 + V=0.1212879733668632D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1075341482001416D+0 + B=0.4826419281533887D-1 + V=0.1472872881270931D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1416344885203259D+0 + B=0.7751191883575742D-1 + V=0.1686846601010828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1766325315388586D+0 + B=0.1087558139247680D+0 + V=0.1862698414660208D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2121744174481514D+0 + B=0.1413661374253096D+0 + V=0.2007430956991861D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2479669443408145D+0 + B=0.1748768214258880D+0 + V=0.2126568125394796D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2837600452294113D+0 + B=0.2089216406612073D+0 + V=0.2224394603372113D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3193344933193984D+0 + B=0.2431987685545972D+0 + V=0.2304264522673135D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3544935442438745D+0 + B=0.2774497054377770D+0 + V=0.2368854288424087D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3890571932288154D+0 + B=0.3114460356156915D+0 + V=0.2420352089461772D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4228581214259090D+0 + B=0.3449806851913012D+0 + V=0.2460597113081295D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4557387211304052D+0 + B=0.3778618641248256D+0 + V=0.2491181912257687D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4875487950541643D+0 + B=0.4099086391698978D+0 + V=0.2513528194205857D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5181436529962997D+0 + B=0.4409474925853973D+0 + V=0.2528943096693220D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5473824095600661D+0 + B=0.4708094517711291D+0 + V=0.2538660368488136D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5751263398976174D+0 + B=0.4993275140354637D+0 + V=0.2543868648299022D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1489515746840028D+0 + B=0.2599381993267017D-1 + V=0.1642595537825183D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1863656444351767D+0 + B=0.5479286532462190D-1 + V=0.1818246659849308D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2238602880356348D+0 + B=0.8556763251425254D-1 + V=0.1966565649492420D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2612723375728160D+0 + B=0.1177257802267011D+0 + V=0.2090677905657991D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2984332990206190D+0 + B=0.1508168456192700D+0 + V=0.2193820409510504D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3351786584663333D+0 + B=0.1844801892177727D+0 + V=0.2278870827661928D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3713505522209120D+0 + B=0.2184145236087598D+0 + V=0.2348283192282090D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4067981098954663D+0 + B=0.2523590641486229D+0 + V=0.2404139755581477D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4413769993687534D+0 + B=0.2860812976901373D+0 + V=0.2448227407760734D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4749487182516394D+0 + B=0.3193686757808996D+0 + V=0.2482110455592573D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5073798105075426D+0 + B=0.3520226949547602D+0 + V=0.2507192397774103D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5385410448878654D+0 + B=0.3838544395667890D+0 + V=0.2524765968534880D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5683065353670530D+0 + B=0.4146810037640963D+0 + V=0.2536052388539425D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5965527620663510D+0 + B=0.4443224094681121D+0 + V=0.2542230588033068D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2299227700856157D+0 + B=0.2865757664057584D-1 + V=0.1944817013047896D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2695752998553267D+0 + B=0.5923421684485993D-1 + V=0.2067862362746635D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3086178716611389D+0 + B=0.9117817776057715D-1 + V=0.2172440734649114D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3469649871659077D+0 + B=0.1240593814082605D+0 + V=0.2260125991723423D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3845153566319655D+0 + B=0.1575272058259175D+0 + V=0.2332655008689523D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4211600033403215D+0 + B=0.1912845163525413D+0 + V=0.2391699681532458D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4567867834329882D+0 + B=0.2250710177858171D+0 + V=0.2438801528273928D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4912829319232061D+0 + B=0.2586521303440910D+0 + V=0.2475370504260665D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5245364793303812D+0 + B=0.2918112242865407D+0 + V=0.2502707235640574D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5564369788915756D+0 + B=0.3243439239067890D+0 + V=0.2522031701054241D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5868757697775287D+0 + B=0.3560536787835351D+0 + V=0.2534511269978784D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6157458853519617D+0 + B=0.3867480821242581D+0 + V=0.2541284914955151D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3138461110672113D+0 + B=0.3051374637507278D-1 + V=0.2161509250688394D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3542495872050569D+0 + B=0.6237111233730755D-1 + V=0.2248778513437852D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3935751553120181D+0 + B=0.9516223952401907D-1 + V=0.2322388803404617D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4317634668111147D+0 + B=0.1285467341508517D+0 + V=0.2383265471001355D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4687413842250821D+0 + B=0.1622318931656033D+0 + V=0.2432476675019525D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5044274237060283D+0 + B=0.1959581153836453D+0 + V=0.2471122223750674D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5387354077925727D+0 + B=0.2294888081183837D+0 + V=0.2500291752486870D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5715768898356105D+0 + B=0.2626031152713945D+0 + V=0.2521055942764682D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6028627200136111D+0 + B=0.2950904075286713D+0 + V=0.2534472785575503D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6325039812653463D+0 + B=0.3267458451113286D+0 + V=0.2541599713080121D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3981986708423407D+0 + B=0.3183291458749821D-1 + V=0.2317380975862936D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4382791182133300D+0 + B=0.6459548193880908D-1 + V=0.2378550733719775D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4769233057218166D+0 + B=0.9795757037087952D-1 + V=0.2428884456739118D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5140823911194238D+0 + B=0.1316307235126655D+0 + V=0.2469002655757292D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5496977833862983D+0 + B=0.1653556486358704D+0 + V=0.2499657574265851D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5837047306512727D+0 + B=0.1988931724126510D+0 + V=0.2521676168486082D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6160349566926879D+0 + B=0.2320174581438950D+0 + V=0.2535935662645334D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6466185353209440D+0 + B=0.2645106562168662D+0 + V=0.2543356743363214D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4810835158795404D+0 + B=0.3275917807743992D-1 + V=0.2427353285201535D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5199925041324341D+0 + B=0.6612546183967181D-1 + V=0.2468258039744386D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5571717692207494D+0 + B=0.9981498331474143D-1 + V=0.2500060956440310D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5925789250836378D+0 + B=0.1335687001410374D+0 + V=0.2523238365420979D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6261658523859670D+0 + B=0.1671444402896463D+0 + V=0.2538399260252846D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6578811126669331D+0 + B=0.2003106382156076D+0 + V=0.2546255927268069D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5609624612998100D+0 + B=0.3337500940231335D-1 + V=0.2500583360048449D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5979959659984670D+0 + B=0.6708750335901803D-1 + V=0.2524777638260203D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6330523711054002D+0 + B=0.1008792126424850D+0 + V=0.2540951193860656D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6660960998103972D+0 + B=0.1345050343171794D+0 + V=0.2549524085027472D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6365384364585819D+0 + B=0.3372799460737052D-1 + V=0.2542569507009158D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6710994302899275D+0 + B=0.6755249309678028D-1 + V=0.2552114127580376D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD4802(X,Y,Z,W,N) + DOUBLE PRECISION X(4802) + DOUBLE PRECISION Y(4802) + DOUBLE PRECISION Z(4802) + DOUBLE PRECISION W(4802) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 4802-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.9687521879420705D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2307897895367918D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2297310852498558D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2335728608887064D-1 + V=0.7386265944001919D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4352987836550653D-1 + V=0.8257977698542210D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6439200521088801D-1 + V=0.9706044762057630D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9003943631993181D-1 + V=0.1302393847117003D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1196706615548473D+0 + V=0.1541957004600968D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1511715412838134D+0 + V=0.1704459770092199D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1835982828503801D+0 + V=0.1827374890942906D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2165081259155405D+0 + V=0.1926360817436107D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2496208720417563D+0 + V=0.2008010239494833D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2827200673567900D+0 + V=0.2075635983209175D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3156190823994346D+0 + V=0.2131306638690909D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3481476793749115D+0 + V=0.2176562329937335D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3801466086947226D+0 + V=0.2212682262991018D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4114652119634011D+0 + V=0.2240799515668565D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4419598786519751D+0 + V=0.2261959816187525D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4714925949329543D+0 + V=0.2277156368808855D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4999293972879466D+0 + V=0.2287351772128336D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5271387221431248D+0 + V=0.2293490814084085D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5529896780837761D+0 + V=0.2296505312376273D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6000856099481712D+0 + V=0.2296793832318756D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6210562192785175D+0 + V=0.2295785443842974D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6401165879934240D+0 + V=0.2295017931529102D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6571144029244334D+0 + V=0.2295059638184868D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6718910821718863D+0 + V=0.2296232343237362D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6842845591099010D+0 + V=0.2298530178740771D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6941353476269816D+0 + V=0.2301579790280501D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7012965242212991D+0 + V=0.2304690404996513D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7056471428242644D+0 + V=0.2307027995907102D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4595557643585895D-1 + V=0.9312274696671092D-4 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1049316742435023D+0 + V=0.1199919385876926D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1773548879549274D+0 + V=0.1598039138877690D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2559071411236127D+0 + V=0.1822253763574900D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3358156837985898D+0 + V=0.1988579593655040D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4155835743763893D+0 + V=0.2112620102533307D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4937894296167472D+0 + V=0.2201594887699007D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5691569694793316D+0 + V=0.2261622590895036D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6405840854894251D+0 + V=0.2296458453435705D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7345133894143348D-1 + B=0.2177844081486067D-1 + V=0.1006006990267000D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1009859834044931D+0 + B=0.4590362185775188D-1 + V=0.1227676689635876D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1324289619748758D+0 + B=0.7255063095690877D-1 + V=0.1467864280270117D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1654272109607127D+0 + B=0.1017825451960684D+0 + V=0.1644178912101232D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1990767186776461D+0 + B=0.1325652320980364D+0 + V=0.1777664890718961D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2330125945523278D+0 + B=0.1642765374496765D+0 + V=0.1884825664516690D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2670080611108287D+0 + B=0.1965360374337889D+0 + V=0.1973269246453848D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3008753376294316D+0 + B=0.2290726770542238D+0 + V=0.2046767775855328D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3344475596167860D+0 + B=0.2616645495370823D+0 + V=0.2107600125918040D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3675709724070786D+0 + B=0.2941150728843141D+0 + V=0.2157416362266829D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4001000887587812D+0 + B=0.3262440400919066D+0 + V=0.2197557816920721D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4318956350436028D+0 + B=0.3578835350611916D+0 + V=0.2229192611835437D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4628239056795531D+0 + B=0.3888751854043678D+0 + V=0.2253385110212775D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4927563229773636D+0 + B=0.4190678003222840D+0 + V=0.2271137107548774D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5215687136707969D+0 + B=0.4483151836883852D+0 + V=0.2283414092917525D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5491402346984905D+0 + B=0.4764740676087880D+0 + V=0.2291161673130077D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5753520160126075D+0 + B=0.5034021310998277D+0 + V=0.2295313908576598D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1388326356417754D+0 + B=0.2435436510372806D-1 + V=0.1438204721359031D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1743686900537244D+0 + B=0.5118897057342652D-1 + V=0.1607738025495257D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2099737037950268D+0 + B=0.8014695048539634D-1 + V=0.1741483853528379D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2454492590908548D+0 + B=0.1105117874155699D+0 + V=0.1851918467519151D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2807219257864278D+0 + B=0.1417950531570966D+0 + V=0.1944628638070613D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3156842271975842D+0 + B=0.1736604945719597D+0 + V=0.2022495446275152D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3502090945177752D+0 + B=0.2058466324693981D+0 + V=0.2087462382438514D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3841684849519686D+0 + B=0.2381284261195919D+0 + V=0.2141074754818308D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4174372367906016D+0 + B=0.2703031270422569D+0 + V=0.2184640913748162D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4498926465011892D+0 + B=0.3021845683091309D+0 + V=0.2219309165220329D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4814146229807701D+0 + B=0.3335993355165720D+0 + V=0.2246123118340624D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5118863625734701D+0 + B=0.3643833735518232D+0 + V=0.2266062766915125D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5411947455119144D+0 + B=0.3943789541958179D+0 + V=0.2280072952230796D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5692301500357246D+0 + B=0.4234320144403542D+0 + V=0.2289082025202583D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5958857204139576D+0 + B=0.4513897947419260D+0 + V=0.2294012695120025D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2156270284785766D+0 + B=0.2681225755444491D-1 + V=0.1722434488736947D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2532385054909710D+0 + B=0.5557495747805614D-1 + V=0.1830237421455091D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2902564617771537D+0 + B=0.8569368062950249D-1 + V=0.1923855349997633D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3266979823143256D+0 + B=0.1167367450324135D+0 + V=0.2004067861936271D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3625039627493614D+0 + B=0.1483861994003304D+0 + V=0.2071817297354263D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3975838937548699D+0 + B=0.1803821503011405D+0 + V=0.2128250834102103D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4318396099009774D+0 + B=0.2124962965666424D+0 + V=0.2174513719440102D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4651706555732742D+0 + B=0.2445221837805913D+0 + V=0.2211661839150214D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4974752649620969D+0 + B=0.2762701224322987D+0 + V=0.2240665257813102D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5286517579627517D+0 + B=0.3075627775211328D+0 + V=0.2262439516632620D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5586001195731895D+0 + B=0.3382311089826877D+0 + V=0.2277874557231869D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5872229902021319D+0 + B=0.3681108834741399D+0 + V=0.2287854314454994D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6144258616235123D+0 + B=0.3970397446872839D+0 + V=0.2293268499615575D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2951676508064861D+0 + B=0.2867499538750441D-1 + V=0.1912628201529828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3335085485472725D+0 + B=0.5867879341903510D-1 + V=0.1992499672238701D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3709561760636381D+0 + B=0.8961099205022284D-1 + V=0.2061275533454027D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4074722861667498D+0 + B=0.1211627927626297D+0 + V=0.2119318215968572D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4429923648839117D+0 + B=0.1530748903554898D+0 + V=0.2167416581882652D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4774428052721736D+0 + B=0.1851176436721877D+0 + V=0.2206430730516600D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5107446539535904D+0 + B=0.2170829107658179D+0 + V=0.2237186938699523D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5428151370542935D+0 + B=0.2487786689026271D+0 + V=0.2260480075032884D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5735699292556964D+0 + B=0.2800239952795016D+0 + V=0.2277098884558542D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6029253794562866D+0 + B=0.3106445702878119D+0 + V=0.2287845715109671D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6307998987073145D+0 + B=0.3404689500841194D+0 + V=0.2293547268236294D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3752652273692719D+0 + B=0.2997145098184479D-1 + V=0.2056073839852528D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4135383879344028D+0 + B=0.6086725898678011D-1 + V=0.2114235865831876D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4506113885153907D+0 + B=0.9238849548435643D-1 + V=0.2163175629770551D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4864401554606072D+0 + B=0.1242786603851851D+0 + V=0.2203392158111650D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5209708076611709D+0 + B=0.1563086731483386D+0 + V=0.2235473176847839D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5541422135830122D+0 + B=0.1882696509388506D+0 + V=0.2260024141501235D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5858880915113817D+0 + B=0.2199672979126059D+0 + V=0.2277675929329182D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6161399390603444D+0 + B=0.2512165482924867D+0 + V=0.2289102112284834D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6448296482255090D+0 + B=0.2818368701871888D+0 + V=0.2295027954625118D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4544796274917948D+0 + B=0.3088970405060312D-1 + V=0.2161281589879992D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4919389072146628D+0 + B=0.6240947677636835D-1 + V=0.2201980477395102D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5279313026985183D+0 + B=0.9430706144280313D-1 + V=0.2234952066593166D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5624169925571135D+0 + B=0.1263547818770374D+0 + V=0.2260540098520838D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5953484627093287D+0 + B=0.1583430788822594D+0 + V=0.2279157981899988D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6266730715339185D+0 + B=0.1900748462555988D+0 + V=0.2291296918565571D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6563363204278871D+0 + B=0.2213599519592567D+0 + V=0.2297533752536649D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5314574716585696D+0 + B=0.3152508811515374D-1 + V=0.2234927356465995D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5674614932298185D+0 + B=0.6343865291465561D-1 + V=0.2261288012985219D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6017706004970264D+0 + B=0.9551503504223951D-1 + V=0.2280818160923688D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6343471270264178D+0 + B=0.1275440099801196D+0 + V=0.2293773295180159D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6651494599127802D+0 + B=0.1593252037671960D+0 + V=0.2300528767338634D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6050184986005704D+0 + B=0.3192538338496105D-1 + V=0.2281893855065666D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6390163550880400D+0 + B=0.6402824353962306D-1 + V=0.2295720444840727D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6711199107088448D+0 + B=0.9609805077002909D-1 + V=0.2303227649026753D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6741354429572275D+0 + B=0.3211853196273233D-1 + V=0.2304831913227114D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD5294(X,Y,Z,W,N) + DOUBLE PRECISION X(5294) + DOUBLE PRECISION Y(5294) + DOUBLE PRECISION Z(5294) + DOUBLE PRECISION W(5294) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 5294-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.9080510764308163D-4 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.2084824361987793D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2303261686261450D-1 + V=0.5011105657239616D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3757208620162394D-1 + V=0.5942520409683854D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5821912033821852D-1 + V=0.9564394826109721D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8403127529194872D-1 + V=0.1185530657126338D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1122927798060578D+0 + V=0.1364510114230331D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1420125319192987D+0 + V=0.1505828825605415D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1726396437341978D+0 + V=0.1619298749867023D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2038170058115696D+0 + V=0.1712450504267789D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2352849892876508D+0 + V=0.1789891098164999D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2668363354312461D+0 + V=0.1854474955629795D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2982941279900452D+0 + V=0.1908148636673661D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3295002922087076D+0 + V=0.1952377405281833D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3603094918363593D+0 + V=0.1988349254282232D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3905857895173920D+0 + V=0.2017079807160050D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4202005758160837D+0 + V=0.2039473082709094D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4490310061597227D+0 + V=0.2056360279288953D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4769586160311491D+0 + V=0.2068525823066865D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5038679887049750D+0 + V=0.2076724877534488D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5296454286519961D+0 + V=0.2081694278237885D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5541776207164850D+0 + V=0.2084157631219326D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5990467321921213D+0 + V=0.2084381531128593D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6191467096294587D+0 + V=0.2083476277129307D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6375251212901849D+0 + V=0.2082686194459732D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6540514381131168D+0 + V=0.2082475686112415D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6685899064391510D+0 + V=0.2083139860289915D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6810013009681648D+0 + V=0.2084745561831237D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6911469578730340D+0 + V=0.2087091313375890D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6988956915141736D+0 + V=0.2089718413297697D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7041335794868720D+0 + V=0.2092003303479793D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7067754398018567D+0 + V=0.2093336148263241D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3840368707853623D-1 + V=0.7591708117365267D-4 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9835485954117399D-1 + V=0.1083383968169186D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1665774947612998D+0 + V=0.1403019395292510D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2405702335362910D+0 + V=0.1615970179286436D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3165270770189046D+0 + V=0.1771144187504911D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3927386145645443D+0 + V=0.1887760022988168D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4678825918374656D+0 + V=0.1973474670768214D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5408022024266935D+0 + V=0.2033787661234659D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6104967445752438D+0 + V=0.2072343626517331D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6760910702685738D+0 + V=0.2091177834226918D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6655644120217392D-1 + B=0.1936508874588424D-1 + V=0.9316684484675566D-4 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9446246161270182D-1 + B=0.4252442002115869D-1 + V=0.1116193688682976D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1242651925452509D+0 + B=0.6806529315354374D-1 + V=0.1298623551559414D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1553438064846751D+0 + B=0.9560957491205369D-1 + V=0.1450236832456426D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1871137110542670D+0 + B=0.1245931657452888D+0 + V=0.1572719958149914D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2192612628836257D+0 + B=0.1545385828778978D+0 + V=0.1673234785867195D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2515682807206955D+0 + B=0.1851004249723368D+0 + V=0.1756860118725188D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2838535866287290D+0 + B=0.2160182608272384D+0 + V=0.1826776290439367D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3159578817528521D+0 + B=0.2470799012277111D+0 + V=0.1885116347992865D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3477370882791392D+0 + B=0.2781014208986402D+0 + V=0.1933457860170574D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3790576960890540D+0 + B=0.3089172523515731D+0 + V=0.1973060671902064D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4097938317810200D+0 + B=0.3393750055472244D+0 + V=0.2004987099616311D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4398256572859637D+0 + B=0.3693322470987730D+0 + V=0.2030170909281499D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4690384114718480D+0 + B=0.3986541005609877D+0 + V=0.2049461460119080D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4973216048301053D+0 + B=0.4272112491408562D+0 + V=0.2063653565200186D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5245681526132446D+0 + B=0.4548781735309936D+0 + V=0.2073507927381027D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5506733911803888D+0 + B=0.4815315355023251D+0 + V=0.2079764593256122D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5755339829522475D+0 + B=0.5070486445801855D+0 + V=0.2083150534968778D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1305472386056362D+0 + B=0.2284970375722366D-1 + V=0.1262715121590664D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1637327908216477D+0 + B=0.4812254338288384D-1 + V=0.1414386128545972D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1972734634149637D+0 + B=0.7531734457511935D-1 + V=0.1538740401313898D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2308694653110130D+0 + B=0.1039043639882017D+0 + V=0.1642434942331432D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2643899218338160D+0 + B=0.1334526587117626D+0 + V=0.1729790609237496D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2977171599622171D+0 + B=0.1636414868936382D+0 + V=0.1803505190260828D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3307293903032310D+0 + B=0.1942195406166568D+0 + V=0.1865475350079657D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3633069198219073D+0 + B=0.2249752879943753D+0 + V=0.1917182669679069D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3953346955922727D+0 + B=0.2557218821820032D+0 + V=0.1959851709034382D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4267018394184914D+0 + B=0.2862897925213193D+0 + V=0.1994529548117882D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4573009622571704D+0 + B=0.3165224536636518D+0 + V=0.2022138911146548D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4870279559856109D+0 + B=0.3462730221636496D+0 + V=0.2043518024208592D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5157819581450322D+0 + B=0.3754016870282835D+0 + V=0.2059450313018110D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5434651666465393D+0 + B=0.4037733784993613D+0 + V=0.2070685715318472D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5699823887764627D+0 + B=0.4312557784139123D+0 + V=0.2077955310694373D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5952403350947741D+0 + B=0.4577175367122110D+0 + V=0.2081980387824712D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2025152599210369D+0 + B=0.2520253617719557D-1 + V=0.1521318610377956D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2381066653274425D+0 + B=0.5223254506119000D-1 + V=0.1622772720185755D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2732823383651612D+0 + B=0.8060669688588620D-1 + V=0.1710498139420709D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3080137692611118D+0 + B=0.1099335754081255D+0 + V=0.1785911149448736D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3422405614587601D+0 + B=0.1399120955959857D+0 + V=0.1850125313687736D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3758808773890420D+0 + B=0.1702977801651705D+0 + V=0.1904229703933298D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4088458383438932D+0 + B=0.2008799256601680D+0 + V=0.1949259956121987D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4410450550841152D+0 + B=0.2314703052180836D+0 + V=0.1986161545363960D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4723879420561312D+0 + B=0.2618972111375892D+0 + V=0.2015790585641370D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5027843561874343D+0 + B=0.2920013195600270D+0 + V=0.2038934198707418D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5321453674452458D+0 + B=0.3216322555190551D+0 + V=0.2056334060538251D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5603839113834030D+0 + B=0.3506456615934198D+0 + V=0.2068705959462289D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5874150706875146D+0 + B=0.3789007181306267D+0 + V=0.2076753906106002D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6131559381660038D+0 + B=0.4062580170572782D+0 + V=0.2081179391734803D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2778497016394506D+0 + B=0.2696271276876226D-1 + V=0.1700345216228943D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3143733562261912D+0 + B=0.5523469316960465D-1 + V=0.1774906779990410D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3501485810261827D+0 + B=0.8445193201626464D-1 + V=0.1839659377002642D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3851430322303653D+0 + B=0.1143263119336083D+0 + V=0.1894987462975169D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4193013979470415D+0 + B=0.1446177898344475D+0 + V=0.1941548809452595D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4525585960458567D+0 + B=0.1751165438438091D+0 + V=0.1980078427252384D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4848447779622947D+0 + B=0.2056338306745660D+0 + V=0.2011296284744488D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5160871208276894D+0 + B=0.2359965487229226D+0 + V=0.2035888456966776D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5462112185696926D+0 + B=0.2660430223139146D+0 + V=0.2054516325352142D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5751425068101757D+0 + B=0.2956193664498032D+0 + V=0.2067831033092635D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6028073872853596D+0 + B=0.3245763905312779D+0 + V=0.2076485320284876D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6291338275278409D+0 + B=0.3527670026206972D+0 + V=0.2081141439525255D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3541797528439391D+0 + B=0.2823853479435550D-1 + V=0.1834383015469222D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3908234972074657D+0 + B=0.5741296374713106D-1 + V=0.1889540591777677D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4264408450107590D+0 + B=0.8724646633650199D-1 + V=0.1936677023597375D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4609949666553286D+0 + B=0.1175034422915616D+0 + V=0.1976176495066504D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4944389496536006D+0 + B=0.1479755652628428D+0 + V=0.2008536004560983D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5267194884346086D+0 + B=0.1784740659484352D+0 + V=0.2034280351712291D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5577787810220990D+0 + B=0.2088245700431244D+0 + V=0.2053944466027758D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5875563763536670D+0 + B=0.2388628136570763D+0 + V=0.2068077642882360D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6159910016391269D+0 + B=0.2684308928769185D+0 + V=0.2077250949661599D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6430219602956268D+0 + B=0.2973740761960252D+0 + V=0.2082062440705320D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4300647036213646D+0 + B=0.2916399920493977D-1 + V=0.1934374486546626D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4661486308935531D+0 + B=0.5898803024755659D-1 + V=0.1974107010484300D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5009658555287261D+0 + B=0.8924162698525409D-1 + V=0.2007129290388658D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5344824270447704D+0 + B=0.1197185199637321D+0 + V=0.2033736947471293D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5666575997416371D+0 + B=0.1502300756161382D+0 + V=0.2054287125902493D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5974457471404752D+0 + B=0.1806004191913564D+0 + V=0.2069184936818894D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6267984444116886D+0 + B=0.2106621764786252D+0 + V=0.2078883689808782D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6546664713575417D+0 + B=0.2402526932671914D+0 + V=0.2083886366116359D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5042711004437253D+0 + B=0.2982529203607657D-1 + V=0.2006593275470817D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5392127456774380D+0 + B=0.6008728062339922D-1 + V=0.2033728426135397D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5726819437668618D+0 + B=0.9058227674571398D-1 + V=0.2055008781377608D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6046469254207278D+0 + B=0.1211219235803400D+0 + V=0.2070651783518502D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6350716157434952D+0 + B=0.1515286404791580D+0 + V=0.2080953335094320D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6639177679185454D+0 + B=0.1816314681255552D+0 + V=0.2086284998988521D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5757276040972253D+0 + B=0.3026991752575440D-1 + V=0.2055549387644668D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6090265823139755D+0 + B=0.6078402297870770D-1 + V=0.2071871850267654D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6406735344387661D+0 + B=0.9135459984176636D-1 + V=0.2082856600431965D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6706397927793709D+0 + B=0.1218024155966590D+0 + V=0.2088705858819358D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6435019674426665D+0 + B=0.3052608357660639D-1 + V=0.2083995867536322D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6747218676375681D+0 + B=0.6112185773983089D-1 + V=0.2090509712889637D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + SUBROUTINE LD5810(X,Y,Z,W,N) + DOUBLE PRECISION X(5810) + DOUBLE PRECISION Y(5810) + DOUBLE PRECISION Z(5810) + DOUBLE PRECISION W(5810) + INTEGER N + DOUBLE PRECISION A,B,V +CVW +CVW LEBEDEV 5810-POINT ANGULAR GRID +CVW +chvd +chvd This subroutine is part of a set of subroutines that generate +chvd Lebedev grids [1-6] for integration on a sphere. The original +chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and +chvd translated into fortran by Dr. Christoph van Wuellen. +chvd This subroutine was translated using a C to fortran77 conversion +chvd tool written by Dr. Christoph van Wuellen. +chvd +chvd Users of this code are asked to include reference [1] in their +chvd publications, and in the user- and programmers-manuals +chvd describing their codes. +chvd +chvd This code was distributed through CCL (http://www.ccl.net/). +chvd +chvd [1] V.I. Lebedev, and D.N. Laikov +chvd "A quadrature formula for the sphere of the 131st +chvd algebraic order of accuracy" +chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. +chvd +chvd [2] V.I. Lebedev +chvd "A quadrature formula for the sphere of 59th algebraic +chvd order of accuracy" +chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. +chvd +chvd [3] V.I. Lebedev, and A.L. Skorokhodov +chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" +chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. +chvd +chvd [4] V.I. Lebedev +chvd "Spherical quadrature formulas exact to orders 25-29" +chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. +chvd +chvd [5] V.I. Lebedev +chvd "Quadratures on a sphere" +chvd Computational Mathematics and Mathematical Physics, Vol. 16, +chvd 1976, pp. 10-24. +chvd +chvd [6] V.I. Lebedev +chvd "Values of the nodes and weights of ninth to seventeenth +chvd order Gauss-Markov quadrature formulae invariant under the +chvd octahedron group with inversion" +chvd Computational Mathematics and Mathematical Physics, Vol. 15, +chvd 1975, pp. 44-51. +chvd + N=1 + V=0.9735347946175486D-5 + Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1907581241803167D-3 + Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) + V=0.1901059546737578D-3 + Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1182361662400277D-1 + V=0.3926424538919212D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3062145009138958D-1 + V=0.6667905467294382D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5329794036834243D-1 + V=0.8868891315019135D-4 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7848165532862220D-1 + V=0.1066306000958872D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1054038157636201D+0 + V=0.1214506743336128D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1335577797766211D+0 + V=0.1338054681640871D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1625769955502252D+0 + V=0.1441677023628504D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1921787193412792D+0 + V=0.1528880200826557D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2221340534690548D+0 + V=0.1602330623773609D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2522504912791132D+0 + V=0.1664102653445244D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2823610860679697D+0 + V=0.1715845854011323D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3123173966267560D+0 + V=0.1758901000133069D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3419847036953789D+0 + V=0.1794382485256736D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3712386456999758D+0 + V=0.1823238106757407D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3999627649876828D+0 + V=0.1846293252959976D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4280466458648093D+0 + V=0.1864284079323098D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4553844360185711D+0 + V=0.1877882694626914D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4818736094437834D+0 + V=0.1887716321852025D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5074138709260629D+0 + V=0.1894381638175673D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5319061304570707D+0 + V=0.1898454899533629D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5552514978677286D+0 + V=0.1900497929577815D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5981009025246183D+0 + V=0.1900671501924092D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6173990192228116D+0 + V=0.1899837555533510D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6351365239411131D+0 + V=0.1899014113156229D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6512010228227200D+0 + V=0.1898581257705106D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6654758363948120D+0 + V=0.1898804756095753D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6778410414853370D+0 + V=0.1899793610426402D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6881760887484110D+0 + V=0.1901464554844117D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6963645267094598D+0 + V=0.1903533246259542D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7023010617153579D+0 + V=0.1905556158463228D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.7059004636628753D+0 + V=0.1907037155663528D-3 + Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3552470312472575D-1 + V=0.5992997844249967D-4 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.9151176620841283D-1 + V=0.9749059382456978D-4 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1566197930068980D+0 + V=0.1241680804599158D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2265467599271907D+0 + V=0.1437626154299360D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2988242318581361D+0 + V=0.1584200054793902D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3717482419703886D+0 + V=0.1694436550982744D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4440094491758889D+0 + V=0.1776617014018108D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5145337096756642D+0 + V=0.1836132434440077D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5824053672860230D+0 + V=0.1876494727075983D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6468283961043370D+0 + V=0.1899906535336482D-3 + Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6095964259104373D-1 + B=0.1787828275342931D-1 + V=0.8143252820767350D-4 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.8811962270959388D-1 + B=0.3953888740792096D-1 + V=0.9998859890887728D-4 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1165936722428831D+0 + B=0.6378121797722990D-1 + V=0.1156199403068359D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1460232857031785D+0 + B=0.8985890813745037D-1 + V=0.1287632092635513D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1761197110181755D+0 + B=0.1172606510576162D+0 + V=0.1398378643365139D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2066471190463718D+0 + B=0.1456102876970995D+0 + V=0.1491876468417391D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2374076026328152D+0 + B=0.1746153823011775D+0 + V=0.1570855679175456D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2682305474337051D+0 + B=0.2040383070295584D+0 + V=0.1637483948103775D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2989653312142369D+0 + B=0.2336788634003698D+0 + V=0.1693500566632843D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3294762752772209D+0 + B=0.2633632752654219D+0 + V=0.1740322769393633D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3596390887276086D+0 + B=0.2929369098051601D+0 + V=0.1779126637278296D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3893383046398812D+0 + B=0.3222592785275512D+0 + V=0.1810908108835412D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4184653789358347D+0 + B=0.3512004791195743D+0 + V=0.1836529132600190D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4469172319076166D+0 + B=0.3796385677684537D+0 + V=0.1856752841777379D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4745950813276976D+0 + B=0.4074575378263879D+0 + V=0.1872270566606832D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5014034601410262D+0 + B=0.4345456906027828D+0 + V=0.1883722645591307D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5272493404551239D+0 + B=0.4607942515205134D+0 + V=0.1891714324525297D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5520413051846366D+0 + B=0.4860961284181720D+0 + V=0.1896827480450146D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5756887237503077D+0 + B=0.5103447395342790D+0 + V=0.1899628417059528D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1225039430588352D+0 + B=0.2136455922655793D-1 + V=0.1123301829001669D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1539113217321372D+0 + B=0.4520926166137188D-1 + V=0.1253698826711277D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1856213098637712D+0 + B=0.7086468177864818D-1 + V=0.1366266117678531D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2174998728035131D+0 + B=0.9785239488772918D-1 + V=0.1462736856106918D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2494128336938330D+0 + B=0.1258106396267210D+0 + V=0.1545076466685412D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2812321562143480D+0 + B=0.1544529125047001D+0 + V=0.1615096280814007D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3128372276456111D+0 + B=0.1835433512202753D+0 + V=0.1674366639741759D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3441145160177973D+0 + B=0.2128813258619585D+0 + V=0.1724225002437900D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3749567714853510D+0 + B=0.2422913734880829D+0 + V=0.1765810822987288D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4052621732015610D+0 + B=0.2716163748391453D+0 + V=0.1800104126010751D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4349335453522385D+0 + B=0.3007127671240280D+0 + V=0.1827960437331284D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4638776641524965D+0 + B=0.3294470677216479D+0 + V=0.1850140300716308D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4920046410462687D+0 + B=0.3576932543699155D+0 + V=0.1867333507394938D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5192273554861704D+0 + B=0.3853307059757764D+0 + V=0.1880178688638289D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5454609081136522D+0 + B=0.4122425044452694D+0 + V=0.1889278925654758D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5706220661424140D+0 + B=0.4383139587781027D+0 + V=0.1895213832507346D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5946286755181518D+0 + B=0.4634312536300553D+0 + V=0.1898548277397420D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.1905370790924295D+0 + B=0.2371311537781979D-1 + V=0.1349105935937341D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2242518717748009D+0 + B=0.4917878059254806D-1 + V=0.1444060068369326D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2577190808025936D+0 + B=0.7595498960495142D-1 + V=0.1526797390930008D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2908724534927187D+0 + B=0.1036991083191100D+0 + V=0.1598208771406474D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3236354020056219D+0 + B=0.1321348584450234D+0 + V=0.1659354368615331D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3559267359304543D+0 + B=0.1610316571314789D+0 + V=0.1711279910946440D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3876637123676956D+0 + B=0.1901912080395707D+0 + V=0.1754952725601440D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4187636705218842D+0 + B=0.2194384950137950D+0 + V=0.1791247850802529D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4491449019883107D+0 + B=0.2486155334763858D+0 + V=0.1820954300877716D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4787270932425445D+0 + B=0.2775768931812335D+0 + V=0.1844788524548449D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5074315153055574D+0 + B=0.3061863786591120D+0 + V=0.1863409481706220D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5351810507738336D+0 + B=0.3343144718152556D+0 + V=0.1877433008795068D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5619001025975381D+0 + B=0.3618362729028427D+0 + V=0.1887444543705232D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5875144035268046D+0 + B=0.3886297583620408D+0 + V=0.1894009829375006D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6119507308734495D+0 + B=0.4145742277792031D+0 + V=0.1897683345035198D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2619733870119463D+0 + B=0.2540047186389353D-1 + V=0.1517327037467653D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.2968149743237949D+0 + B=0.5208107018543989D-1 + V=0.1587740557483543D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3310451504860488D+0 + B=0.7971828470885599D-1 + V=0.1649093382274097D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3646215567376676D+0 + B=0.1080465999177927D+0 + V=0.1701915216193265D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3974916785279360D+0 + B=0.1368413849366629D+0 + V=0.1746847753144065D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4295967403772029D+0 + B=0.1659073184763559D+0 + V=0.1784555512007570D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4608742854473447D+0 + B=0.1950703730454614D+0 + V=0.1815687562112174D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4912598858949903D+0 + B=0.2241721144376724D+0 + V=0.1840864370663302D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5206882758945558D+0 + B=0.2530655255406489D+0 + V=0.1860676785390006D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5490940914019819D+0 + B=0.2816118409731066D+0 + V=0.1875690583743703D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5764123302025542D+0 + B=0.3096780504593238D+0 + V=0.1886453236347225D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6025786004213506D+0 + B=0.3371348366394987D+0 + V=0.1893501123329645D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6275291964794956D+0 + B=0.3638547827694396D+0 + V=0.1897366184519868D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3348189479861771D+0 + B=0.2664841935537443D-1 + V=0.1643908815152736D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.3699515545855295D+0 + B=0.5424000066843495D-1 + V=0.1696300350907768D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4042003071474669D+0 + B=0.8251992715430854D-1 + V=0.1741553103844483D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4375320100182624D+0 + B=0.1112695182483710D+0 + V=0.1780015282386092D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4699054490335947D+0 + B=0.1402964116467816D+0 + V=0.1812116787077125D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5012739879431952D+0 + B=0.1694275117584291D+0 + V=0.1838323158085421D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5315874883754966D+0 + B=0.1985038235312689D+0 + V=0.1859113119837737D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5607937109622117D+0 + B=0.2273765660020893D+0 + V=0.1874969220221698D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5888393223495521D+0 + B=0.2559041492849764D+0 + V=0.1886375612681076D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6156705979160163D+0 + B=0.2839497251976899D+0 + V=0.1893819575809276D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6412338809078123D+0 + B=0.3113791060500690D+0 + V=0.1897794748256767D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4076051259257167D+0 + B=0.2757792290858463D-1 + V=0.1738963926584846D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4423788125791520D+0 + B=0.5584136834984293D-1 + V=0.1777442359873466D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4760480917328258D+0 + B=0.8457772087727143D-1 + V=0.1810010815068719D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5085838725946297D+0 + B=0.1135975846359248D+0 + V=0.1836920318248129D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5399513637391218D+0 + B=0.1427286904765053D+0 + V=0.1858489473214328D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5701118433636380D+0 + B=0.1718112740057635D+0 + V=0.1875079342496592D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5990240530606021D+0 + B=0.2006944855985351D+0 + V=0.1887080239102310D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6266452685139695D+0 + B=0.2292335090598907D+0 + V=0.1894905752176822D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6529320971415942D+0 + B=0.2572871512353714D+0 + V=0.1898991061200695D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.4791583834610126D+0 + B=0.2826094197735932D-1 + V=0.1809065016458791D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5130373952796940D+0 + B=0.5699871359683649D-1 + V=0.1836297121596799D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5456252429628476D+0 + B=0.8602712528554394D-1 + V=0.1858426916241869D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5768956329682385D+0 + B=0.1151748137221281D+0 + V=0.1875654101134641D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6068186944699046D+0 + B=0.1442811654136362D+0 + V=0.1888240751833503D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6353622248024907D+0 + B=0.1731930321657680D+0 + V=0.1896497383866979D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6624927035731797D+0 + B=0.2017619958756061D+0 + V=0.1900775530219121D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5484933508028488D+0 + B=0.2874219755907391D-1 + V=0.1858525041478814D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.5810207682142106D+0 + B=0.5778312123713695D-1 + V=0.1876248690077947D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6120955197181352D+0 + B=0.8695262371439526D-1 + V=0.1889404439064607D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6416944284294319D+0 + B=0.1160893767057166D+0 + V=0.1898168539265290D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6697926391731260D+0 + B=0.1450378826743251D+0 + V=0.1902779940661772D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6147594390585488D+0 + B=0.2904957622341456D-1 + V=0.1890125641731815D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6455390026356783D+0 + B=0.5823809152617197D-1 + V=0.1899434637795751D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6747258588365477D+0 + B=0.8740384899884715D-1 + V=0.1904520856831751D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + A=0.6772135750395347D+0 + B=0.2919946135808105D-1 + V=0.1905534498734563D-3 + Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) + N=N-1 + RETURN + END + + diff --git a/plugins/DFT_Utils/functional.irp.f b/plugins/DFT_Utils/functional.irp.f new file mode 100644 index 00000000..e034a244 --- /dev/null +++ b/plugins/DFT_Utils/functional.irp.f @@ -0,0 +1,54 @@ +subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b) + include 'constants.include.F' + implicit none + double precision, intent(in) :: rho_a,rho_b + double precision, intent(out) :: ex,vx_a,vx_b + double precision :: tmp_a,tmp_b + tmp_a = rho_a**(c_1_3) + tmp_b = rho_b**(c_1_3) + ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b) + vx_a = cst_lda * c_4_3 * tmp_a + vx_b = cst_lda * c_4_3 * tmp_b + +end + + BEGIN_PROVIDER [double precision, lda_exchange, (N_states)] +&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)] +&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)] + + implicit none + integer :: i,j,k,l + integer :: m,n + double precision :: aos_array(ao_num) + double precision :: r(3) + lda_ex_potential_alpha_ao = 0.d0 + lda_ex_potential_beta_ao = 0.d0 + do l = 1, N_states + lda_exchange(l) = 0.d0 + do j = 1, nucl_num + do i = 1, n_points_radial_grid + do k = 1, n_points_integration_angular + double precision :: rho_a,rho_b,ex + double precision :: vx_a,vx_b + rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l) + rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l) + call ex_lda(rho_a,rho_b,ex,vx_a,vx_b) + lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex + r(1) = grid_points_per_atom(1,k,i,j) + r(2) = grid_points_per_atom(2,k,i,j) + r(3) = grid_points_per_atom(3,k,i,j) + call give_all_aos_at_r(r,aos_array) + do m = 1, ao_num +! lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m) + do n = 1, ao_num + lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) + lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) + enddo + enddo + enddo + enddo + enddo + enddo + +END_PROVIDER + diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f index 6071a18b..7c9d2c05 100644 --- a/plugins/DFT_Utils/grid_density.irp.f +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -1,42 +1,60 @@ -BEGIN_PROVIDER [integer, n_points_angular_grid] + BEGIN_PROVIDER [integer, n_points_integration_angular] implicit none - n_points_angular_grid = 50 -END_PROVIDER + n_points_integration_angular = 110 + END_PROVIDER BEGIN_PROVIDER [integer, n_points_radial_grid] implicit none - n_points_radial_grid = 10000 + n_points_radial_grid = 100 END_PROVIDER - BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ] -&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)] + BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ] +&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)] implicit none BEGIN_DOC ! weights and grid points for the integration on the angular variables on ! the unit sphere centered on (0,0,0) ! According to the LEBEDEV scheme END_DOC - call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) + angular_quadrature_points = 0.d0 + weights_angular_points = 0.d0 +!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points) include 'constants.include.F' - integer :: i + integer :: i,n double precision :: accu double precision :: degre_rad -!degre_rad = 180.d0/pi -!accu = 0.d0 -!do i = 1, n_points_integration_angular_lebedev + degre_rad = pi/180.d0 + accu = 0.d0 + double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular) + call LD0110(X,Y,Z,W,N) + do i = 1, n_points_integration_angular + angular_quadrature_points(i,1) = x(i) + angular_quadrature_points(i,2) = y(i) + angular_quadrature_points(i,3) = z(i) + weights_angular_points(i) = w(i) * 4.d0 * pi + accu += w(i) + enddo +!do i = 1, n_points_integration_angular ! accu += weights_angular_integration_lebedev(i) -! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi +! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi ! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) + +!!weights_angular_points(i) = weights_angular_integration_lebedev(i) +!!angular_quadrature_points(i,1) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) & +!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) +!!angular_quadrature_points(i,2) = dsin ( degre_rad * phi_angular_integration_lebedev(i)) & +!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) +!!angular_quadrature_points(i,3) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) !enddo -!print*,'ANGULAR' -!print*,'' -!print*,'accu = ',accu -!ASSERT( dabs(accu - 1.D0) < 1.d-10) + print*,'ANGULAR' + print*,'' + print*,'accu = ',accu + ASSERT( dabs(accu - 1.D0) < 1.d-10) END_PROVIDER @@ -63,7 +81,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)] +BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] BEGIN_DOC ! points for integration over space END_DOC @@ -79,7 +97,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid double precision :: x,r x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration - do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom + do k = 1, n_points_integration_angular ! explicit values of the grid points centered around each atom grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r @@ -88,7 +106,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid enddo END_PROVIDER -BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] +BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] BEGIN_DOC ! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) ! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension @@ -102,7 +120,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang ! run over all points in space do j = 1, nucl_num ! that are referred to each atom do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom + do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) @@ -115,7 +133,6 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang enddo accu = 1.d0/accu weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu -! print*,weight_functions_at_grid_points(l,k,j) enddo enddo enddo @@ -123,43 +140,65 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_ang END_PROVIDER - BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] -&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] +BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] + BEGIN_DOC +! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) +! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension +! and the points are labelled by the other dimensions + END_DOC implicit none integer :: i,j,k,l,m + double precision :: r(3) + double precision :: accu,cell_function_becke + double precision :: tmp_array(nucl_num) + double precision :: contrib_integration,x + double precision :: derivative_knowles_function,knowles_function + ! run over all points in space + do j = 1, nucl_num ! that are referred to each atom + do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom + x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] + do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom + contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & + *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 + final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k) * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral + enddo + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] +&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] + implicit none + integer :: i,j,k,l,m,i_state double precision :: contrib double precision :: r(3) double precision :: aos_array(ao_num),mos_array(mo_tot_num) + do i_state = 1, N_states do j = 1, nucl_num - do k = 1, n_points_radial_grid -1 - do l = 1, n_points_angular_grid - one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 - one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 + do k = 1, n_points_radial_grid + do l = 1, n_points_integration_angular + one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0 + one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0 r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) -! call give_all_aos_at_r(r,aos_array) -! do i = 1, ao_num -! do m = 1, ao_num -! contrib = aos_array(i) * aos_array(m) -! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib -! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib -! enddo -! enddo - call give_all_mos_at_r(r,mos_array) - do i = 1, mo_tot_num - do m = 1, mo_tot_num + do m = 1, mo_tot_num + do i = 1, mo_tot_num + if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle contrib = mos_array(i) * mos_array(m) - one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib - one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib + one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib + one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib enddo enddo enddo enddo enddo + enddo END_PROVIDER diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f index 43eb1ab8..a665349a 100644 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -4,18 +4,11 @@ double precision function step_function_becke(x) double precision :: f_function_becke integer :: i,n_max_becke -!if(x.lt.-1.d0)then -! step_function_becke = 0.d0 -!else if (x .gt.1)then -! step_function_becke = 0.d0 -!else step_function_becke = f_function_becke(x) -!!n_max_becke = 1 - do i = 1, 4 + do i = 1,5 step_function_becke = f_function_becke(step_function_becke) enddo step_function_becke = 0.5d0*(1.d0 - step_function_becke) -!endif end double precision function f_function_becke(x) diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f index 4943783b..0708658f 100644 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -4,7 +4,7 @@ double precision :: accu integer :: i,j,k,l double precision :: x - double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) + double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular) double precision :: f_average_angular_alpha,f_average_angular_beta double precision :: derivative_knowles_function,knowles_function @@ -12,7 +12,7 @@ ! according ot equation (6) of the paper of Becke (JCP, (88), 1988) ! Here the m index is referred to the w_m(r) weight functions of equation (22) ! Run over all points of integrations : there are - ! n_points_radial_grid (i) * n_points_angular_grid (k) + ! n_points_radial_grid (i) * n_points_integration_angular (k) do j = 1, nucl_num integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 integral_density_beta_knowles_becke_per_atom(j) = 0.d0 @@ -20,14 +20,13 @@ ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" f_average_angular_alpha = 0.d0 f_average_angular_beta = 0.d0 - do k = 1, n_points_angular_grid - f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) - f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + do k = 1, n_points_integration_angular + f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) + f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) enddo ! x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] double precision :: contrib_integration -! print*,m_knowles contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha diff --git a/plugins/DFT_Utils/test_integration_3d_density.irp.f b/plugins/DFT_Utils/test_integration_3d_density.irp.f index 93ce58f4..dba02805 100644 --- a/plugins/DFT_Utils/test_integration_3d_density.irp.f +++ b/plugins/DFT_Utils/test_integration_3d_density.irp.f @@ -4,13 +4,55 @@ program pouet touch read_wf print*,'m_knowles = ',m_knowles call routine + call routine3 end + + + +subroutine routine3 + implicit none + integer :: i,j,k,l + double precision :: accu + accu = 0.d0 + do j = 1, nucl_num ! that are referred to each atom + do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom + do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom + accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) + enddo + enddo + enddo + print*, accu + print*, 'lda_exchange',lda_exchange + +end +subroutine routine2 + implicit none + integer :: i,j,k,l + double precision :: x,y,z + double precision :: r + double precision :: accu + accu = 0.d0 + r = 1.d0 + do k = 1, n_points_integration_angular + x = angular_quadrature_points(k,1) * r + y = angular_quadrature_points(k,2) * r + z = angular_quadrature_points(k,3) * r + accu += weights_angular_points(k) * (x**2 + y**2 + z**2) + enddo + print*, accu + +end + + subroutine routine implicit none integer :: i double precision :: accu(2) accu = 0.d0 + do i = 1, N_det + call debug_det(psi_det(1,1,i),N_int) + enddo do i = 1, nucl_num accu(1) += integral_density_alpha_knowles_becke_per_atom(i) accu(2) += integral_density_beta_knowles_becke_per_atom(i) @@ -19,6 +61,18 @@ subroutine routine print*,'Nalpha = ',elec_alpha_num print*,'accu(2) = ',accu(2) print*,'Nalpha = ',elec_beta_num + + accu = 0.d0 + do i = 1, mo_tot_num + accu(1) += one_body_dm_mo_alpha_average(i,i) + accu(2) += one_body_dm_mo_beta_average(i,i) + enddo + + + print*,' ' + print*,' ' + print*,'accu(1) = ',accu(1) + print*,'accu(2) = ',accu(2) end diff --git a/plugins/FCIdump/NEEDED_CHILDREN_MODULES b/plugins/FCIdump/NEEDED_CHILDREN_MODULES index 34de8ddb..8d60d3c7 100644 --- a/plugins/FCIdump/NEEDED_CHILDREN_MODULES +++ b/plugins/FCIdump/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson +Determinants Davidson core_integrals diff --git a/plugins/FCIdump/fcidump.irp.f b/plugins/FCIdump/fcidump.irp.f index f93c1128..8d334fc5 100644 --- a/plugins/FCIdump/fcidump.irp.f +++ b/plugins/FCIdump/fcidump.irp.f @@ -1,21 +1,25 @@ program fcidump implicit none + character*(128) :: output + integer :: i_unit_output,getUnitAndOpen + output=trim(ezfio_filename)//'.FCIDUMP' + i_unit_output = getUnitAndOpen(output,'w') integer :: i,j,k,l - integer :: ii(8), jj(8), kk(8),ll(8) + integer :: i1,j1,k1,l1 + integer :: i2,j2,k2,l2 integer*8 :: m character*(2), allocatable :: A(:) - print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, & + write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, & ', MS2=', (elec_alpha_num-elec_beta_num), ',' - allocate (A(mo_tot_num)) + allocate (A(n_act_orb)) A = '1,' - print *, 'ORBSYM=', (A(i), i=1,mo_tot_num) - print *,'ISYM=0,' - print *,'/' + write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb) + write(i_unit_output,*) 'ISYM=0,' + write(i_unit_output,*) '/' deallocate(A) - integer*8 :: i8, k1 integer(key_kind), allocatable :: keys(:) double precision, allocatable :: values(:) integer(cache_map_size_kind) :: n_elements, n_elements_max @@ -23,14 +27,18 @@ program fcidump double precision :: get_mo_bielec_integral, integral - do l=1,mo_tot_num - do k=1,mo_tot_num - do j=l,mo_tot_num - do i=k,mo_tot_num - if (i>=j) then - integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + do l=1,n_act_orb + l1 = list_act(l) + do k=1,n_act_orb + k1 = list_act(k) + do j=l,n_act_orb + j1 = list_act(j) + do i=k,n_act_orb + i1 = list_act(i) + if (i1>=j1) then + integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map) if (dabs(integral) > mo_integrals_threshold) then - print *, integral, i,k,j,l + write(i_unit_output,*) integral, i,k,j,l endif end if enddo @@ -38,13 +46,15 @@ program fcidump enddo enddo - do j=1,mo_tot_num - do i=j,mo_tot_num - integral = mo_mono_elec_integral(i,j) + do j=1,n_act_orb + j1 = list_act(j) + do i=j,n_act_orb + i1 = list_act(i) + integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1) if (dabs(integral) > mo_integrals_threshold) then - print *, integral, i,j,0,0 + write(i_unit_output,*) integral, i,j,0,0 endif enddo enddo - print *, 0.d0, 0, 0, 0, 0 + write(i_unit_output,*) core_energy, 0, 0, 0, 0 end diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index 16fce081..25d61c69 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD +Perturbation Selectors_no_sorted SCF_density Davidson CISD diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index 7733831c..a6e7e506 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni c_ref = 1.d0/u_in(index_hf,1) do k = 1, n_singles l = index_singles(k) - diag_H_elements(0) -= diag_H_elements(l) + diag_H_elements(1) -= diag_H_elements(l) enddo ! do k = 1, n_doubles ! l = index_doubles(k) diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 65d81e07..7c321b72 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -48,6 +48,7 @@ subroutine all_single(e_pt2) print*,'-----------------------' print*,'i = ',i call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) + call make_s2_eigenfunction_first_order call diagonalize_CI print*,'N_det = ',N_det print*,'E = ',CI_energy(1) diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index 41ec7b6c..c5205903 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -29,21 +29,13 @@ subroutine create_restart_and_1h(i_hole) enddo enddo enddo + integer :: N_det_old N_det_old = N_det - N_det += n_new_det - allocate (new_det(N_int,2,n_new_det)) - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, N_det_old - do k = 1, N_int - psi_det(k,1,i) = old_psi_det(k,1,i) - psi_det(k,2,i) = old_psi_det(k,2,i) - enddo - enddo + + logical, allocatable :: duplicate(:) + allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) n_new_det = 0 do j = 1, n_act_orb @@ -58,19 +50,56 @@ subroutine create_restart_and_1h(i_hole) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) - psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + new_det(k,1,n_new_det) = key_tmp(k,1) + new_det(k,2,n_new_det) = key_tmp(k,2) enddo - psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - SOFT_TOUCH N_det psi_det psi_coef - logical :: found_duplicates - if(n_act_orb.gt.1)then - call remove_duplicates_in_psi_det(found_duplicates) + integer :: i_test + duplicate = .False. + do i = 1, n_new_det + if(duplicate(i))cycle + do j = i+1, n_new_det + i_test = 0 + do ispin =1 ,2 + do k = 1, N_int + i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) + enddo + enddo + if(i_test.eq.0)then + duplicate(j) = .True. + endif + enddo + enddo + + integer :: n_new_det_unique + n_new_det_unique = 0 + print*, 'uniq det' + do i = 1, n_new_det + if(.not.duplicate(i))then + n_new_det_unique += 1 endif + enddo + print*, n_new_det_unique + N_det += n_new_det_unique + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, n_new_det_unique + do ispin = 1, 2 + do k = 1, N_int + psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) + enddo + enddo + psi_coef(N_det_old+i,:) = 0.d0 + enddo + + + SOFT_TOUCH N_det psi_det psi_coef + deallocate (new_det,duplicate) end subroutine create_restart_and_1p(i_particle) @@ -107,18 +136,8 @@ subroutine create_restart_and_1p(i_particle) integer :: N_det_old N_det_old = N_det - N_det += n_new_det - allocate (new_det(N_int,2,n_new_det)) - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, N_det_old - do k = 1, N_int - psi_det(k,1,i) = old_psi_det(k,1,i) - psi_det(k,2,i) = old_psi_det(k,2,i) - enddo - enddo + logical, allocatable :: duplicate(:) + allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) n_new_det = 0 do j = 1, n_act_orb @@ -133,17 +152,59 @@ subroutine create_restart_and_1p(i_particle) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) - psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) + new_det(k,1,n_new_det) = key_tmp(k,1) + new_Det(k,2,n_new_det) = key_tmp(k,2) enddo - psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo + integer :: i_test + duplicate = .False. + do i = 1, n_new_det + if(duplicate(i))cycle + call debug_det(new_det(1,1,i),N_int) + do j = i+1, n_new_det + i_test = 0 + call debug_det(new_det(1,1,j),N_int) + do ispin =1 ,2 + do k = 1, N_int + i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) + enddo + enddo + if(i_test.eq.0)then + duplicate(j) = .True. + endif + enddo + enddo + + integer :: n_new_det_unique + n_new_det_unique = 0 + print*, 'uniq det' + do i = 1, n_new_det + if(.not.duplicate(i))then + n_new_det_unique += 1 + endif + enddo + print*, n_new_det_unique + + N_det += n_new_det_unique + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, n_new_det_unique + do ispin = 1, 2 + do k = 1, N_int + psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) + enddo + enddo + psi_coef(N_det_old+i,:) = 0.d0 + enddo + SOFT_TOUCH N_det psi_det psi_coef - logical :: found_duplicates - call remove_duplicates_in_psi_det(found_duplicates) + deallocate (new_det,duplicate) + end subroutine create_restart_1h_1p(i_hole,i_part) diff --git a/plugins/FOBOCI/density.irp.f b/plugins/FOBOCI/density.irp.f new file mode 100644 index 00000000..4a988134 --- /dev/null +++ b/plugins/FOBOCI/density.irp.f @@ -0,0 +1,16 @@ +BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)] + implicit none + integer :: i,j,k,l + mo_general_density_alpha = one_body_dm_mo_alpha_generators_restart + +END_PROVIDER + + +BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)] + implicit none + integer :: i,j,k,l + mo_general_density_beta = one_body_dm_mo_beta_generators_restart + +END_PROVIDER + + diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f index aaf80c4f..14a2fefa 100644 --- a/plugins/FOBOCI/density_matrix.irp.f +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -1,12 +1,12 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, norm_generators_restart] +&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)] implicit none BEGIN_DOC ! Alpha and beta one-body density matrix for the generators restart END_DOC - integer :: j,k,l,m + integer :: j,k,l,m,istate integer :: occ(N_int*bit_kind_size,2) double precision :: ck, cl, ckl double precision :: phase @@ -14,23 +14,37 @@ integer :: exc(0:2,2,2),n_occ_alpha double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) integer :: degree_respect_to_HF_k - integer :: degree_respect_to_HF_l,index_ref_generators_restart - double precision :: inv_coef_ref_generators_restart + integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states) + double precision :: inv_coef_ref_generators_restart(N_states) integer :: i + print*, 'providing the one_body_dm_mo_alpha_generators_restart' - do i = 1, N_det_generators_restart - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart = i - inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1) - exit - endif + do istate = 1, N_states + do i = 1, N_det_generators_restart + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart(istate) = i + inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate) + exit + endif + enddo enddo norm_generators_restart = 0.d0 - do i = 1, N_det_generators_restart - psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart - norm_generators_restart += psi_coef_generators_restart(i,1)**2 + do istate = 1, N_states + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate) + norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2 + enddo + enddo + double precision :: inv_norm(N_States) + do istate = 1, N_states + inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate)) + enddo + do istate = 1, N_states + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_norm(istate) + enddo enddo diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index dd1ed221..c74d08e7 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -107,7 +107,6 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per !enddo !soft_touch psi_selectors psi_selectors_coef !if(do_it_perturbative)then - print*, 'is_ok_perturbative',is_ok_perturbative if(is_ok.or.is_ok_perturbative)then N_det = N_det_generators do m = 1, N_states @@ -117,7 +116,6 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per psi_det(l,2,k) = psi_det_generators_input(l,2,k) enddo psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) - print*, 'psi_coef(k,m)',psi_coef(k,m) enddo enddo soft_touch psi_det psi_coef N_det @@ -150,7 +148,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) - integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref + integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average logical :: is_a_ref_det(Ndet_generators) @@ -168,11 +166,17 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener enddo + integer :: istate + do istate = 1, N_states + do i = 1, Ndet_generators + call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart(istate) = i + exit + endif + enddo + enddo do i = 1, Ndet_generators - call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart = i - endif do j = 1, Ndet_generators call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix dressed_H_matrix(i,j) = hij @@ -185,15 +189,21 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener i_det_no_ref +=1 diag_h_mat_average+=dressed_H_matrix(i,i) enddo + double precision :: average_ref_h_mat + average_ref_h_mat = 0.d0 + do istate = 1, N_states + average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate)) + enddo + average_ref_h_mat = 1.d0/dble(N_states) diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref) print*,'diag_h_mat_average = ',diag_h_mat_average - print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) + print*,'ref h_mat average = ',average_ref_h_mat integer :: number_of_particles, number_of_holes ! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant do i = 1, Ndet_generators if(is_a_ref_det(i))cycle if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then - if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then + if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then is_ok = .False. exit_loop = .True. return @@ -202,7 +212,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener ! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then - if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then + if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then is_ok = .False. return endif @@ -210,7 +220,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener exit enddo - call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix + call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix double precision :: s2(N_det_generators),E_ref(N_states) integer :: i_state(N_states) @@ -236,15 +246,10 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener E_ref(i) = eigvalues(i) enddo endif - do i = 1,N_states - print*,'i_state = ',i_state(i) - enddo do k = 1, N_states - print*,'state ',k do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) psi_coef_ref(i,k) = eigvectors(i,i_state(k)) - print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k) enddo enddo if(verbose)then @@ -257,7 +262,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) enddo enddo endif @@ -278,18 +283,20 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix integer :: i_good_state(0:N_states) i_good_state(0) = 0 - do i = 1, Ndet_generators + do k = 1, N_states +! print*,'state',k + do i = 1, Ndet_generators ! State following - do k = 1, N_states accu = 0.d0 do j =1, Ndet_generators - print*,'',eigvectors(j,i) , psi_coef_ref(j,k) accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo - print*,'accu = ',accu - if(dabs(accu).ge.0.72d0)then +! print*,i,accu + if(dabs(accu).ge.0.60d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i + print*, 'state, ovrlap',k,i,accu + exit endif enddo if(i_good_state(0)==N_states)then @@ -304,14 +311,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener accu = 0.d0 do k = 1, N_states do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) enddo enddo if(verbose)then do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) enddo enddo endif @@ -333,7 +340,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do i = 1, Ndet_generators if(is_a_ref_det(i))cycle do k = 1, N_states - print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative +! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then is_ok_perturbative = .False. exit diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 8a709154..3860493c 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -15,8 +15,6 @@ end subroutine run_prepare implicit none -! no_oa_or_av_opt = .False. -! touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -28,7 +26,8 @@ subroutine routine_fobo_scf print*,'' character*(64) :: label label = "Natural" - do i = 1, 5 + do i = 1, 10 + call initialize_mo_coef_begin_iteration print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i @@ -56,6 +55,8 @@ subroutine routine_fobo_scf call save_osoci_natural_mos call damping_SCF call diag_inactive_virt_and_update_mos + call reorder_active_orb + call save_mos call clear_mo_map call provide_properties enddo diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 46ca9662..746704c2 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -40,11 +40,13 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) logical :: exit_loop + call update_generators_restart_coef allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. integer :: i_hole_osoci i_hole_osoci = list_inact(i) +! if(i_hole_osoci.ne.26)cycle print*,'--------------------------' ! First set the current generators to the one of restart call check_symetry(i_hole_osoci,thr,test_sym) @@ -54,7 +56,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) print*,'i_hole_osoci = ',i_hole_osoci call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det - print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) double precision :: e_pt2 @@ -82,10 +83,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - call diagonalize_ci +! call make_s2_eigenfunction_first_order +! threshold_davidson = 1.d-6 +! soft_touch threshold_davidson davidson_criterion +! call diagonalize_ci double precision :: hkl call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) hkl = dressing_matrix(1,1) @@ -118,6 +119,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) do i = 1, n_virt_orb integer :: i_particl_osoci i_particl_osoci = list_virt(i) +! cycle print*,'--------------------------' ! First set the current generators to the one of restart @@ -152,11 +154,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) enddo enddo call all_single(e_pt2) - call make_s2_eigenfunction_first_order - threshold_davidson = 1.d-6 - soft_touch threshold_davidson davidson_criterion - - call diagonalize_ci +! call make_s2_eigenfunction_first_order +! threshold_davidson = 1.d-6 +! soft_touch threshold_davidson davidson_criterion +! +! call diagonalize_ci deallocate(dressing_matrix) else if(exit_loop)then @@ -541,7 +543,6 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) call print_generators_bitmasks_holes ! Impose that only the active part can be reached call set_bitmask_hole_as_input(unpaired_bitmask) -!!! call all_single_h_core call create_restart_and_1p(i_particl_osoci) !!! ! Update the generators call set_generators_to_psi_det diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index eba9f0ad..6ec528cf 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -21,23 +21,19 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ] -&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ] implicit none BEGIN_DOC ! read wf ! END_DOC - integer :: i, k + integer :: i, k,j integer, save :: ifirst = 0 double precision, allocatable :: psi_coef_read(:,:) print*, ' Providing psi_det_generators_restart' if(ifirst == 0)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) - do k = 1, N_int - ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1) - ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1) - enddo allocate (psi_coef_read(N_det_generators_restart,N_states)) call ezfio_get_determinants_psi_coef(psi_coef_read) do k = 1, N_states @@ -45,6 +41,18 @@ END_PROVIDER psi_coef_generators_restart(i,k) = psi_coef_read(i,k) enddo enddo + do k = 1, N_states + do i = 1, N_det_generators_restart + if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then + do j = 1, N_int + ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i) + ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i) + enddo + exit + endif + enddo + call debug_det(ref_generators_restart(1,1,k),N_int) + enddo ifirst = 1 deallocate(psi_coef_read) else @@ -74,3 +82,18 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ] END_PROVIDER + +subroutine update_generators_restart_coef + implicit none + call set_generators_to_generators_restart + call set_psi_det_to_generators + call diagonalize_CI + integer :: i,j,k,l + do i = 1, N_det_generators_restart + do j = 1, N_states + psi_coef_generators_restart(i,j) = psi_coef(i,j) + enddo + enddo + soft_touch psi_coef_generators_restart + provide one_body_dm_mo_alpha_generators_restart +end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 7d194a54..db683c96 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) implicit none integer, intent(in) :: i_hole double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart,k + integer :: i,j,degree,index_ref_generators_restart(N_states),k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:) @@ -13,6 +13,8 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) integer :: n_good_hole logical,allocatable :: is_a_ref_det(:) allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) + double precision, allocatable :: local_norm(:) + allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -22,17 +24,18 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) n_good_hole = 0 ! Find the one holes and one hole one particle is_a_ref_det = .False. + integer :: istate + do istate = 1, N_States + do i = 1, N_det + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart(istate) = i + inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) + endif + enddo + enddo do i = 1, N_det - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart = i - do k = 1, N_states - inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) - enddo -! cycle - endif - ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -59,40 +62,48 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) enddo endif enddo -!do k = 1, N_det -! call debug_det(psi_det(1,1,k),N_int) -! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1) -!enddo + + print*,'' print*,'n_good_hole = ',n_good_hole do k = 1,N_states print*,'state ',k do i = 1, n_good_hole - print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k) + print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k) enddo print*,'' enddo - norm = 0.d0 - ! Set the wave function to the intermediate normalization + ! Set the wave function to the intermediate normalization do k = 1, N_states do i = 1, N_det psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo + + + norm = 0.d0 do k = 1,N_states print*,'state ',k do i = 1, N_det -!! print*,'psi_coef(i_ref) = ',psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) - cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo print*,'norm = ',norm(k) enddo + do k =1, N_states + local_norm(k) = 1.d0 / dsqrt(norm(k)) + enddo + do k = 1,N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * local_norm(k) + enddo + enddo + deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) + deallocate(local_norm) soft_touch psi_coef end @@ -101,7 +112,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) implicit none integer, intent(in) :: i_particl double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart,k + integer :: i,j,degree,index_ref_generators_restart(N_states),k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:),index_one_hole_two_p(:) @@ -117,6 +128,8 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) integer :: i_count allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) allocate(index_one_hole_two_p(n_det)) + double precision, allocatable :: local_norm(:) + allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -128,16 +141,18 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) ! Find the one holes and one hole one particle i_count = 0 is_a_ref_det = .False. - do i = 1, N_det - call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart = i - do k = 1, N_states - inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) - enddo -! cycle - endif + integer :: istate + do istate = 1, N_states + do i = 1, N_det + call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart(istate) = i + inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) + endif + enddo + enddo + do i = 1, N_det ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -173,7 +188,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) do k = 1, N_states print*,'state ',k do i = 1, n_good_particl - print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k) + print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k) enddo print*,'' enddo @@ -185,20 +200,29 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - do k = 1, N_states + + norm = 0.d0 + do k = 1,N_states print*,'state ',k do i = 1, N_det -!! print*,'i = ',i, psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) - cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo - print*,'norm = ',norm + print*,'norm = ',norm(k) + enddo + do k =1, N_states + local_norm(k) = 1.d0 / dsqrt(norm(k)) + enddo + do k = 1,N_states + do i = 1, N_det + psi_coef(i,k) = psi_coef(i,k) * local_norm(k) + enddo enddo soft_touch psi_coef deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) + deallocate(local_norm) end @@ -210,12 +234,60 @@ subroutine update_density_matrix_osoci END_DOC integer :: i,j integer :: iorb,jorb + ! active <--> inactive block do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) - one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) + one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j) + one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j) enddo enddo +!do i = 1, n_act_orb +! iorb = list_act(i) +! do j = 1, n_inact_orb +! jorb = list_inact(j) +! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) +! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) +! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) +! enddo +!enddo + +!! active <--> virt block +!do i = 1, n_act_orb +! iorb = list_act(i) +! do j = 1, n_virt_orb +! jorb = list_virt(j) +! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) +! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) +! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) +! enddo +!enddo + +!! virt <--> virt block +!do j = 1, n_virt_orb +! jorb = list_virt(j) +! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb) +!enddo + +!! inact <--> inact block +!do j = 1, n_inact_orb +! jorb = list_inact(j) +! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb) +! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb) +!enddo + double precision :: accu_alpha, accu_beta + accu_alpha = 0.d0 + accu_beta = 0.d0 + do i = 1, mo_tot_num + accu_alpha += one_body_dm_mo_alpha_osoci(i,i) + accu_beta += one_body_dm_mo_beta_osoci(i,i) +! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i) + enddo + print*, 'accu_alpha/beta',accu_alpha,accu_beta + + end @@ -261,8 +333,18 @@ end subroutine initialize_density_matrix_osoci implicit none + call set_generators_to_generators_restart + call set_psi_det_to_generators + call diagonalize_CI + one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart + integer :: i + print*, '8*********************' + print*, 'initialize_density_matrix_osoci' + do i = 1, mo_tot_num + print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i) + enddo end subroutine rescale_density_matrix_osoci(norm) @@ -438,6 +520,10 @@ subroutine save_osoci_natural_mos endif enddo enddo + print*, 'test' + print*, 'test' + print*, 'test' + print*, 'test' do i = 1, mo_tot_num do j = i+1, mo_tot_num if(dabs(tmp(i,j)).le.threshold_fobo_dm)then @@ -445,7 +531,9 @@ subroutine save_osoci_natural_mos tmp(j,i) = 0.d0 endif enddo + print*, tmp(i,i) enddo + label = "Natural" diff --git a/plugins/FOBOCI/track_orb.irp.f b/plugins/FOBOCI/track_orb.irp.f new file mode 100644 index 00000000..7f01fe6a --- /dev/null +++ b/plugins/FOBOCI/track_orb.irp.f @@ -0,0 +1,57 @@ + BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix that will be used for the 1h1p approach + END_DOC +END_PROVIDER + +subroutine initialize_mo_coef_begin_iteration + implicit none + mo_coef_begin_iteration = mo_coef + +end + +subroutine reorder_active_orb + implicit none + integer :: i,j,iorb + integer :: k,l + double precision, allocatable :: accu(:) + integer, allocatable :: index_active_orb(:),iorder(:) + double precision, allocatable :: mo_coef_tmp(:,:) + allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num)) + allocate(mo_coef_tmp(ao_num_align,mo_Tot_num)) + + + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, mo_tot_num + accu(j) = 0.d0 + iorder(j) = j + do k = 1, ao_num + do l = 1, ao_num + accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l) + enddo + enddo + accu(j) = -dabs(accu(j)) + enddo + call dsort(accu,iorder,mo_tot_num) + index_active_orb(i) = iorder(1) + enddo + + double precision :: x + integer :: i1,i2 + print*, 'swapping the active MOs' + do j = 1, n_act_orb + i1 = list_act(j) + i2 = index_active_orb(j) + print*, i1,i2 + do i=1,ao_num_align + x = mo_coef(i,i1) + mo_coef(i,i1) = mo_coef(i,i2) + mo_coef(i,i2) = x + enddo + enddo + + deallocate(accu,index_active_orb, iorder) +end + diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 79599065..8977b7fd 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -12,11 +12,6 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply("FCI_PT2_new") -s.set_perturbation("decontracted") -s.unset_openmp() -print s - s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index ad5f053f..2f1e40a1 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Davidson +Perturbation Selectors_full Generators_full Davidson diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore new file mode 100644 index 00000000..7ac9fbf6 --- /dev/null +++ b/plugins/Full_CI_ZMQ/.gitignore @@ -0,0 +1,5 @@ +IRPF90_temp/ +IRPF90_man/ +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 47c8fa26..6fd4fd5e 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,3 +1,1116 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, fragment_count ] + implicit none + BEGIN_DOC + ! Number of fragments for the deterministic part + END_DOC + fragment_count = (elec_alpha_num-n_core_orb)**2 +END_PROVIDER + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert failed: "//msg + stop + end if +end + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 + end do + end do + end do +end + + +subroutine select_connected(i_generator,E0,pt2,b,subset) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator, subset + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) + enddo +end + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(2,*) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np1 + integer :: np + double precision, save :: res(0:1) = (/1d0, -1d0/) + + np1 = phasemask(s1,h1) + phasemask(s1,p1) + phasemask(s2,h2) + phasemask(s2,p2) + np = np1 + if(p1 < h1) np = np + 1 + if(p2 < h2) np = np + 1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 + get_phase_bi = res(iand(np,1)) +end + + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, subset + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + logical :: monoAdo, monoBdo; + integer :: maskInd + + PROVIDE fragment_count + + monoAdo = .true. + monoBdo = .true. + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + +! ! ====== +! ! If the subset doesn't exist, return +! logical :: will_compute +! will_compute = subset == 0 +! +! if (.not.will_compute) then +! maskInd = N_holes(1)*N_holes(2) + N_holes(2)*((N_holes(2)-1)/2) + N_holes(1)*((N_holes(1)-1)/2) +! will_compute = (maskInd >= subset) +! if (.not.will_compute) then +! return +! endif +! endif +! ! ====== + + + integer(bit_kind), allocatable:: preinteresting_det(:,:,:) + allocate (preinteresting_det(N_int,2,N_det)) + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + do j=1,N_int + preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) + preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) + enddo + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + maskInd = -1 + integer :: nb_count + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + negMask = not(pmask) + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) + mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) + mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) + minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) + minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) + enddo + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) + fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) + fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) + enddo + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,i) + fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,i) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(j,1,i) + fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(j,2,i) + enddo + end if + end do + + + + do s2=s1,2 + sp = s1 + + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + monoAdo = .true. + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + banned = .false. + do j=1,mo_tot_num + bannedOrb(j, 1) = .true. + bannedOrb(j, 2) = .true. + enddo + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + if(s1 /= s2) then + if(monoBdo) then + bannedOrb(h1,s1) = .false. + end if + if(monoAdo) then + bannedOrb(h2,s2) = .false. + monoAdo = .false. + end if + end if + + maskInd += 1 + if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + if(fullMatch) cycle + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + end if + enddo + if(s1 /= s2) monoBdo = .false. + enddo + enddo + enddo +end + + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) +! ci(istate) = e_pert / mat(istate, p1, p2) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + PROVIDE psi_phasemask psi_selectors_coef_transp + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + if (interesting(i) < 0) then + stop 'prefetch interesting(i)' + endif + + + mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + + if(nt > 4) cycle + + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + if (interesting(i) == i_gen) then + if(sp == 3) then + do j=1,mo_tot_num + do k=1,mo_tot_num + banned(j,k,2) = banned(k,j,1) + enddo + enddo + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + + perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) + perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) + do j=2,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) + + if (interesting(i) >= i_gen) then + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + else + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + end if + end do +end + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + h1 = h(1,1) + h2 = h(1,2) + do j = 1,2 + putj = p(j, 2) + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + hij = integral8(p1, p2, h1, h2) * phase + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list_in_selection(myMask(1,1), list(1), na, N_int) + call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end + + +subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint) + integer, intent(out) :: list(Nint*bit_kind_size) + integer, intent(out) :: n_elements + + integer :: i, ishift + integer(bit_kind) :: l + + n_elements = 0 + ishift = 2 + do i=1,Nint + l = string(i) + do while (l /= 0_bit_kind) + n_elements = n_elements+1 + list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + ishift = ishift + bit_kind_size + enddo + +end +======= use bitmasks BEGIN_PROVIDER [ integer, fragment_count ] diff --git a/plugins/Generators_CAS/Generators_full/.gitignore b/plugins/Generators_CAS/Generators_full/.gitignore new file mode 100644 index 00000000..8d85dede --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/.gitignore @@ -0,0 +1,25 @@ +# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py +IRPF90_temp +IRPF90_man +irpf90_entities +tags +irpf90.make +Makefile +Makefile.depend +build.ninja +.ninja_log +.ninja_deps +ezfio_interface.irp.f +Ezfio_files +Determinants +Integrals_Monoelec +MO_Basis +Utils +Pseudo +Bitmask +AO_Basis +Electrons +MOGuess +Nuclei +Hartree_Fock +Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..54f54203 --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Hartree_Fock diff --git a/plugins/Generators_CAS/Generators_full/README.rst b/plugins/Generators_CAS/Generators_full/README.rst new file mode 100644 index 00000000..c30193a2 --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/README.rst @@ -0,0 +1,61 @@ +====================== +Generators_full Module +====================== + +All the determinants of the wave function are generators. In this way, the Full CI +space is explored. + +Needed Modules +============== + +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + +.. image:: tree_dependency.png + +* `Determinants `_ +* `Hartree_Fock `_ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Determinants `_ +* `Hartree_Fock `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`degree_max_generators `_ + Max degree of excitation (respect to HF) of the generators + + +`n_det_generators `_ + For Single reference wave functions, the number of generators is 1 : the + Hartree-Fock determinant + + +`psi_coef_generators `_ + For Single reference wave functions, the generator is the + Hartree-Fock determinant + + +`psi_det_generators `_ + For Single reference wave functions, the generator is the + Hartree-Fock determinant + + +`select_max `_ + Memo to skip useless selectors + + +`size_select_max `_ + Size of the select_max array + diff --git a/plugins/Generators_CAS/Generators_full/generators.irp.f b/plugins/Generators_CAS/Generators_full/generators.irp.f new file mode 100644 index 00000000..eea5821b --- /dev/null +++ b/plugins/Generators_CAS/Generators_full/generators.irp.f @@ -0,0 +1,75 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + integer :: i + double precision :: norm + call write_time(output_determinants) + norm = 0.d0 + N_det_generators = N_det + do i=1,N_det + norm = norm + psi_average_norm_contrib_sorted(i) + if (norm >= threshold_generators) then + N_det_generators = i + exit + endif + enddo + N_det_generators = max(N_det_generators,1) + call write_int(output_determinants,N_det_generators,'Number of generators') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + integer :: i, k + psi_coef_generators = 0.d0 + psi_det_generators = 0_bit_kind + do i=1,N_det_generators + do k=1,N_int + psi_det_generators(k,1,i) = psi_det_sorted(k,1,i) + psi_det_generators(k,2,i) = psi_det_sorted(k,2,i) + enddo + psi_coef_generators(i,:) = psi_coef_sorted(i,:) + enddo + +END_PROVIDER + +BEGIN_PROVIDER [integer, degree_max_generators] + implicit none + BEGIN_DOC +! Max degree of excitation (respect to HF) of the generators + END_DOC + integer :: i,degree + degree_max_generators = 0 + do i = 1, N_det_generators + call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) + if(degree .gt. degree_max_generators)then + degree_max_generators = degree + endif + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer, size_select_max] + implicit none + BEGIN_DOC + ! Size of the select_max array + END_DOC + size_select_max = 10000 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] + implicit none + BEGIN_DOC + ! Memo to skip useless selectors + END_DOC + select_max = huge(1.d0) +END_PROVIDER + diff --git a/plugins/Generators_CAS/Generators_full/tree_dependency.png b/plugins/Generators_CAS/Generators_full/tree_dependency.png new file mode 100644 index 0000000000000000000000000000000000000000..eed768663d7f287bfec3d9b93f170370955e4983 GIT binary patch literal 82663 zcmXtA2RxO3`#$#GlB^^N$x6s3t5A|qWLH!oSsB?YJ1t7cuFOgyD?7Ak` zYU#NjOUwCQJ}cn(ULNJ{>EF7f>62Sg+Uq^$muB4KeZu(5lA8LLDw@AZWE%4;8&U^j z#%YdBGhhLC>|K@kf&kw#+DV~fxLHvXue(E5hol3nVYRu&7%(B+BA;e#Z+$Y^d z9h7$DW`H|^nLLj%s^ONd;PCLUZSnoK^K_waA3fshr}0vzj(ghz__KmUn1gzbU$}5VM@Q$vg}vc*HqZOFG18W1^$&RUg~w z|GO3!7mara%CwA+ZA)jCNtaA|pPilk_3Kx>_V)HJEqTZcrgzvxY6_%`baWUVCtmF} zH33Jn9@jZoc6N7ncXlQiXgQF5Xl|yCYdV={Od4oyZ7tatu!ofU1K6UNBN&24_> z%o#JYwCWc7Uz~Pf{OtOH%prkGOG^U-1IfwBtE;Pxjg1&CUhm$$+t{c*b6uA;(*FGU z^B0NN(Tq;q<@@*V9b}T{iZGX@`yPuqWIO+NIXQh-9U2%AP3i0FGfQU7fA&mFOl;0F zc&~LjOCV;tF+q)ASVE%k$&)7uC(O;GmTJZqyy)oYE?v5G?b3P-nA6$#gCT1C4%iWQ10U%Z6ckVrm?Jg0 zxw%bEP37d|FpKyBi_$kkO@iI#(1U$eP;g`6b3@d2iC@2eW4Jr$DG6%WV*UO7EiEk# z4Gs7KS7#^7yo*%lz`z-kf0w1DCFUAGo;Ld@^gjgdFoPU4+z=hbHoW03EpXKKl$Fg(XR^!io@}s>C>lVgpL_E8Qu?%ln2|}nI45c62wtSOD{5ehK=~_*)uHF`uh6Fh^4Z! zG80qWp~AA)uN@p6ZFq%byz#4*m6hv-ckbMYY_O%Hi>kp!3<#*HQN#WBukr6PAU(-X z-jb***#1bl;@Z@)GiL@8_a1+3QIMCHS6%I|rWR0Lz4h?WwHGg67RR!1NqqnQ{m`L9 zr%#{8Y~U>u3tkQi^fWZ5%iToYlxWx0uv4p7UvhS?_WUuDqUdR4WTc>=kZtgw)MZ@5 z|KEjE_$(t>lAoFS*RNkC&!1yI>{RlqIsbfkXz1>K^HR5&uCz3M*2oa|fDW@-c4`BU zj~_oqMn+bz|I)Lxp@4+ zx7pbrLuJ=CR{!+$;6xVruKfD=)HFOS3_H!1mrF)kl0qXfN>}jc(W9%QTbuV%QVg<; zb_)oM`28J@k7p(&QIXirRs7+@hs?}Oy?f$WIXT$vg=bz~ocfT$$H!;ZL?J?(t>#c- zEuGX9%d6~i>U-OX+LWSvLexXl=O+0bROx3#sI7FZl|{i5sWIJ3U;+jD+s2NxG@ z;qH`Wthvn2sD{;cp(U@MPjsS{`(+J|r(+ z-_VeMwt@rUj(59^Ft)jYP=YQiE9>S$oIhfuvd_}x{*ut6S+>0FnJYJ=qN-QEJ~(jU z!}8kNP6aoIrMZ4H9dZWx((YX`ckbPrnwVhY<=yz8_~Z7ydzff*_m$&H&isHi4L+Aw%Zeu$f`)sIIG=a7bmrmUKwI=+TNwGYKN-ljWcs1fZ`*XbRNtIH123bgG;LuRu))Px}o@7ZO zjrUvYdzXK;s;Y=`-m+L1wc?G`bX{GXK^($F?lUcTT~YD$a%a4N^*-h<8S0?*KZX9o z#db}qTPy84aeR3STSo+~|6GiJKqt1p_PA=`z!`q#fJb~kzinGy&>5S3+GQ=%(hx-; z#NQ@gUZ+X8wJo@5Lhj0tnW3RtPIqunkkQGL#j(`hWS1#4l7(btm&R&?v9jhbFK(lZ zs`g-b^P5rf0NM5HHScJH3AZnOenCn@&d)&>X>Wf)y7&sk(MZk5G2C*NmEM19gQ;%Z zxbcLEz{QNu;+h^<+V{MZIYll0gn-{uBn0apBP?I4uT81BNJ`3(4-C}QlB{q1 z2xwTHD0KLH$Be#enN&Z8_QlKE#TouxHZq}$e*$?G1Cn;ckB}!N(e&n%_4Wqnk~cP5 zFWAQ4`qgMr^1Rg}lZM=SRAp?O#LYdhK>X)V!l*A<$XlDc!mNQi{mF0KsOe#k*RAPd zeP%%u=EQlVnuI{$+tT4A^O(zf^2#}rn*1$}&At8R9NV_-@vD^xQ6>+Pp-63iRa!by za*pnv(JxRgyyZ+WxK?Be{`qW$vWLi6_UDIAF8Rfv0&Q2P@*c& zbL*kfv{mPh>q_?XLnNCr{we~@^e^i-FYV%fZ%z5&T+Q`KZN`lglYN&PQ zZc&`%&pcFMRUO+jfdGA1J-&sSKppqDvAK3>xhZxRf#1YL*H)lwB-W)&*F*O6WGEq^ zzOhQGFowbPx6oVLU4Q=QddZU#SUKfCYdm`vZ~lszaVm~*cmLt}A@%$En*3^9T=8U7 z%mii$iIwKb`lj6k{;;rSL`QS(uHLYR@_~lJ)P&~Ejl=s-m~JN_L`EIv;$jXY%*<(C z8PVjBFqw|}zB7_5Ta8@3YHQO+^v=6U*J1`T4MZ`=SZq^-+~{Dnlh#(F+`Fmt0##Hn zVcx6UY^J9$^w?PE_YZFUY9jymk(v+@SQ|mNGP!-l;pEALBFXw8o?XnF)N%TE<19Wr zJB_z#yye~U*L8WL6T7T_G0W_sxO?v&8394Ih&Y5+ z8~(P1Db=mAk`mU5sQK(;6z=Y6FWBW3nSPp1Dlh{u(7Pn3nus+FmbGyKU z7y=>HkCK^ueWg9^8U5lP5^@q{WxxsfvOTM7!8d8+?@%oLpxS3j>gVV3S3Dwe$GP#1 z->0oc9mr0l+`LIk2*}Uh-y5h#K+1BwHQ9Ra)5nilSy?ta>Qgt#3511(v~us|$l)OZ zVXP%_bkNCFm6pqW*Qrz0;orV2`rNGax4OY4(-xuW9IZK;>9w}Rz1x3d8$r@#(3B&P zu)a|{x=C4JK|(=62#_mK=Vdu?fKbEj^e#I31V@%e&ao6%506K(PF(*R04oxADBboO z>kCbOoTZd^#VN+e)1I>}F9(oOscBJ+{U!+~JE~W^x$%q5d61Go7#|;7zG`Srx4KG5 zWqQ|ITWnV|YSpierHmGXe6xV$H$j0_=x`o*i@r=}zX=i5pG1qIdNwbleis-bcU zm35cfT6ym#n&NRxp9WLJoUfLFOKIiYdY~OG*P-5~^ z_u*qH-gcjP6)7JXl{<;Lb~a7Z_E%fo`21&fGH0mBCV=$1lAy3dz&Q%4-M*VYZCW>c z7ZWr_FK&@KkKUCy>fPO7ea*)E5PfiMQAx>}H(te>0=1%)x{UgP@!3a?9NCrF@}u%E zpH;bHV|@&_t}(l+x=jV5=E$u3?S`N^A-=Z$-tUWi!EWjcqrM|wAkfFnp;L!ZzYBTBaN17HE_UR-E@bZzRxbsrz#q64C$H+2O878bM9 ze?Kh$o`GTlI3#DM|9V3ER8vEP(_krsNf`~$xr33{`tri7(HjpQKD>P8N|oQ*5^!D3 zNu&6#ZS3qk3U1SHL+RLQ0pa#z$eHP$chuOn=?8WQzO|MF3~-(6lM=tjy<^A9e8ms( z(V~^LsBuE|UH9=`51%J@K>N%RhI8YDC_=IZ$MCSWS)4dsTfm0T}W6 z%hFOHL(4Z_QgU*i>g(FIEI zfx4s6tXM!yOyA0C=j?P^XD}+M&6rE&{=0tv`USABq@+YjMn*2->7P`B;QwK3qlcOF)Rk(fo_Pu*^0Kx|P`%jyj*O^Ngr(q_(zPxpd zRc7ktix&g}Y9Nf@VM+={()p0eYD^^wsa^eO@8F<0YCse_7$1K4H_EoD-y{T0frMi@ zgZ=&KJ33JqfE>W785-h|-JuiMc3uuAR8|(h>}_^%a?;u>DJ|{l>Z-v#?Jzs^;R7RI zsG1RRGF~5M&dkd@QXZ`R_Y>9@D<_aZozmFT(}Qz>&%-Nfc!kTjP`qau6`!Th2f)Yo z;fjro4GRnF?KPncM%6md(b0j)>gcGMbnO(u{eQPi)vSnAmdr18ACaI2_oDHa0fcH#RoA6fd7Y zA2xne{Ts2iPfi27gVM>zr$T0*?tu_D!DNlqcD*d4&gfi}*C>d=7!(#B2UTM%$`>am zE&X<4!C3T;8h`Z0O`S;1x3DIJhoaS)~rm zVNR1J(Eqv{)lED=N&zIG*=kPB-l9?%r+Ao?IDb$&;*;weza{!}RoB$u0jQ zr0(ifc5#TVuD!dn4+lZXd(pwm>-D2YBd>i$m@^4p-zCWNDi4P<`YrWe7<}cd>M|B^ zM&{1f_SEA-iKG5o8(VADTTxL_bqYKVzk>2XE7)nIyUh0H<1}oJhwoHbo!^=Udr?aybe=q%y0y~8x_~g{nN6J1PE59c9=-svE{os(9on2sAIndBR ztU`X?;?Vs=jAAd1O-wkrxJ21$QJW%l=;MY zjH_{c%F=RjO$t1FkmTM~`uyEo%u%iU{Xr4KC*CD1kxuFf(-c7Q-~Ym~J16yq_x#Wy z>7;0P&7+6;nHiDXCQtzXPTgAnS;s^{O47@so=7@J7sCGs`}AoHv)P=*KGSSBSWy|$N^*U6LJFE4#UXf0;E;ESR+JTx@2;WO^` zb$L1NHnU|c(vUiN8i?B0&u_)|#<63ujl`QxOg!n~QHpq6SokB~{8bSnRhK>S;D&gB zOSt~~E9e-+$Ns@VJKorvpyx&_JS9X$zkPo-s^T`yjO@|k<_@<`79zj9hzr&tDX-C}LUKk43D+uV4)mGu4M0D&;CI0Ky#$PEZDYNk4EacN? zr=K?t4k}7XT`l3IQk!5Po+uamp|aoVVpo)ab;tub=knLDt#NyY z{@tD#mibL(9SziDQ@IG|D39HQbbXGRD_7uhKTwL#L zi!sYa&Oco_so!$qZ*doVhg|KE!_2}n_-JWq-`3TE{cL+6m-6r-@lQ>Qwo$8_*-CQa zF0k>+{kK%!``^6g>Dk`amSvQ;xw(mWWEM`Ax9?vBoK9>9O^RrYbX&}*(`II7mYI_y zflS|WYY$iq;$Q9|{v|iI851L;c53*{*jRwO{KZIpp;X|i=j|$M*p#?4K~@^#ZBY_$ zi-4it*=IUZ;pvPVg`qaO$Xi^#JeQ?+FLtLYA8zdYb8rksdx2B`Gxi{2JSHm>5d}e+FlJ;SrLC+s;a7h1R4-31c(8yQS0zwV7Z!& zwZDLd8;FUvydMP5IXR^~dNlw2yE0H4unRV&%(w%fkPR;xxnuHFd#Z%RYv%AeW#476 zQgpK}LI+tRUtIk7WMpIn$MEl;Kl{y!2t*c*UFJlM2|u|=|DV}UQ`lKf125+0E)(g@ zy1;o%BSS@ zbGkDFTr6cUF+zp_fs)7c1$aK734II1JU3kNw^gEA$#3;VX=&*ri3CSyXC`|3x%v6Kye;<9K&>}`guz5MG&a5+$);%?8Bvjw zBSO93U)w4?z9-M6Dkv&$7q{^GTu<}NHrSYW^0<;-zkZD)jX((W>ZX7CbkeI=o;Eh) z!Bk8p`Da3%ygG^?h}=p{eC0gKw{6?D?c2kvMAi72-)t-m0t@sMjVP8&1phJW*yBKxp!Ep^CBAADOvvH@+nJey%LA(J zZpb0Hg@L}l+qZA)`jA|ew?MRxi(@J+Ru?5sv&gsiNe8%PFUJqtW54R^HWyZJ9u-KC zq^IYKa<1N3a`s<)Fvm$6IQI4H()!9ZB|eXBj`GAav`dTw6Iq33}^vnw`foS5Z4Qgd7hGtuDi7rKRLt1>YrH_78cjt3tmb={Oq)Q6coIX z#!$E3ucwSTYiT)xY|#GjP~Er-K>DJ`aRMPh7p2MjwzklAg$`q4;xoiJkreIhGG0{Z z>gmy`$7@A#H~~p0De`(sjjGC9wt508MPw^dGtlyPtA2>z(DNE7sO13v!J`|A~E4l0;46FctI8 zoe&=^$<=|o423g09q?5{udilAMYVF8G9=%JFm(*|11i+7U(YY50@$88bqY0)>S8p$ zLYQ4TNk34n13PYTa33>urvEnDP*lo?-xvIYoLM^o!2z8AEG|Or0lrJnm64R>oOq(X z0mzsat0~~r6~qB;?J!-zGp}823=NsjoINde_r=KL zCVL0>Q|i{xSL~(xq3Y-gK0d{sUtqjrTIZh>c;41l;DJf{CSt?wJb++?%k=cXT5B0u z*~k3_pt|z&8F=qz%e-LGPB-j`;o!|S6sDx4EIEXkKOxNS)|z9KC&=n3*7WwD99d*0 z#uxYL)2F8M&nZX)FE>uQ$j^N;6EnGf{m{MEhH;m!Zd)w7HmU*{RIJeY-1=4zDx?$u zvWNU&;W`ee{PN|t{KwGxZ~?+&BJl$tdVapa(vE4|hl6nyP-5LU_G5Du z^Ht->?A44;)NaUuz{{sjp$alIH4V?MjE!Y< zBb83NjOqj%|G#1d1rQ(te#UQ5xLmxbu)uU|ZFSYM$~RJFkDf4l>C2Y~<>X$0(ZLrS zJc!#v`@yqWRn&ho@sEp&Cus3ZDtYmhBXQ z&H#XQ#tzCXDne|iuVZ7@7cS(8?^D#q4c8$gAhbY`+$PP%%}qj(=lK9YfFcw{q(`;0 zUAqIRc6Jvp-gF-m{WvgibKVk5koA2GkqC3@#`e6lRQp z-4g21w?tX5qy(P{A#+hKxK<5e!9nK5&BysWLGC&paHtvFCBqljbO{3O<;$A0q6z_} zk)3l9O%qO+FZ1y5bVSQL4aodgj@zt#_(&xC-avyx3I%w<1)RLP>J9cFD{FFYZVuBV z5qvD?(uh#H1;PQg`RdDmy71@na)n|ueST)-v!S6Oq?)PsNx?T>nKeD-tGB)C=qPeV zwX+=cI6Wc$Mpntoo`C@_k5SQM{LC^kGRCdKqN1V_5;|+75V$+aZanuA=zjgcWFb}6t>uLYl;2n$Z0U%98!g#E$FidjM6MuqHKNG&?GKWZ z!6A5~vV4BN?X5z=IKn2%Qo+4@Jv}_i%gVGgH8r)hVP7ymaOOpaH8c73rMc6nt#Dnv zS{xa9#NPf(V+{Ak`nqH^kUvB1xQjR{t+~Ep)Q1X(4&_@_tB8uysx-Mu3yX-9;S6E# z;+FkL*{{l7&_Eto0awYC30n${E&3^4T>0Q?N!5Y4ovR zrj84`M12Niml@Tc3PhftKV5JHxnelj*nWR*pd(f}HxU+i6+KYpqqdHSh(OrcMnyQ8 z#$_kT>A%uy1qu<9>AyTqC6pNHuF1SqUQx02w|dJUMd6OV(2u@ivO!I+t<8;<-&14+ zkU#$42M(&F#@R@AgfvY3PP}ysn~91*O+#~i`Dgk&4u+FyXRs4M!b>HuAA2ajiT`AVzgtJ*X66Wy!Nc> z1t?0CQ)C39i2|YP>e*ftjvb!o)`5y9%K1h5w-S&|W3&;8`m6jZR%MkBdQEU8JT)zR zEHVEY7LDco6gN6AW|Wk4;hqKt6!z@VI!AX(o%W#v_nWU-YCQ;EV*B@FBUzq3tIRhU z)$kcr-Gs|)toHN%xdpTOfUwuS5&{CYnIirIJ=)J~?^Dl;hd0;~<&5yU?_j|n7W{f( zwvV16`^l4c;4FrR&o-FK=?}2yTJG70Y;yzg-c6x0J6pSK4?Z2mIYKcg0F$ykOnOV^ z+afhFR|q}+8?#oOulU;#)W{_Weq;Na7GTh)!llL84|8>{Yn?&hV{R(%Aan8u`0 z?mGFdPwxS}(692nd-kwI))T+;sKoW40!cx-O6Raz>)aciH*;#DqobKrmTTUHVz#RWL?W4OY!G*9%E#bSo8;3}#x`1p{efc;w% z_ntF7TAS}2p+RZxnQpjT$E3Qvy4vL+Baq-=W5cp-+aE+ekza);3P4>=EG)y=HpxME za!j+yT2fcA3&%VhKLy25%|NQl9nB`y9 zIr0q4bL8q?N+TdZ*S4$pZ~Ds6(UJ#2=wYhVo_0BU^d{^uKoRf6dv5>fKCbF`=@R4s z(X1EnXMvg(&dNQ(`FZP&yM(Wl>IcO@q1V7+8QF_@^}q%MU;-pS8Qqq zRL9O2fjL6qAqgL3em4~(4}suy{d&tbgmCxS-u)%`fx5AE318u>Wy{z^0>py^~1xwgrC3LRhdrwD!VoXD-GZma?Q5L3lBrW!frsk zwUd~FDk{i&M36P6GPiSw00j)2@3PgjzBLA9iKt9ie>C^L=Lzr=V5e_jKxMvrF=Nhs z42%nb07Y~qRIwm5>Q`ZZmwF9jLKQp1IswP_-&bq{OgO?}C4r?i>LE1Qcd zE6;k^o0~syQ;n+fFV4?*inz7lwGMjs)YfZ`L*Uy1F1URTfwYs7mF4p}lp$Nc^)xq^ zng9<~XWY%67!tjczKyj{qRs~#1+Mbb3p^18N{dZX{tr@g$p_mgkrF89i5?h4NL zF)``w$vb(j)uP-Dr(-t2>NPFrjvXSeKJ8E)+fHS`!@wLG?5S6azM;^HVbr~LXNc1=Fj$?b`U|bP zNY%eXhU5vp97WI4kI`z^$)kRL8<2Jz>+6N33%k+}w!to%6e=o}qA@Z4YqFJ`RQ
yec~N#>BwPs zd9VNaa^&Z#W^Q;m6~Vgb(!Gvbzyux7PvPWpy2snqTT7z;1RBHP!7V50^UVzv($X(& zLG;wAaLjs|M?6EaqS6^b<~IfG*!x}Vbz;3|6S)ud-4&)&-cUUE?)I+i9jaKrPMDOx zU*uK1PrA1pCg6Sho=#6Y=-(|E3;RAc28#(eY*5F!T%z zwX>}@RcrH#gn+=nTA)*eb*OR5w}`6^O`lPAt50FR0mG&yZt+|)&3Out$9c%`EG6cZIdvqWiS_H z_50l>2Qheh?Ez6R(_PaI+kdmg9=z$t-rl>qf}$nI)tLnk9(0Fk7N-CVkd97MTif@< z<0=V$BDF9W>xwf`WsoDh_TU ztT=FJuDKfT1|TyxR}>P`o@qeob=5oMV~4$Gn;>gTeSLjv>#PJ&vGrd=rnAKSR`(%y z?C#^{`w8a@PdNLz?xwQ%i^2z7J0x_LNKMdM{{CB_kDn})S|{kfK&izVDZ{6zhGhx{ zKUV2|5IerJ`w_n`5k?}nz?`AT7fD;$f3?5l976t437+H^z$8TeStyYxZt_jm?bG-e zeD^N#9UiDTP+nl8b3}!@YsM?sNGCyBx&eXB^ZS51)JG-D7493Tk}wEbI=Tz*?_UK# z&$`ECpnMk)c5oPX>dt|(T&{V0*;`E8#yLVr> zFa^e7!O{dJ^X1FWFaVgEL31?vT#e6ulAn(XC=aRv{>gRcjJS@SoDV~zZ83DRtMWtm zOH}6&rc(4v+3%;MRDvReA=rJ^hAJWgBJ=_De^&$BdN)(_`ms}ax!KEMg4O@@FAf&do7MUlp;w5A9<<}PTsM9(= zohBM^D5yFQ!z-@3xjccOj<`LF9P9IU-o|x;TqXgW)qlz*)L!VMJC(hS54JE-oJ#f`IB^28Fi$2YCxOu0Iy&Mt1@aN@cJC&ejo1VM+;Q(a6e#2ieEQux zcOct@R6>=6BxiQ|^tj7w6jngsmVXNCYj@ST$E$sN3|#{G3)xaaLIU9|?q8Mb>h9j4 zAnw2eg#$(I*-G!1MMWL`{nt_C&VDM)>2xq_I#>iM8FF@tg8P&7^jcV&!O#l`keYP1 zWas7zA3C%GYzvyeO=07>|7tfxGq`c2Xdna{fU^fLLv;OERgb{D^6lHruNsTWD)HyN z&>sLF2`)#+ywFgT&h^O$F9ih!vHLDbmEzPuoVa`Yw%bHw3``v`tiZnz5kU)$di#(v}Q;0t=FW!0ZfV;Od#uEGv^b&6%dnjPYn5wGP|C$Pj zu@c=nU>6!S0he-eE`TpZPQGvfI@-$G8Wi==u&`qfkJ6n?`+E5ABUBxF1_o^(K79SX z!pO)7wuPFJaq0K(M4ug;GU*_KzkK-umQUI1XWEk|H}!?6$jPDSgL3iu=TFbk2aO^k zB7*wd7l+Ez^Hp*2RYYGGmm=`pu>UN6)aW2@ngR>;8)Q^B^rr4^s8iV}dT{n}mlCH- z>RVc9W(kwE?DAzUWkb+&UPzrVGz{R6KvIkQcj2?{-MbeUNYX2H?BZqFHKZ&UV~CvE z`tns!d3XiGLft8JNFXps7U#u8o;RNEjTJL+yj=)Ye1_1m{6 z;^89TlB=KQ<+Xr(#?}`W_FDOMj>u~UXlJCCb>O!E5G^f7Rz;;9*kRpkefJK0Dy(Xq z4^hmL5F`&C)M8Qu;WaTkOV@sk3H0ye)Rd~v5`F$-M5*c7PB2&T z^zIOuGaxNonVIBmzVwu21lY8GeElkmKYS5bP__4|4Q&V|+JS;fk6|`2{8o6)R8pA; zX@M}w{5SUj8=1>A~oj%=i{y7N&rHr_^IA|># zLJsc`63_mO0DfI;S!D01n>RZ+j+{G}rN&PnOwZ0LHs6Gj(a^IlSN<>>-qG_^o?1lfhL<(MV@# z#er4_@Cbm?*M}Y;Jv}{eFkCU&d275XsiUa9Uq2iX^kM4<0<|bfyfi zOG-`##Nl>IOLJmZNMVfQYz#INgNmi|cX-;_4U@){QiH7tq8>!Ru^gx%>Fxk)x3x2p z?%#K4RPmFf4tnuVr$8bFKL#Hex|+beyAhOU(Ua8Ksm{dJkwHZp>bm@M99$E$Mc+Rk zO^GC+$Nt-lFoG_^h*eH=gpH6)hVmTvDl_p!o-vN%e;sS+$l{8DVnn|NCt{t;S$n8z zC`6&0-R{KA;Tjr>W+Yl}kd{X!}&>Eo3w$dfZ zPRz&u3n)f2YS*qE7`RAIfM|kyN-OIC-N&2O=>WIb(JYL}$ST87xUV3VNA^LRZE?r9 zcis$b9u8VsRDcNewo(dok(wnhUTE%nvS%^y{3#}Zk0 z!N2+%lsq==?ekGcI2ac%s{jH5fx3vvHZE(n_1<)Qo0pHZgSlWZlAhVHiQ@kkK6F@es)?PZ|{zq_*UFW zRKvIV`Sa3Au4^u&fofSsSu;b}R0!RmAw2qU#@G#riXJvHdem}rb72MsQ5WO=T?nSs z^sAmQg2C$WKKbB2DXGqP?~W=|0mc_(h4MAN`zjcyR)dsnA)eZPK{`nzJ-%*SS1(>y z@Nl*AeN_FATp_*kC+K#u@B5pek)C$QODQ>rHS$YuzB%F^z6GA=mF0;zKn-QmK*^!_(AC|lk(F?~XhIK8kYif9j{16c|?+~fPeAMm+;7Ta@ZpZE!i$dp0t zj#F8sCcv5hG>B^K@o~K!KeD1b5rZ*M^mzgmOiWBvR8$b1KPd>Y8^CQf3O9>CFL zla!KzFG9(49!f#2!sE_hzh50*c~76xQB%wNZ>|Hiex8`HiK03Py#oDP=+8pWnW&1& zNN=yKkWe^n)!RE#cI^WCIAO~`@7a2BHqu@x!* z)yQYpGPrEaD?IiSy;>d~9+*<>hE&)SLD<5{@%HUoz>K0;IxZa`fXlMxc2`z=y1QXf z+$Sa`BPYj1OM9mJh9BhrUiBDGXn40k#KBww+cyOj6?C(IwzJN9wCuv#1>Z7IGIBF& z=~3_5eB4R%**G%CFoZusKx3xb?Tm~GoN_1{kCKw$wPJ?xWJK+mI8oh>Y_ZqY)Fj59 zQHbY|y?sCD3jFl)g=-5W0wx;LAIKhrs5j1|Dn#PlAzm7F4_K0Z}cR4k5lFhpXu!y=bDbUwx`K9s*oI1Syk~kF=}gR0dI5p9qbDs z+BA*=|NcUpxO(+E{9|+d&*7akQmddr9A4T zKR35VL4bgj)kc?Q{or5)26N!RHRN}=%-S8xS@RmIKP>q-9gCEk;Uv2>1M0D+g+sp^>aOtGb678I}guLPfy4xLA!9B88Q!wn&Yr)M@AA| z!1kHLAwY6r!y$diA(+^=aEVGtw2zG372ZxYx8flmH)<{sZ{?er$O0My+`ma5?GPNEnauj*6vbP9)|yY z)`dSSa5&_C0LChSeoO3dY-fCxC%Tg_a?qaS7yN-1*?lI@sOjj|;HLf0TF14W%!94> z<3}6bd*_4jR$(lfvhoJ3dFW+vx^(GeEh_-xND&|~M36BUH5Gl9#D;7SKC+NYhXjhC z;o%|Md)1N4>txzz093@KI@@AoFXNx&J222uxbv`MZ@`lazz;_U(O(&BA!ma=k~tw` zaW9?vh`zzW(Q1Dyb8{a^%qXiT%Eb^3&`Rbak7fCYd|gU`fvN%gffz>JyMVsfq9RGmrX*zr%^k)Oc6nML5~$~3y&;;zUci-; zRl_dd53q*PLFVAW;cEZU!9i|VDkDif*hKaIJ^mmtzvcv>F!mH2D`!jWk6gdL;w453 zNuJouFDc2a9*;>5IQ?Xdk{o12=Tr zX*X}U2Hx1waFOC>=)6vjah}NQxqX|RD@GPM3J#4)4#tyXg6<$8u#w@Kfd#f5?l-LQ zAO24Ux;fo8a^po~27z`u>4sqK^aK*_ikLE+5lbF8;dF=uiRiCk=u>aC3**r*3#L{oTJ3<#h2eV4P7 z69oZ#^=K0?jl80w9dmzXpa)x6XehQlFIuNj6{8Ua)eo-3CGs^QFOAAGukg;@yKlGW z3%9}_a%JRA8R9d#O*Yp?w@fr5sbw6A`HK)hwE5R5FlQaYymfqB!_u2I$(I4*H#If_ zv2t;8!e-j^kN6HDaXU<`X}h{^nP}05f<@qBVOe-py^)`tO*zZ?(Og4=lrdZpAJi8W zB;r!C3_Xm5fE3Bw8z_A8_;DtXWnx=1)6<~sta&Hw(Y67Dx5K4NQB4yFt7W7rwiO;n}NO|)<6*#qrOTXIleemk2y|!?kHq;v}UaRxD=uJ znQEtRfV*2_vYA*FxH_B_~? zViY0nll)G_45{(gC@3(1sycV+5;q42+TXR$QtJnD&4bj0_tfa!k>8O=gxR@v?D#V} zOw>Vdy*SjfYA{)LI5vox^Cg#?I2iTFsrHU;lhdZMmrVNNU*viF>_P!vZ z4CdzK|7-E;Ucj7wn3 z$VtbMn{a3Ih*GPsNRd~Hfv9eO9u5KI$m(=J95%fgVrLA9QcbfAp%7t>5_~Vp3y=;w zhqd78x|ogNtHhTYA0Ob({{(;-G4`CN9MFl~3}1lp`MxV}@gM^-!s4GlA7}4t!@#QI zNmI$pE=$sM1hx+lYxBbuI#LoCldy^kR3E6<9J6Z1du3%!yv1*83P1&?nvFdCzu@hyc_WSjYP6P;Hr;r|oawz$K?8bqPh~E7cwOG7$e81*8|=zra4O&y zifH5uKzrTVqsPO`TV^pIaXv)EFoSrOD}WZKLo!{aqNj*NOE05WA=)I4Vr#_m5}b?Q;+xxlft#3H`n3wI5u!C07n;g zTTOut^h(z%aOl#Y`A4>o;VUs`6~|ujLVfS>LWavJ(}2yv4J8-kdsK$(sTAS-%>j4l zjU;ft0F!aCu_`WOgx+H7jPmjUJfeYMc=|L9+HvrC-=_}MKE2P|*Xk?(c5a@ifgPekb0xUn$-7;Dxieu05T>V#*AvW1d zqj+4*Qi8@MkN_^iO@T4|-@`*%;gUz)m=d7I4@i|JcMhH!R9$*XAVy`~@ zc3{U~B)#;NlZ842$~gepUjR8wfvG)5AFZ(u@B|$DK%#H1PJ|^_ZN;@u9pH?HSOI+# z1wAwgxGiTS;jk|@Llq&$vG3f~>5*{M=O~{Y0L~61enLfwhtVL9!h5?FE3A7C9V+m@ zf02&if%zL2r%k!^zk4~NfPhg#z?pW42h%b$KmWBEh3;ipZeBD1OfGoAiHl2#?|9zR zgG$m#&tP55$T%#N2;Kpvc3kLT^Cs*KwN$=@2lA{Bc-ExctMgAE>|Rabk3#VK`X>&4`k|- z+4|||nZqM>s@#IXuHU<|MIN+%i2el+7?H9CJZz}^)8WB{=_dFB{x$D?Ao@_Z`tS%E zwCk0@VGVWx4~m%~k|3$znow(1R&E3wpA5U5ix40$|N7}uJ?{=k>@?(v{BR$;7Jk8# ziGoN~h@AZyyN{CW6fAj!lbL1P7N_J)ZV#=ss8t2ml1LHypo ze;;ipZ!lXZHDPeMjrE5hVr<;g+xvJ;0=I(YUJQKy!mvg$JA3*6qb;8UisT9=k` zD4)5d%@KAzzRCxzKDKj=3H*<0gWRSk{}I}`upQ)vws)}g_IPQwhI6q?$KOM4R{X z=WO#1@yAQA3==`u=7vw_pBu)c;d|gZfnrE(UIBE=N>vE1O*104(xL)}1`jV0wkswb zoB}S$<9Dj`T;IYth1MWk@D)L;U?DGl{+tei2qWVo8OJVRe?QP~SZcs>T>rV5fBka( z*Wv&V^y@fCTc^*Qd1q6%nH!{?0nG~SeRx1a0gM;2J_ttilxRegws}hq4jmV&N1UFO zhsm(NH^%a=4SSCIp@0&2oX#r0{u+-00NOyCC{c%Z%r-xD${k1rrxDT%wk7rso_3_F zs*0zXj4YC|^C3n+gF#J$VikIpP+|*;kzKoXf$)%(l#GAr*%eSX{st2Q5TewU(LF;> zT8j+_eh!;THX50bsk^uI1jW79{qToFBoG#E#?D8~Z*RX)OzcO*+8eU$g{KI2u(HGL zIXFb*7pMYYen&p1vC6+EcA3!ATfh$bqk2m`g&meuK~KaWo{|Ix7i$4aWZ&hb`%-pF%E~rR zU*k@3o9k}`PK1$$*NI@9?d|PIw0MGpfdOK(ATu?Fiq%DP68a2F^4sKOWMCkgM?ddi zsZ(Wx`W_eg6DB56PlOSr!<(b2zp-|WKk5HL)n z+|{vKGCUH2m9+%wH15LYECWPph+wA?){Kn0AV~rNAOu0Dg6x%(lLPy~&&6%G6Q~}v zeSivc$@vKagE285p$oxb(rSgFFdJ z61!6HjE}>`i{%g|F|~Nw*|({wSMZF1uXt>b@;M7#4(MgYKONK8=TY>S0~$BM6Re^| zL#cy^iw+|#wm!ZY5E#m2qL4w*J2?w&{WRTJIID6)Vf$8APJw}7dAa7sRrt{J%1)d) zgI0^{V1{Arc{asqd*%_lRtY>9h@5Z&Vcqq_?_gWNpq8L3xNX}VRO4?+c!gQ_NJu!> zg)v|Y;rqaw;8AL~Ug|ss1i;oLVsG|C%F2~s^hVJS1bp6GklrjI!v$^o5_DZWm5+p| zQ}o+^oQ>~HuqgvG_WohwqCRZRCz6EXec4V7GyQh*GE1%oYTGM zHuKRqB!v_eKdu77Uu|-u057L~7I$*eHxhg2o|&Z=6vWnA4-F5aMKJ!(orX!*bKkk% zxdgRNA|K9=R*$x|F%Z(y(~IE*xqqKC^5Qr^J_!M3{kH|;00OYec9Qq8^Yz}!<3V8H zDn;0D!X^VfatD2wppp6v6FntSUWe}z(*v6&nvY7BsEPgHSe7x?b}RsRu&+)tu|d-8 z(Be?;O@IDONUFVDq=8`9kN1YvbVunTsvJvK^v_u?rZp_&4` zN?y#vUHZpB-1WiWhlg;1_}W-~sqZ`HS_UbWo{=%^c@O9v)5y}AjOgNEyU&EJsx=B2qh23 zFgRsoWENqDSLPr)E!K+y6GkNvIpZG=0(*dnygg*LtN$0m0c|KNJA2Q_h^tm>~?qkI;HzQX>rgGXN8aFb#+svrJ_mz z%w4vpR}I%gGP@Bd`h3JUmVKQ62WZ+N(ZUH;Es0w-fjB@DKpHQvZ2$ArC7tv-vL2sv z*Q4h4kQD8;jL?+YKViLs4%JjsyOLDb z800;d+^Gx3JYnXluPNlS=cS>xurGFf7;wXV9t*WZp)&4qLd$;MBF`Z~Idx*z9@1y>S zbFzWKyCx5N&Day&upXuQ-tiDVuo8CA%8vKZadcD1YUpU1R>R(w|4>>(! zLePc9l#8Es4>X3;07UL%vI{Xn?!$K6fY6Q`D4H3bs+Ebou~=G4iseJ{l=L(NVGzaK z!y9s<>>?mLzCc5Pf5RuPs*!v1^z`J?SRN9h4SzlX>z5Xt_N`NHQ@P)F#$L0LS~Gsi zmj*W{vWGcfw`{3=Sg?ql3BN_WH|%!E3b1zR#Nx|A6vj$|n@pOdYfde9*eOfLcsY~| zZRG@rK&qL5z+v{@GJ9@3I~SNuTz~+>K@(AbqUO-#XRb=)RIO8ge0+`!HQh-sg;W;& zo=Qyoa8)*GJ==s5;YwqW3Gnc1I#yY5H_$HLzAYF{a2{>=HF!#$W@TR_ND5=a6`;ts3!7vNlTU0gW$ z`&?*7+$}HlgLQ46xPMuEAAQd7Hf0od>>;S&q?{K3*Hr ztr~}4|5Nhoy5?V{xug3}rwHp-T(L-Uva-yzc^z@lH+bJX$FFVnvD+uMEh>EUp6rol zAt53|x-+k6Qg@rx%TZa^!5OeX`pl}mYANL?8UuNN$^b>?)x(jh0 znokEzZgpu$%2g6MF%gytJR^vp86#S?Am@p!SSTrnD89u+ASjlFI8G zzu9x=cC*KHeIsCKx%v07ZQC!%L3PsNs|6Brg3Xq|^xSDVR!zAMITtQKb9FrU*&h0Y zgsA+^9c61pTKZi6(V5U0HjsU=u)Ibq#pxzyW z&-XKkj6aha{=|j+S!A_l&FGJBV83n1D2Ejx+mH5Rw)yHq;1k`?X4vQy*k`gRqK7Do zypd^{X!=^2hvs}5r~&hzH2+=MKW?P!sdY`(DT`qvxEqcI?z3dYmu#-{#R&q?+hOIV zw{Sfmt~=J6S$53me`-g!S$ROkf9C zDe9V=t8b_s%-MJHr1Mwp1Z52kLdMnHf6NiX0Yu*ZAiwX~N{tAQxNFVd^=FA6`dOMA zbZ%N#!6_EsL{G%pFV2MliR~XIwqeau{YO*ES0FZqfqd@VI8g)7W}@A@FT!R{un`wQ zs`*i~aH)^Ke+axz>ufa7YiZDRr7kRWeeLifZcw<;ZMCtHjG3I~q6~S8LQ>iE*#L|* zRNHhmW!wwVtAe z=4OzhjJa;Bi53h@YhE`kymb+)CO8=gA4^G`%^bD|!6ulnv>F#JJ5) zd+(1|cx^f|h4d@vCLg(xH)3DEGjYHH5S-9Th(s6yydQbfs{4Gu5gDUNg~4Z<&;HR{ zTrNiZpPgNnQ9Eark8d217e(b(OS6 zJSh3aFG9~2CZI@!i0MmXm2`c}D>*+rYXMpR19OJvhXt#R1O|Dl5w zIqXhUeo0A|gKpx%d8^`Oo}brTFkL*-MYV^X!ne>VF#{%t4l$@dTJ?5t_vSi?@ZVqC z)NU@cPg%#pwfgwsWM^HSMB>LcZ)DnDeY+}4!A!UqSH47%t&00ww58+@EA^S4o{%a( zahgsWp9|&!*$3wP)ST z1S{?j^SoMiSq6K1Yl*yx6rd->SB?%`qh6$Z2i_MKty#MklzjnZ6eTI@E_e43h`v;} zlGY?t0#_2ZNVTNd3l{XA>FVaDyvZTBgQ%e@hk$;%;e8^i>Ei4CvI6f+Fq4g*Ef~Um zI+yu9bV?aSZ_(zgEcG3Z0fB*t=}GfDT}^xT>?tY-aHsAisld^t;onmi_nBq9*Y+;v zp*kL{jCJWcu|PT_UAjM2VZKO2NNR0u<>A2}gx&N=A@1mrBc$xzZ~r_M>vOrb_6c2 z4YL<19j%R1BF##3-OQC&W7YKXT zw~LZ)eLHKU`)AkrRyG@M7(HYY^fvIh*sf!`X%1NPz36Q{#AWCECncmg9>D`_V!08>X~v`?_nY zq&Spm3V>ZvUlSq@jNIawBOm$4X55J~7w56wYkUd>b>8AU{VDV{CsG9|@7V|=!+qYo zcP%Z|moLXZJ>RkV?Y&_l{JzVM543K{f(6fB0quorslEGZu99cP|8N27>cl3$yyYsJ z(Tnu}SB~mAJ^T(kxu5(i!fI-q`9l3omCeC)bz&;K;e7X&9U@T1L%%E*SwYYZRGDQb z4?c9r4JykC_$Hh@GhJQ9M0>}tb-W**D?`Jr=YU0IOHcl}*C@6M?1J(oQhOF_Tm%r( zzyC6f{`MJLEd=F3F$H#Wd3%A2F8=oK8+Ill%zopbmB~>SG-TL*%kGMsq&1V|Zsv0c- z%)xy)^ucGUtNqBb1%l;J{m$q*Up-yj_m9tBgBUK#IdS45C>CT!*n%ww=!{B<5K=2o zigwJ&pyz{s=ll!nP8=WD62-m}691%X+9_B!t+!E#PaQ-h#9@_>1!1)hehXs^k2Qc9 z0E!W5`;S|xA+nl1dkg~uiu+!8pg**ja94=4bcw zLE3@2W@07|3!*YyVimS%A-G`GsH>|7?NK&ATwMH}aLhhrOVLE4kX~>;D7XBon|>54 zR8L3e1yTTh7_grrsRIZl?q##!rASAgG;!NDT>nYHSAh<%S_R<`@_6ike{;5uZICJj zL*%~%jUth```|$~7PL4X5iG#uGdclic9|@!BuhcGJ|awYht<*`EOtnxS(@U-BKf`) z2DlS|$zkO0)JTE8A&zK^)p4qv`NN;cUpY3o+-%MHX; zwWM#KKkpv-+t}j@GLhvEV#UyP5LL^5yG|HnUV~`wQRH7wy-5z~_hGkV<;Yq&Y5vHJJ~MiAI1YQlHlCG6tAKX_XWNe z&@ntBc-AyRDFDdHXmWx7qI*g6tZqqW9fR{hUx8}W_I+r29gCjk9h-vOl{4=Cq{Kmz z*0>(P;UXx2=+iOb{{3$cb1ntUAJ~TNi`$69&ubPTQ3JVAe2^dAzc00MQ_d^%@#Ed} zGsM(=P5N99FEa8|-S65$d^GkrJM{U#e;8yg+4h!1}s zf5XsFEy*sQU_@2Q2M86WHkw%a*)+BxBL|yNfu}h{zX({m)SPUDi{lYCb{%@tODgKq z+rNh&2_^m#USPw(>09;;N|fK<`Hz6pXU>#({*sX2dgj$&9&PC^j_vFA#7RDl>v?G$ z5&YF}Qd9RNtgr62gThfg(u#9=D{#vASc+$lkV&w)^Gn8XWb4&lJW2kcX~)d%i;z%) zOk&W0xJqfD$_}dpMHQ7%n27=|+{hYbfB#bL!1>04uNF}j-z7f$oh8a&{`zaTUH+<) z`Cd*GYb-3em^>i21+y{txpbP_{=_sk<+;3XT3EgGjC_^*Xd_XT{WuS#4My<$$& ze*ODT4j4=E$-d%4o}1PgYT-ZHllJkwQhpU}NtE$Z)AcGs!`XhH7x)DtfjV_6P?dHl zA{^|v__OlDh%nf9o+!| z5jMw}GiO*e#H}-D(kr}MKOd8cYxfJ^su*-FM*FYv?;V_+s6#(fd^Q;G%A*|QTiiT>eQMoeY zlDsqx#?`A^c1ug2!M(HfRzP3P>!v<$PPo|~ zzB>VQj7$CNFUfo0P8IWq?tRWuwkdOf8HyAsy^dldTH8#+nP$l=C-F$FoD0<8zblF( ztE&ng8w{t~q*I04wa}Q#9{Ki&WTIeXZW;Pn7Y|9*on^5~r2afvgn<~kryk#wrb(or zkdE7(xpSx8;kz|k)nB%>$d0*HSGRQZ`rL#hfsBkw8xGlmBhRoIK|P22CUpDS+vn1z zuU>tIwk2<6hvSFWrwu~`AN5;jV{7{d?Cq}3Uq`y?%-Px?ZuC+AAv1`5aBQLk{l4DI zyl9(aA)R?GCdy-{@gHwrzKlBgkIp*p*9BG=3OK!xKw_0|5UEUqMDUYcGkzkBkM64N z^`1FqtPwi-dk~ocYx{lZ>G-_-tmnfO>xf1&?&mk#v#s~$?I-BNcbqrxPblN_PAq$I zIU%URM^*L{X+GF9u|>w|JN>gM1QA+3$2A62kSx<671U?osq}<9EtO96NK7Zk#lZ+` ziNL~jk_Q)f7d)g0LI(k(bC94WKRaQ{7U#o<4;`u;G9Jb+)k&jI4}5ko>8Hsy<@K&< zz1(}M8qY#R*+m3q%MU)EK3k8236oN$9T*|cw)!bewJ})GL&0l>kyWqr-Nc7;iSKzt zIHhX<(aHD2&2pmutLYC&b4m9}8Gd~J?1|6){6gpZ3ftTotc(`Q;-Td-YZkm}<|Z99 z?C77x9=y(+s3S+-z-tWp(JmG_HaZb#TaPl4M?ovb>;9!2`K@e7$T{fJ(58C)x+CqR z_l4Et@}*(yXdV*D%^PpE5*_@`E4K8QZ#*}|#s|%2Vxpt3?*S)`0imjW`XJIvu4<%b zR@uu?TF$elYHu=THyVKJ-tVG3RX1VdLL_B|hUc0!UjeE8K5Wwpk{_CJk)x4xfs+gk zlmLTn+&In0Pc1{6kbc^IMatmM?4XE_Pxfj_Ltg*6T%jlRblamP*$Bie!rGYD7MMCm z_w4kK{x2|2Y7MV_tdvnPD)5;FUpRiB@p5}+)j3X^hRUjxI-aM1h+kf66pI;D99t7k z%(}-DGA5nh@Xa97>dhw?;)+OXpm-34}>D{jMWvW;w_D$OXs@6sCP~szMmR zh;zr;5&BW~#djq`&)i!Wa0*u;3bVie?o%AZhUQ3^_I!9o#VSONG{4u9>4w|`A3(4T z*z{+{#r`8nM2^od`Aka~j0D|dR`rz^v|_Jx?zR zq<)9BAkdAvLaS7%bn@1Yrw>U5d_+=V8-f0W#~HiXvk}d46-gC&y9^HHXP~)|ms(BB zj(Sx`%1nbnW{1%S@42zlMH!DQuzpg4b*olIUbH4R!iQF zpU=Xj4*E5W0bH{d`JSpWU#9d&PgX3sfY9y_Z$CKtV*mS;fUB{Emf6BzMloPv>rPi$ z4XVHQQ1PIGrJWtD?=!{luB32nrVu-J5!6#)U*OP6}Q zh3$m6pQp?>>)Wg`V#rYc{y)*z(}rn0+xtQW>HMVNrdkSVc)Dndg?7i(16#Jq43vkl z3&J#Q+B=q8=c5z}zYwyiQ3!O{;0gQn+_AH#%Q4UFH(jNecG;;@BQ&lg+cjnQP55-s!n6F0v4_;G}7S*!{{;_;s0WoqD8%JM{l|>&g#X%hvbQ<6YF>oA$C=ZC<(ho0!=^^9tjq74%<3ZHG&K1j@%VL_*Q z==9yb{{H&Qm$)|dtY-`gB_n3d;15xERxNc;-M6n3i0>n7m9!u5fb-wYL3KyD*qIIA zmcb|E-$k(KZQa(aUtbpb<;sm4A87AWBXbV(uCd4SuhDeO{_4?FQbbE*zeOm?%XJF= z@m_VK$dm9NzXn|oh*HxsTm##?vj&~_etk$?d(=QDy(KLAQ`Wzc}=;=&f-?kzk}7mMLGWG zpHMNz9E;HJJZ!1#psUPpg!*;h<@QoY5S$r-lum-s|Ia^h2t$E7Z9%ulv!{k4e$d26 z|1X`VW9{-W@4H-6!w=BG4=$On^wJ~t+sZBag_SNem4R)=fweu?^38$xuI-_MqwacmNVZy!fC;dn7iqu_JUOr>nqQZj=d&H>$h5Sl?e|J`{KW(ld3(r3qqbt=K$k!zdG-L-Y0LFLL$NX=qJG{B&2o5TE*nOANAsO;y5z# zN1K$-f`L6`j6dwGGaxwxFkZuT+wbWFXIdcv%b_R~;(mT2!`p^_s-SA5N zzzeBLqOl4ksHsK%oEW9r5s=A>(kD@Cve_)kL)%!saoTEBkr)e2El*ZVKX(Wkaxy9&-sv$_xT zp79;nAKeVwG&dK~Ryk|aaLl8Z_LI5CtrkDcHKdqf@Do9q!rh}v{C7~kUZBEc&k&7R zjwRj|;uI7fzs87&dDSDzIuI(wI7?>qFWvV&q;Lrp{KtOr3h7#gtqZY+TN=<-@Pg znCyp<59zzmymGDiDS2{)(!hb6h||d9++XjpjOdC#`sJI*^er_sPputPKU90crf&i} z9nW+5i~TRbx&f8qs1rJia8pIz{{H7NU?trTr)6~iSwb@DLgS~l>(`wmt${0w1D}I) zgyRe9@he7W(ZdyErJ@qHZq>N$L0-t{jI`8gn<|m{tEjMORt5z05=c(JXk=k(dY^H; z!!r*^8AQr({u~rz`Ys${oLMY1L0Cgsr`Pq3jVJMZI4~&0#YEKhoVJ4&7S{BRtNQfy z>zdW8lc2WWy&Lt*{%3o8-Qy9e>USSMmJ>Yw2Hy5Sg^sybQ;?bR=VSK3C&Uw`sK}p> z7mO8|z_JSuJil?iJs&H|F~*{com1#;XrXzlF$lO66FF=iZ@1jqPuDQuy>JMTjB7V1F){J)33`YJU+{=65hon9yABMAFG74G#Xi`MZdkl&N`;KT<32 zZNbnPREQu+4Y|5xKBb1htH-8;N@u&Xr-F6%Y|%f3A`x}9sP*5c6X5T$+i-yGRa19t z`=NpYVF+x{l?|&_jl{nmy8tv_;Mu6m<1;79q}LIvy2-^tn*I7cd-`zFOMvL{P?fa zr(LwL-$rn@&wTY_PD;~Hjwk(BuH4q`z-2rMkui40tlQ+V!9?Ilgg(%q)xy`chICLw z5=n=u)VMT7QY1`A)U7yt0pm!3);@EbzxYho!tLliLME(Ck~5AOj*7O29Iw4H#U5^7 zTr`b@e_YID1V@!|Fv7QJQ9OB-gKpNrjJAjNJLcHFof6?KO(&ud()F{u94f zII3>1h7hAN=`+LzY$0C06o}&l;rd5a4j>` z-%l?84{_iI7*`>dm<~inS|gUB>n4A3yP|l$Ctwk8jubEH>azw6n(&Jkx*>$wPy?uv zF0vXoNYwhYIL3=7_js{H96l|)3lPRH!vCS z<4}dT)oa%#Z`-Chb>0+!6E^geM^X8nD6Z$6@|rkadUfJHaJ5U6+f)?{#Z_3LFx9KD)exxVyr*BcyV_?dte?&K z4o8WB-INfMWp?$fEqkP0;8rr5UnA!nsN z5|Vc>A44Zt8MItcxZr=uNnJAkBv?ETlyjVB6Udp%qjbf5Pw|B(WVXHg_4C~+9+27b z*H;;mH{}tr*yFeK(iJyO8XY{9`ii~EJ=XQ|^zdLlR&<3oT`xj7*`9D9NYEVnb$2T; z{SM~)`h5hg3QEph1;-5Q1acD&MlNf|mUH@5v&DG<0#fk%1Bkr$A+|6y!g}}^3>#LF zI8Y&OCY>liX+E=OS2qR$E2H|e(wbiq><8z}v~56l59?HNKj?v6&bKcaAXprw6`%I9 zng#e-!|}qo|KS4s^J`Dwr7Wr@+7GAad|hb6ugttg26=%M3xxtJC3Phw{CtcRds(OQ zjKUwIX6~ynYvxRNjlY3cYXJ1AQ)QE?Ia?II_0EY;AyLq*k*F%pB3t66(ivdDpJ+3A zH2DKhTNuN)cP~RstgR!Hlcz&Wxi@go!P=I4ZE$2@3$ug3SNKqKgJsj^gI*Pm(-v3h^Owa`eN>A%iZ_{u6m93WT87*XiRW#mg@FD2z#>U^O?- zs%ivyAQ4nIzL`*5_HEFSsdU9o8zN=O1u1vFYE6rX4wKLXm}z7xCha#T+LTH8M4g zC#H77KPRo^xpROge?IHEfwQdgf(PdpWfgjXO6eJ`-oM1U6Ce{_l}d8}VVezyWX_z} zJb`zSlf&!Wa6IxTqMicx{T%?TPtUJfM7PGLdpUO@v&Bk1HbB!tJ$4K;7@c8E`G}k_YtOMq^)*?#KHS2;N^TcbXup*V(7}R1q0OCVaWh9Bp9l4 z&7ggt^CA(jAV~n!SDKR~A(N!93HTeZ>zf>d7A*-`^qSK_A+YH~D?~>Ys%KnP#mi5m z>sSiXS1W46Pcfk>)^Oe0we>A)IEy2LXpzw$1NWxK+_z7kid(Gyv3tNn5#s@G0xGcq zz~|$h)!eVIFCg!Mnjw9%2400v0lnta6PWYD0C@Z#vLpIS%x@07=e!6R3}+Czv#?J8 z{+l<3AjK}<`VocA%f4groub`~XceO93zcy7fHMgM5>_2#fb47ly^hs`um=kX#!9GH z8QxY%Wgz0<4O!RzFc}*aU{wi;sN6ktO}J5-wQ=7{(QnZH;S@zL#$!4XCh^Bks1?ge zZuQ2<$q3lIb^Yk6mPFAY&>s8UVit!ybCq39lX)Ef^=;v6Se+GG zfP4U_=y7I&BeL;Z=ek6fr5tECDiqqVYNn*f#D&JbT_44NFsclXM3F%r`fDmzUKdYl zh5dY?{SO*QB9a&%zl-Le)eQPYt-VCkTG?UjDtAM2^Zs(eFeK_sHUs1cOaGyba?=S5 zWEg{rlrq9~hRNCpSb~azi<7hSzi;1S-a~cAJQX@maT~=BU%WVR!h`|eSJ1IXQ^bCy z3GQyo7!b9mXCPT|F#qCUWWYdV^CMoP{>G|(PtS!E@-2n* zuByN;1WuPogph&h3&K!@Nw?m}tkFx|m@7-D07tc7 zHigz8EQC<344F~@WcZBlfKx>u2N!||RaH|6fxydzo1n6*n!UEyHE{~0J*cujd>34^ zr<@$w7SIl#Hh@D`yhs!?8N)>3gW|lCEh+1nJV2d(2W?s!T6k`j|D4zXzX3Y9n_GXL zD)+^Q5X-LOFXtWWpmu@73n*>LeB=3Ya!J)Ue^?PBn>%2$AzA`4Dj? zpMHLE;}SnV{&VUHGu7;}_E&pI{hp20wN@JZB8@@vSaiY>CAVWI5^F|5S3`bDWp4hl zkKzO;J-}8YP9=ECR2MWaP@|F8w6cD_Rl;Xs9&#yK=WA}I*xT$ zuabNPgojU>bqUus;r3~+Lk&G!P!K7xjm^cA@cS?#QJ&!Lq6BRMy*&?&$UpB$5@H@Y z*Bom6W{TYPUZVWs?*|zB+A4ZL=wr6kv$-J21~{!caXrkP>Xeb8;#gT zkNScSW11ONQ=Qm{XiSdMoE+BDOFR<)~Hw#!Z`4E#+1iJ5kr>)~3@;R&(HdVquhGWfux6~TsH_m$L(o4iR`w60}z}|oz6{-~+v*o?S7hK%1wy8D^J|c;} zG4`bts_464tX+9IH7hF=EStW_XUk+xxTNaJ#cq<;ijp`umHx9ZAmBz>_|dRC5I$Li zz>n-$GQi=Xkcm&H2qQOjmXC9dok+G$(m~nCpL~K$b`z_JpzLMTp0s67HD)*-6zo$7 zB~cY$@53e+AXIh~)PGv&m;Y7?h3bsi!CK5rpU(O%lB=g_7q?Q*Rx&Eh%3#M&RD2vN zJS1VD8hh)_vgS=(8ITQaptEJ&T^G)u$E_d~XygA&CKXAAQK8VWV!Nz~YfL+K3`epm8~7G6zf8fPOkcneM5JYW%F?gEt`ngpd6 z(jrn?#<~fDyO4nsu+PHbgIkSTxeS89B)pOJz?oObj%A(d+HwGZMYf0{M)JnFShat6E63>%P zL4wVu{zE|3`Cc>w@Z{h#)IJ_)-LT?jcKFY_r%wkmJS4~rGV!4BHf>|$ZO(_UJ)WSN zu^*7>7ospV?Mt`xf4G!rY1I)l4&E(-&UK(UT@ zPPSI>$A%P;83vqd1d=fm>_YFZz+R?$KdOp1a1E>dX#T7q4!{IO%@#yDak1^udQ1#1|?LV#zz|i zGHh1z{1oC)pKo|#7!Z?r+r#8=~>jyLttE zS4mxMFh07sNjm)U@W}t9q_J8MqRJJ`J608ITwzcGHuVJSXM#vKS|6Ck$QS2_$#yMb^qG-HDOPC}RBq@8) z_%%_TnKpYI1s^My_g4@qGL$|6OmfsHDmeHbBfjgp#5$AWCsiYoR_h35?8(?Y%%sBTnS;wra&S{HN+!xKt0vezLS<~?wjH0=mvz~Q-C>x;_ERO za#^#(OG?@y>0I^;!Uz+CE8vY6ruu5pUnJx?(?}pj!G>VH6&H80(R=88owNPI|5Y|x zIpHTI5b{IPH}EC~TTA`xAd24o1ZoMvpD0E}!2bR-`S3MfOIa>o^$8XlHk^jfEo~>vYd84$rnOC77y}8 z`i}>bIf1&;&X_W8h*$K2eI_<-*qz$6+AChNW=1k$s4|X{urXs!WBmq94*LX&y5xKI zeD~@8kDURMUGZ<`-@Db*l%AQWoQKKq(_W%oW0vo1ZN|Abwx^n$qM~BCib+467aP7W zJ#ee%@CNtnPgzc{*u>K7Hyyab72|cb`DYKF`J0z72d|rfL0?jZ_W_H!%f7Z|ugHY% zDS{Wg!+XPI{o%u5V?f30pS4Q~8tP%MVmr`-%G< zMG>DBFP$+#1ogiZpO;$+G_91}Qg=+eIL9wxxy+||R0 z^h0UZe?GI}p3F=zJ~DK+7JL6a%Z z#yhOtYh@GV;E~#M{ECU_GCd`%;Sx;ziB7)&D~V~6CJVRpoA7o6D5FTU^7*BSYi5#p z1-tjK*^pU|k(8Irli|(?TrPXaY$0!w$PK+rCNCP4SqZaKTx4T!|79Bnj;Ct&t|M5A zz05n4ym?yQYFEn<4)7-V-Ty2Fx;j!L{tT2wLc}n?%YgukJw+m~yB^sO&deCR$;(}= z=I7Rr!Xz29_5aTA9+Bi^#yJ@qYuEjf80|WF-#U)U`7|hW4f8u*PYlNBw!X^ka_X~) z>_$)@_!(q{qH=C*Lz14SIBS82@m*hBJ1EIh(wYQS+b3nZq%}-vj_md-oQ6VXe)X17 zOQOI@yBWL+vxS@>6PaC3dTL31cCFJH`c*Gd;La*O3+S^-?Q_AuF;$Hr14e%ScT6O@ zRU3eF5$@sFCmbYiwZF!9cI^CheXO`~!cE)GGOf~ej{$QuyUo%ZBtk>Cu zC{pQlIM_~{^kKUd$=iP%QqgAXTVk6}jTMPLPF0byo-`?s4meVAGA*q7TMsfj_hukt z4&nL;!za++v7+!dhfNFhuQ4U6s*%zQCrwkcz+W>!zDPJvyq(}LBe?}T48~)-mu^>R zy(r)EI(%uX@#^2w-R9the~z%Y>{B3>@mKk!@0%765c`>)^iv{m_MzMnw?@amt6P-Q zch1&vlZ!d8F`WOtdfZb$T1?_2^HR>s$jH#m7hG7PKh-OgX;%JG2Fu^TysnQk0)F6{ z+Z)d)Z_#Sa?PI)6cAm;W@q=j*zK=QXH?ENtpBEUCtZlLw*V!-wEUC|Rbu?RlK{_IA zx*NBre|UBgZ|=-8aowR`Un|H-f8RBz;jfk8;O~u$8e?xGUK6`E@zAsE6?ePm>-GJv+D*%1;Bl$QjEPQkIQZY1jM{XCANcJl;T3J2b@$%A11C;& z60LuX3itBT6lo0|YOj2g{tk7VS4ps~@)djYEw^InZqRwu-SsSDP%USW!4A0rliBVM z=Zyx=6P1(gxBas^I{%xx&%%XbqK6kZuBVg-S3`Ro_|tN$;B+#4?nwY)K!2W{`^ec) z^GuNS$j)v>05zpd@8YNGz6;FE%@e9;k({G{q5{5rUgxxXzrB*etqVrwKZthJRyZL1 zH@yL9Dr%b3CMsx=h;+wb$771rgKj{xKl6Qgm60m8uk#|k6qW279n{vY{YG+d7a%uz zUCSK-64n~6VHdq`Qu5c(g+1iItN&lMs3rXsh)mRbi(qKo)-~ROLRlozePH?G-8&9- zM_KhjH)JLa0Hc9w4d}St@l;=$yR?ORKo)-W&??=6zU$%MMWWri)m4 zsH^kG0#q2HHuxmfp^=lwGi-I0aeNqT90h?yS9zGB;nukaQ>A~dmX49wcuk;(zBP){ zmJxvS)4?^^Q;3N$gj@6W|8u9r3HW5Xdv}(VSq8?hB^X)S*(`8xoMlr3G!ax7k#fk_ znNkDwRUT5K9Hai6mlJaeMoBc+42pnDvvY5!Ym#^IyZ7%QWW}VX>TZ7)folc01WahG zs}#3g`9%w$aOKnSH0vY%lw-0r>b2os@*b(+iNfFzq^ByUR*T!=9?|(CX#_|)n~4NoD)sG0}PPjQb=N}4%mPVu>Oea}BOJz%-s#q9LC z4n|Uhg>|qZ0R6B+O|U6Ed$yC5kd{niJrFE%-#?Hdapv-9p+Sg5WODUKe`EznI;-wW zlGk+3y}5RyuI1=kUFWZ`$DTavvtPrdjWy5DuOB z61osXJytG7foYCPS?Bk82oz;QW3*)E5B>lQzI~d{nmbihxHk`nXP%ooUB9yt>LigU zsCx1z>JHKK3FL$-AvMX9;b8O-wf^{#2`RJi@P!K-QL6I5$RMKJ-)?{^98|JMmZXU` z$=>xj3ica}1G`$QdfVvWzxK=RyA)k3LgFySj9gq?M-rl85t2GN7mmQ*i5u6=l5J#7 z9GwNKyPU-izoS92mE%z$J9tnW0-P;^eti6R7)VWpQSV_TQzI?lq~Ltzlb|`jNsu1u1R#K{Pw$h+uc^Duy9E9#kdvv zdGB+!_MD`%J(thhF)5(>{t5S@pYA^-XKAcZRF|uLCKD}Mcx&tP zK|dZ?go^s;)=jSr?XDQEH}v(dgp!i%jW;Jg|5yT`MrV`ACwX?ykeM$;VxBn}Sjn&9 z^Z}2=OY_*VzxWyWh)37NHzhzV_+yq_%@EKgk;{DW2>rXsb30p8H%-BppTaZ9P1U9e zdKX)s{#U_bk5V|}H=jpz6S@XQRRB0gFxHLCcYCH-WPBgZl+6A6yBgyL!3)9Ts<9Cs zSVVkNe~05!BgHwX;JtkLp4X!);%W6#SbUhG$JM+f!^Ahn>uJBwQq-#w!v=oN?(Sfy z85U=RBBCRB-2ACisdA^{_6gtx(i;?@Bx6&IATTu(e5I}Dyty}( z>RCqS4a^`%zUw($qkA)QBGil7#uRc1H9zA<@Y4MHz@=_{_img)14{D9bFDkls z>sIfmisMXVelhjDvet+ZA8|4g#>zmXbkWCh9T_N}9T|NZ}YnHvx0)A|gaU zfk=Pc;s2t8J~CPJi#MUF@KTfTIxQWjKUr^;w9c3@fBzPR3$r9mCi*1`we+)6JQ~KE znK6hd-{|#00@glusjjYMNhvevp8mk0(*mxyi*)|mX?F!Bd)CV{PZ)yWg(N}(+1l!kqjS$xyRk<(JN4yjqEj}c?U== z22MZ7`2dwbA_>mBy$5=&;e}3}F$2~7Lhb@Y5a#m!{m&4;s>@&DPfkmSUhg(WTG_~@ z)R6N#61HfpO`pCAq?jHlzX_H(W*=Z+*Hf-xWmQoj_UMWG@zxLvHZ}B~i+NoNzHUx8 z#g&ld@dDAD(hO#r?nQXRH0=gYIAG;vM?;6liuLHuJ$tZ!f6ovXV-pjXbpg2bjwd)G z-3FmVzGS6^xRfyT4`4TI8%Yc`bwIMBIeCH6s8L_Qrs<)AVp7`!Wbz|-@4}1>*|33r zmZMjnea_E0{aLJrk?zpAz+(g_Q>)`G<$K(<#4$1ebwRPoQlz&J$L9yKj=|M!+Lg4c z&?O7A#ZH{KaqCtfSv*+uST~R9ldzfD1oapmDF!@z=%(Z8S5zd-N`hoThlD!-%+kAH z-&+!sW_sX&QH-mj?*U)ObIu&RkyyK=M1mw4LLDKSf2(Q>8i(^9IYjcjwpmRbg5UMF zZ47s5l^&w}?1^{}w7fdT#{UW>&ygdi|MRHaZY%Ngf4Bg$vXLqWcv^y08qhIa13JNQ zzJGC7@7^+MZCWYQP$&Z_t|4&oC)heo*Wc|2;9fpl0!0QNSU4-*$wVSs?=^(Whn@kE zg-=?q{=W%q;K$UDjH2eYQ`nP zN#HL)cr`DfQwdF(QKKlvIPUL8SQWQK){a{-mM*{W!H7N7g?=^juU>v4xhp6b8GP24 z0*`J526VZ(k;P4!u>R9n01%!W^fcnC;F!@Jq!irgWYcb!p{7sL`I^VcL5}KfSfR$F znwmI>awR3xH}zh#G@pgYwu5sI2F^kZn-sw+proY#XZKwpW~&d8?Y$sGPaUOIxEM^6 zZhMdom(3!FcY;B!>n{!K1A``I-|{tu{6Kr69#P@EdBaUC#_qvQ$=ifGsa+pH%b~q@ z;f^>APt(%V({Y+Bh{pwrBaN-AoTOh9UoGB)o8O47a4@;rho2Q<*SK*=EQxr+XY^>^8nEl&8?1UZhT=Ju z`7cNdYAbx(w)E)9*ioRsVFmGAwV*{{9bMMBI`YL?tA)^Rgg!LO5n|Bl)v!oW53}Y7 zhhX9SN#~AMp8yfP1jh{kDU|@aXqC_HrSMhh8=ae8P7rUDu zU<8->p8~rWD6h7pkNMveD8`vdqjBwK&&CgAFD7qr%CBes_6|o%g2_K#)++K#Szf|b zojF5^fAFAf!#aLxZ4~=RAug(jIojX>wW&|b%LPX+lP%*2Y_n$B{CFAPn@Kf@JXVsk z_$Wcj>?hAOmug6gx@xn$()RX{!_J6pCP*+C4c7rb;MJ#)-$px4I`!BD-M%dVpDcC$ zWG9B*9ZXl3-_0iHN~noJ!E5yqt4n#@hy*Bha$>d-F`Wz%e2UIqYDPXglqijdq%a^H zV(Dp8*>s0meX<_Ri3;3n7c@y4b)4rdo;fqK%?O;>fI%ZF=LhoyV11Bj&YpeHMW6f; z&N!zgpZkF`I7$@c{hwPG@g4y}Uw{Mk; za@~%?3}H+0nPtHK-eH%ooigHO*;rrXR?rA;ZD{m6dbo0x3tFrO#kiZi)yx{t^-`Jc(T zw85H^=KRK9Rpl_{B#C0f$x97ZcxiL&Z%nu8FR-q^{rCYn*7qdF;0$%(|LaXm>)o4< z7*FBicNJOV9(EJ^At#iIv{G!ZNs~b1^8W2xG^$3GiTNt1SK+mczE@&^}wbv_)Cm9P-{;Z55x|sS9WIu1$~?fl(`#*}R|Weegd5&CEf|Keu;a z03SvTOJ@SQn9#TK9rtC^_`&@Qk_V2WLpJ#PDE!M!Oib>FquUP*JOzs(`_`Z_q8_5H zznZSmgkF?=!0l*1`Ni`G%yD%EAFCX@^?l?wd{#-3fDB-AUAu99&ITCEjAolb{MEG( z#|UaYF^9=bx=~k$ZvV4->_m7FN5mb=t;G|B9+ z&$8LKEZ4kI6uyvE2q~8pzX`@F8De&uiK?j*#S&)DhVAD8|1j@IiSs$PS>8X=r{c~X z(~%>E!R`bZ%0+~1`D%TwnzlkU#NzT_DknF0jXqHoHg!IMy4({E#dLi+;*PwZE+zuS6_h7Vso6TW z#fL;@WjzAVOWhR1J0sbXl9uL)D)pkD3-@?2-uF(vm5d7qMTObG<9~oj1@3nNwx-vi zfe1c}b1GIsjnGMxc|G~COp#SxjCQ&%G{q&N_)MNK_LDk(J| zNv$DK5wd(t`VkiVhi@Ok0R;t>Mt@>|MpVrsQWR|3-K6Xvd1NF#2I35G>fQ1zpSqXVk9@3s#yU{Ph66J72rbG)F&Qrx+qpZ!>nz2!0`gs#pP*(GjWK2v=9i5%M zpy$)5*3r?CoSS;5G<6bD)_i7kt!pZE%V_Pvp zEX@e-$EabTF-=UpCCx_$FTS7()cux(S&D9QLMDb|e`ST(Fm4MW=HuI9=Jy2_tlElTv?%lf=0{QKogD?6n zS;9R}OX%^csi{2j*8mA4mqgMbNOA;QHu_WmgQTQsc6L&a^R&9F@Bt4AX=8Z%H){0! z6Sju%i}(s@K2lP&Y|1OcU!sRwv258fQkP;yzKS&tvF5g#&YxC2GsdGErCxzv1yiEA zrA1v+6Zh0D#rn0~XAmzyj7H|AJwWf;5Ukq>1(5z;!=hqAQ5V(E(Ov6Mm24$RMnz^H zGNCm&QceFLmjLU4s&k@|Q2;J~P;G-wN~}drjyV^li81AE(b;%G>cxGNL*VaD9+Ycj zpV&`B17s>g8DS({fGIu07P0=vIOKjHfWOLI5MFTZ9L7O5^Xk8ntC?6>JgKT$#B%aq zo~B5(ME`(q!A}Zp*Dkkji@Ec4c&RXsnr=3^B7GK$ zB>B1Tax3Y;!OW!#6jSY-zaV-0_B-GMsA;HJUx6D)7I< z+rwsFypw5i_;u4{E`cJK#_$4MGI|C~+Yf(IU@<+tFn5D<*mhkOK5n$d#rJW0x>G*pjh6y^70Kp z2@VoEAd&Zr&D^#mCSD~XDrj1?A*!K|l0m=ugiH^3KmdkC0rE_LkTq%*E-{@OA2e~p zXgotsow@}bj`(rm!hitR&viK75|LYlj$%to?g?9iheb;TkMM;HbGcgf%j00(8x$Zs ziUTK1m{>r8=~v+H-!p9@muUhnL)lLBVBDmIVUdvn|LJ`OAVHlMJiAWVCI$ruU#+Vv z!2Fzej@bg=C!KwZljh{C8(Va=z7>){v&1*@q61PV|3ma+2Vn|E=CG-wZRF#;rZ{jk zvXepP!IA;mZqoal%ZMjDK4ejvjKo7;SFAHtIF4}M8CC=rN$#Crnfh(A`t>R#ZMS4GKVAE0#m@$B+CI4u(i>uxLW<*DpZ(B|Le`Bkzmv>%@&*6hMpEQt-EV4|IDs zF%S>3>TR_l(+GzxV4Re?q)KeVUMBsV5F=uOz_q=`3$depHTS(gI$F{~^W(>lDaEOu zAU(qBjh;|DL(M-j`1fowpaxXY6m0ZuIcsxswTo=)L_ohNRO!fdg6h=Y*I5*TBNa*= z=fhB%_Tj-DV6O8DqzG7o8p6M)`XGQh#$xr2aTdN=!F0q={PA>RihC zFj!*Jw0eN~%w`?{6^@&ib}fQjxO~?erivK_ZD?$6-jSJk4p@xYSXw>&ZqJGCPYzw# z-Snj$g3bfv0cV!<_T1hiPqP|AR&UD=GO^KE!~6P52H2*#QNC z@T^OAJP14WFs%ImBNZ6VgX+2w#q#j`hyW*h2e_URz#%Xa`*|^j+=J&AnA zw!e)EiTChSL;-(%zTVKFW%>!%IIP`o@BGrA6YI*&ENw6U6)VE9aV_exZ3YhNq8uSl z)HanU?Q8aw4g#SUDXvhEkb&RTKFi#*@Q{#xB2tw*bX(acxHaM;Qna>i6s;yby;sB@ z8X{OTV9%s}PCcb2{q*Tolp%|<(M7r&7SpYupxvH1T8Y&$OjXV)d6(I3VdNu4r@+w0 zrfvMbe;XT>IMW|LPAt}6B`7);EUeCf>%OL;#{|fMDL8J$!`o;*6HhPQLKQ&8%yc!dI8tuOs!5Zw%NAC} za!TUem-DA$>1FYe{hZdUDdI?L`sSoT>2D^tSJMC1<;e#GGCauXHYdG#9v)8_Dtzxx z)TvUUQjCZF9aO|%6I!i&yR}DDh2i}3Sey3=NWQxTegXAEzkUyCSHJ!OsV2p+^0K!H z_xom}EBY&|%;$>{rp|oSYoMy(UHxS)<33 zN7do|9f8`(%5kKhROQ>oSTg2ICk+waZ8futAzd9M05`}aNQ}T@>F81B&qU^( z7I5ItmS~NcZ>>6HdMdsRBCBP~3?5JRl`vD13mpdRMXqt4q1uq!5F0Uo3Ug1|$kb%1 z`L7|xVkctw*mS5p6A>R8-GuUf^eA(eR)&O_85}!gL@vZyhR*`>(#N9iRBiy!jzG$1d};XY*%c;s-|QnZIz7VUVHI$A@q__q0LJ^Tvpsj@$&|p);ZBJT@w?9O^;b*!5NjBglxMW;=beB4fe^DyGv!C2t_3PYT)R2(WqV3=Zxv^uv5G%t zo*1;#vtg%_iv5*Ko-&@;sT`+hx@UMq#Lshfu}K7&Ty5cP(j;h-u$x#%7190Jfa3z0 z8}6#F+EhRrij<9HFWC-@6Xholtb+^cdw6&K)$V#E9g-G*Lk@i55w^T?| zLyGnw4VCh|ZvB40=a1*P|M2beP498v*L7a!d7Q^_oXw^XSXmgf5J7eOlDX*KEFC>Z zH71Og;$HvbQxnnSGMlJ<7Ct;#b6OW1nm#v{Y20?ucuE43Em#R|XztK3RPEJ4P&zUi z-jO-lMFH4L0`qZHfw0oSAl(9W0=)Abs1@!S1~HbLi_bFU^6Jxhd8u~#@+$q9*hhe& zHJtZB1X00f`3Z{1`RZM$%<8W9ES^ z^m3qTP}^jfIaaY>QhESDf`4;8di02I?A&V(1HLnJ2HwH`m44(fW|RG#gkoUpfxH$J_BrtvV>ybQ}IaSA~l+J^MhQ{)-Gq2L=W;VEJ_SDIN4x<@p`d zyMqU>VqfuRJ{tN|dP%%Jx0s)jMCf8}w0N>jsp_~#RoW0Jj%FDB)P_{R2p7s~q&L{; z0l^a1un;c^QZLroQJlS&w6HUuRm@*ZF|DFL|g{2UN%^=4f4knh+pRyS?~ zS~qA4854KlKUE+>o~uM!kLip4{^FbSbM9Q`TZscSQZ5cQj%S@9Piq1DCRSjN1io$A zzkhFY^Vh*vXiT}~2r0P;YWyT)516|;X?Hbij}6R46~Uh+n&~VuU}&zRM@=IN>?+jg zO3PK6+uXEx!@`y0jV-)i{-aWn(!4q0XzQu;jWgdNekKNq|+Bt!UIFKJ=G^j5`*dgo4WtaC^6~$!UJ9l0`#{+}TGzNLM)sP)sIF zB{ihBG{0uKx59e`s6nf%t5K>|eY)b>k1YqOiHqfgaYk7gQ{A8Od1CdKEE+P7G2*lc z(S>oqkoXY!Xhe-%vOe4j+AYQfALtz13dqL&@K=S49uL|h*8s)X%h#_TR8=uX!Juki zoub=kuH>|K4kpdp&>4cncYlG;*JbIFY_;rXM-~RLb=t) za~)t62q9IPs4?X3ixVJ(;NV~!{T}94-OW96yXt}K14zPY%A+gY?lBER4DLb4Yix9_rl{628)9!q_QKK zmrhSDqvFc1ccx1RZP+G|crXyCQ<7_LcJ_Jli>k$$yEvL@R->Q9#g_egcm<(Zw0}DM z!>HI!Y0oA!l_2-*z!wcoKsA808uOhhRiKh$$4Nx)wM}$dWW*`8bri%@f(fuccx!%A zwM@y)n@g83H&KW_cLi4Bax%8jXK)%2Pi>s z=e`yeCn01|=f8jNGiA!gGdhx%Yco&fHN8-(U32*Oac7@R@@VrIt;x=9MaAQl(R$at zdpDwW0OGS_M8UB_K52oIsr$aLM^h`KuvUV&EY|6ez(C-g7Dzc{O7Zns7Ieh#-~Z8R z!Kwe{0!(DEI&I`!%~7$Wblh4}Bl>{$1xqDeaQpp59nM^+mabT1X+^e zl%sP@qMkQ25#33k0A*=EmuPLp-hyKncR*VI0b_eKrVUe$irGu!fX9l3kFSoBjjWvL zvs&MH)%LvSLVC9(E--!YzG1Q>`6MYT5iRw@UW=M*+VMrOc>xQVzcuQcQG$ZORh8~n zS%^-CNwC{zEC^q~NIO0zBnWx0AM&B4*sZ#_Pz_U!ci;amwAT^iPK$_qRyv;mRJN>r zxuIPbj3bH++-!jJUK<-5)9RqQ8twka=(RM(jJ_&t>ZI;TFDlkg&cFH*2|W(Q*DrT& z{PE*6orHOBJVCj@Iby$8#vVBvi{}T0Kn}{QPLuWNC}TT0{#*Ny6}*sGk(Du<-5uV zm~M~im0K^WX9dA9$ttS7u@mQPw5#zA#}^|)L-Tg+n(XKpDOuC?x0%thRD?E?>7#UV zv*fxC6KV4%r|mQzo%xmUVC#)xppaU|-QI9W2PCZDql9%+l51g2Fmkz)K!PcwpFUjZ z6Ox76vYR+hXwH-4iQ6VY7Tq;IsAg8;{upZVs~$8cnDaT=!=wG?VoFo&T%U8guJ>|r zb_V@@^XgSrdb+*7Do7-Eo&L|DfrUqX;+Wm8hH=7=XKOq{3>-yJnqe66Me3`{PMpqv zu+AJoKnjuqa+xGoCTTyuvUUv{(e#(z??56H8Q_114!Itzv~7AGL9yxC4wR89TD+gF z7mra@SC`RXy|1>&N%0g|U3>5P5R0f^yQ}nFEacjqpTX%$3sG%_M!|VMkT@X>6^u9| zQV5Iex-83L;J~&5eT{_26KGC~qq&ymr2h=DVbVKR(CymM-|ZY9)|W)n{y-n&wQG7$ zAAae=ft|E*yQ#+Sl{Oa-KYqcP#PTtv z$C;Kz5eS&yzJITjr<<}+&Y|)Y2exjPBBpid^jQfhrlhMnTbP!op_ic^E64*|uvo_z zY}#(0?A9+S;1BRmzkG4H@r=&ycH39Y4klZq(2uk+uT&ObAM6|-h|5$b6D z(#O!sD605*?z_n)omZOGrEp@T1Ylj_4h??#AOP>Yq7X(9tNB~pE^g>w=)!_P0?1HR z(EL?R^(2ky!4WKSX#tNPI;Uhg#6f}#>6#!wB{FPj4-SY>kEhllw3MIVkYoOZn9)vjMrHWJqX80jykT`dU(vFNeZI2Nz>)^ z%gI|UPBcwRlrn4``z0w#dG1F6cjAq2lbd?1i~zALt{M0FZ*gT6B5?8>7(r>Riu2!ktAi9*s ze>$1CF(C|LVBup#xEv`QdGQ{}$`MDTh8N0iF2*(f#W~HsiZvOqVLW(yt}!X=?)F{I zW)s3lrgkP9HifK%C#kyYwPT-}C@+EP`;VrJjpazf-1j)umuECOxNc>*L+pSXcPsAS z*QzWS_^5Jg{f`&5wKCJZjG2ScrTMeG!r&1F#@!tNogyzfDPE47Zm7{|3H5}>yQ!pr z>Q-GOum9Jp!+U03Z~PfDa5uBq z*SkjoOzV5x-r2W}aFPh|{rmEPyVurSmE|m`83ZQIh`)XuW$bcFYDvB4$>-}{m=zT= z8j6WuW?6OL3;q9mZ3Q2?B%xr)Q0G&Fb$}m$pJ?FJ)#^Hrc*gWxrkaj-R2M z8qAkYkMkf!OO9S*I)RZ*TJN309bKJ_Ou4xIyM z&SXf;v%Kj~ykJLVD49?)B-rWDP*Py- zd39yw%euOI4G=Tbo7enX! z*zVb;c}eX$Ms1RvoVEuo4#sk*Wx!X7tJD;p7AIupFAK=T*oDd(n%NKVR0jtKUV1R% z-^;Xe^Yb~H$LF4wXwDl5$a4|&!p4RnV^{3kFC8)!cI)Kl-eT*G69DJ~Oq$ zO>s+m3L&Ldf4ZyK zql>pkN9mJ_hA=6e+d{%ZEY~c4=8TGz4r#RH;-)NS zW9GEk=9jDc-qIdmJuTgAZCk(|TzVPe00jxTAB3$@u8H8G^fdKyL7SMyU=OL`6s*q{>jicS)tr(aW45WHTq=FA=BSiwUncQ z5tQgFS{=MyIz&LXxdx#GR-B}FPCmPoIZ@#_fHEAVK$aHdWgPH(;*VL4=hyXS0pOjU zIi?5qio9Qx$>d(JT!{rBoB+@n%qPBo7oEZb&n#`J+u=)k(@oWNLw?G^~6)F z;68C7K*Xx_>sRLZ0Fe-avA+pY+Ny;PgNOrz3g!=u>vA0JaGMRPFa&1fo04DU%8uyC z>4WVw;KfoVQ12b>3%EqB%QnxcOx!~wlg=bu%oz}mpt)OnaO?rOLah^JAE@i; zGw&Te%R-wDKMQO4g5UNgVtG!UgJid%bu!rdnwo4rJiQ`}ga;j!GZ{w8eIP6A+4&{i z5oMe@RasbQ%#2yUB8a0qLJsG>d&lQIg^vrQZ-waXlf@5+>DowwBP(+9K)e_?k&}aY<8Ys>9-VY_fSt|x7Fb1sy_J^2I}-#t*37qoX-_(Uu*3Pv`yC@_ z!EQ@T3??HZ&XED|FX%?G(smU1q0THRw1>1H;($p>;mvl4i^J{6?4TnnD=IqtsER3m zi8_rEa{S4;CNh)t14ls8*V5F4bZYdho)&T7paDbn!mAZ85OXfNkA8morUy^5sM!c; zSpcW`$%Rss4mzfAW@Z$64E2j?c3QB*!BOS^Bb|{I2=9KcY=IE*2j6ew4DEpOgk31x zGKMkeHNkKW@RI`+<^sW|_fT=KXa4>B%Yi-ls?I(!xq_Lh;RqC!JYfoTTpa_t@@phY zlB0}ABx8Ya-s;%*KO}KphKslu@S{707Wf(WBfiL?E8QZoRYYOmzyC?^-kA(Y#R?CI znIS@!{A{(wW4k1)DX2lOJ)V~KoXVC22(AbHnVQC*toZWsVAyPc!~jP$vl$d|Pvj6* z7;GuouSxHd^M?@1T>qhn<*lrkqpCnf+ign;DXz=^e8c73 zXBthg&KRM_rFLpIH5Kz<$SnE~U;bwz4RE}#Flc07p-JsZ9po{`(+%b!f^<-HS|DY% zoL7eX9#mJG>x`!yf|%=f6DJWaDr^Gr{$}5>m`y;2JVoL=t^u_RM~!N?r9@-TEp81l zdG>VuB-az4QfPj*AWrG9DqmDDXZa0U#XYB@=;VMd$zw))Ikz0b3CsjZ`IXr(+D_J& z83m<~d!3k$f}=}-XUrO`;C{}cwELpPV2^owq#5($7lUnLn09y2?ymSHGXIkMiesw2 z^T-2Z@vImN(4Uk<+osR?GG(>)WWtiLeXX7hmMJ$qM`NTgxPN~cfrJWlH{T@r{}$m}*DtAH& zKVS0=wk8KDh0Vr*X~Y~e6iJV;^q(>`1adw^7;LEC={jWUm|&M|rW#SeU)n2aw0@hI z8`4r@;VQ(9dOEIC)Es`b_`Xj)?ss<(vdm=1M zuwOPV=1DnPxVps$Pst)sVeLTL{rAg(;X>BU(gET;H;cV|SqzsTwabfNo+ri`6Yx%l zUofT6@~iUEpQ6zV;7=amPD}IOXcM*KWw{@~ z-il_bwE84{71 z<~=uC@AQ}_^~(Iq9w+S%3G6jNn4;E(eRVC(QqhrnmBYP4B~p25Nayt^&a~pAmZVz@ z=xVs7{%1%SR{QB&R}C9>nW)5=P7{9jZh5)gkCRF2=&I=k=Gp~?tEM=1?ycHGt z)=uE#(_Q|5|KAL|+=-E!r1|iQEE5x1MU-|_*?V94n79>nl95j7J=RjKm$-~%f;D<< zJbd^q2TT8IO9gJINz%a9+x!k>o_|v=Et`MWuJz4a(_8QKQ}JN8f)6E44;9Su;Lnf$ zzRM6Z)%>lidbZuZp_6Re2(@RH_&%M00DfVx;Z2@~@tsqKOM9PiO?ln0lB7S-vXj~T z%1*3YkU!ekL>?}nXpRXc$jk)U$VrAx``5w5^`HW)+cI|ifAYGe=Xy4>`tXVol^T@P z>yKZ0tH6^`m1n};e1o9H*rZWe=&iy`2#hWIn%b3RA78!NklcT1;+=l-GGFFoE;rQh zpLc_92^v>1mb5A>ktV1lR2qg!*RERMZF_BF>ez;TLo~#t z;g%AP$N&s=ybe=|l95RMb>7llGv+g{-3I!#^dJ#z~d zvf>G-Kfl1ld(R;IsZ$eb^^r9LDCHg)<>EJO=vA84vTf}B>4!x}%k@egLk7b`Q6N+f zUHc1a^5%^jx&5`BpvF+-LoP`(o!6P&0Oz>|v2*9&kNL#=77UUGc#PR-c+1p57V_*+ z7@Qb>jc?bBVHI7v#BV<`8|tjoKU!qhZ;kYA2(CeH4oa=-@`hKWw17TGd=jKTuA11m z*V2!wyfiSQ7REcn1J+TOWc0?aWeQn}nOl&- zox>tbbj_riR$OOK;}*KpRJTLon%v@gUe=I&i;16D<&+W6A`0Y>0=!XzasTZ+pXExk z980MvWTT|%VfLS*M9;+`aBKFUhnZR=QWVp+EzMg-A5>~DhsQYBu&2hr|H8Dav@BCD z(b}usaDiVz?N}8zMvONm_Lm$dPTcxWltG!!0^QXr3={I%LvW2q3@RoLGQ$U$ERIFY z(O5*mP30>HWXRiJ70r0j=DvKC#5hLw#{DxPlq=Mx}R)^nUy%cwnB!pTh<;bh2e|8)_Jn>ynWn*vKKCM-- z85@|fA|h3}@+~XHahjp3JiOsnwIM_vVsGvKQGMX`B)J97B@&Q{5WASw$oWJ<1(^H!b4NEv#i;dGjGw$fzQqL=%TN9jwgCwxF)_+P&8_$0 z8C8Acu)pk$dn(Ta+8}?)PXD0@3&fhy~{vMJuGI=I@l08#ua!tZ=JSD~L z=dGsL)~Bt%qmdoNxk9|4>rIkIku1}0s|CIBLHp- zoFSrSY4VW3O>d`%Pw6v=(uM<3IUA3>(w z@&Rg}qRU420)HAR0Od67xV1rRYY&GdrO%Ls zS_Ur0FF$*l3GXpl734F zm;$9A>ypO_MS+VxEI(oBnLZP{5Qm5L9;|a4EN01K@ejC!gG-k6Z^`qu8Va7M^> zIwuUQYj12IZp&l}b<30x2)5luZcpn051V024Cu9jD}DaWr}yt^u~IYhG+AT(jET~Z zR|$;bJT1IRDVik5bK%xO7~iO55Ak`51szrtU+ zS$(aq7e&21VsIKh*usV8=-HMo-SekCpLB7*&>jdjsj%z*4yOk~=aUD-{RbGJnqRaC zZ=0afke)naxaDv0^+U+f8Gs&5jwbVwr%hWheR>DDR;_l~@n`y2SXr$EQS>=`?wunJP$}UA z*PW>retvcVmYI?C?I=;<-(wZc$aGD??qDSd(o-lpl#sdi5;hdSOmfYnOoR?7Lk+bS z`;b;;?0*Edn@W)o1Hxo=J zBsa<(cg0;`%j&U?bO)%?+-eS7KL?S4VTv2<^wInM1%JD<{4#Zc;Zgm^Iq`=Zd9K(N z&tPi_0x23pFsEXHCJtz?sog*WmcdQ)pPW;h6k7AT;novHKi4B+>9$JlkQZq;w)KP|E!p>r%&||9QBexIs z<9HAU$Tc)T(TjAO2x znS`o_r-*X!sYhQ<#mWfGnKIq9XV3YMau^~X_-?Jk^|4c?G#AL}@oU6>|jF!bMrFVuBbWDbOg;+8%6?18H?Q&vf1~*ex3^AJtU|t#xVNu*K%|N=uGM3 zv}>0@eTOw@{D>~KGcdWqjEtk8a{_86n-b;Ic!bZTeWxI!u1R5qSuN5;n=K`X5Vf&_ z4(FJPk5`J*>!6hoCF$kedwH)JIVYx^4_L6^3VmBZUCs-70q8g4#&ivwf)bhUho!v@ zp6m#ru{9Ub&L{RWjt;4U9LW3{=8El0Ow|8#xNcm*Ezp5DPL&p&@GS?Ab}0N*gzC zMkQH|VxEB^ndk3@9iq$Q%p_c%2MuBlX=C%<^<+CFq|-;Wa2)c_t)b#|f({^Als! z4jdqytRWCW;IX#8hgvx@T=+Rg!^qJo1|Iy&9|*TADepd`;Bd;8Q-JS(C~KER=$4k-nSX;nnM1v z?5Pm&5r}czPtdos6UM%rIX2wFfff#&Uobb&+Mc27D-0YT)|jSMzNJPN`M?SagV!~m zll&&jU^0l-snRpg{o3<=TXi;Xf}sxPi!tQWnlSdTIeI9c1Hi{?hKKbfVp z@pnHU7m+Ts^4KD4b{O1S^?SwkbYhzO4ctoA1-XsbfKI&acHr)MJQ&wP1;DQ?KlxG&?B%z$H`!3 zl|i{oQ;eTbM$1n{0NWD6LjSz?o!&)8POc5ag?E4d{04K2j*e!g1Xy?Ct$Pq%x_2Gf zq)gir`a9UQijeryTmC=p)J*}pLb05%C9$YTh(Lla=D*Ma|_22f;Cs%L0MC`8f6h%FEym0}F`b zEume*yX}UrkIl*nd&8{WxK~;&Bm%6st)Rm^ zbB4#Z#v96b8U`kDbQ^mg1M)&g_<@BQP6E5FklW`Vh&;_;*2vX8r!sviUm9sR$o7GAa_!S|_)b zyA~Y6A2-r6~RdGKlBYb7catFGgv$-37o#7AE_XoXfr5FB&ve}d-(nS02W#f50f zMCV+?-X|HCz=IO7X|D?Zu4Z$^bwz;wU9#-+Ac$G9aA$6o zd7yPpnZ-Zi1t!yipn?zGyeDTD>ZO*6HseITL?3So+N+-zGj<+p7!MCy2*D(A6cK29 z;n+Sr+noNnXD@Cyq%Y%s+OFJtFe}%ECZ3Z}5un|`i2IB8ugf+V!A!IL`r_R?#b+zN zGrUT<`~AOIbBtWjt4-_89t@8kDtg|Evk;-bTaWM@}KP}yc7lWU)q^*>waiNqp&99O41ncwIL%Y#d5}o6YJcK z8aRuj1^8!jzT2lZHHqy!0&>ru3af8@9r8;uHKCyF*%kA4yW!)I7WO%Er>)#LedD9B zZYLh|Zg}>TdPwwMV2=DIZ7A(@(@;uQr#~6rOEbO*GPlxpgFXFbsR&s3{(b=kcRmM; zYXrQs@>h%uyhmwBF+OPPupb{DWgI&;wES9g5{d!J%6_sxqK58Sf=Adq&|nTNb`iKO zvfPqDTiZMUul9R2vLDQF#UzjP98eZTw8jV2A+S71rTfs;nKS1CqE36c$$`;G1w=YI zHjy&Y_O!0Z@F>x#*U!bJf9N@xekUdL@RYB9J@{WiKwxIrbCf&BC^-Q>8Uw!UZ(9~> zCMVtNN59f(?5?Kf=EgGKE@#=guJ|GdcKWK^M5hU_$Oal# zhAdi?eMm9H{GpLXYh*17Xg9+HAWXRemp^Er8VkM4gZpZ4ghK?YL9NeDFWN~3eu-~= z4m`qM2tbkOTA@u7SuaaXe;pm#9g4g2uJB@0q}S4f&EI>B@1c<#+Df zxOo$$&+^5Kf%Mep`Wf{v{PxT_1!)#&GmUW!;jZ4(ncaUE_r>p<-r)nskFWbe;Ojmb z$M6i@Qn@BDj-Mg;749JSmW=etTelW729j`>X?M#Dcq1`n8Jv+;BT9475C~8|pQ9bv zBpqRMm&ykQ3WFX=#+!%_jo2B`CAL6sYMSoe7-WA=@mgk-nczwAYFyi|QA_^2 zr~%Q#)x-l24>aD?NJSxoT-|@Av^#}a!8SQz+%%#iJz1kXexW;@L`NbaM%v~J2>}RQX)k%!kcx(?)9+=#tK<> zt`o5b(;s)YeFTkAyhHHUW3B^;hF-z%{pzCWI^-#|0SovttWAk9Vo~CM8u9|Dp*Rra z%^QFlUct^C7?@5cH^NsJito4orZmaOmn>uo&*u_{)(N!4Rf#!zoj2l}) z7z(t~y&)yynNL>22g504kg}h%3fG_>+#uP;vfw3gmUBQYMm0`%rnRf4FZK%eyv3>n#-$5e_6AV7e zg8svkByWbxt6%18;LWI}<<0a9{{O&NN)QXE4%U@t&KToM&|!r$qmpVKsEMb8h5ruk zkCGeO6fNpUJ!^@r2N8Ao`LP&DT zRqU^P3+mI2`4h}^dw*lc3;cnXfK*ZT!50JK3Z~y_^rBIWiC###1)R0q-0Qslxh+WI z9s}11bEIE4o_&~U;bDem$pv`EnB`bny z#zM-%&H*1X$Y$9S&HjKS-vPa@tR$Tx)U%T46OiRHZ#F7Q_Chu!xj`H}sC?hcB}gN9 zLoTqo{&@i#2Lsfz*ez4K=04&1>&`nCsmn-`REbw*?i_qW5@wdBx9v?KdG*py}+NgY-t27=Am4=G_=nS z#(Ke{uA%y5xWzDE5sUhbFlEqy0qMFiG2mri9%fHx3Q~7fd5SFGGxJhFF#O)OosHps zS3SK@a#jpgNZpxhE}F(jE=$dBBPI$2*jY4BcJH1$YgYH4RlEUr1UVfsaSQf#T{j;@ zs6YFTG1^kMEhc1SahV0aOiKVTlwmLSrkSAbgcu6d;>~)~Ep~!SkW-NljhwLh zldKqRnD9BS$5v7TvcRQAv>F)T=w#_g-GpXiM=2FJ{k&5&Re2?vD5t-wqOU)qvOv8eE5))wAb%>b3 zhz>T&sb9W-cedW%f+B;)fa6#RH!*SPRk7Zs|DT^9)@lU~s|$q)T3oPO+9D*fNo9$T z*fJ(V_G09RB_=5yI^b<1(8i#iXETd7^jM-SY%n*D@|iq&#LwvmuW0r51~x}vq?g+! zDUol_trabYkX=ZoJcbWNbBhbE*3FyqNI;AR7yqM9wNks@(%j^+^1O)~*vRrJc&3Ry z(s!1059uMEE1GnC$Bcn*tf;K)XubUhgQ`gc$M-r-17!r=qPz4pNPt0@VT=|mptvUY zrP6ja<`h(q&E&7MvYZ)pW1P$bQ9Vj;4E^^)lp*vK2%hWsFPA&}>Xog?FnA$ka9Lw| zfEllUGA}5o$E`spHb?-Z3JPji{6TW-*VD7%sXPfqBM$XM2m@^*2+-b0aYq3T|5W$T z0K93EI>7YA4Up3myf`pmH4%?zk5|F((2|K&9X7aF3-X;2ybm7QwHns`a{bTIMFF&x zxPJFJiui;l0N@ALb#W2V$j%ZS;TojPOP2Ke((leD83AV`qxl2;xtqb5gYR%jKEzGn zKDDCTL}vRhrYY{u$HOG`#{l0Uo{64(PxRK;mb|%ZVd#(MF(^n|LnE^JMnE=6dMR;n z={H53F~<+uXy~if)dvg(TyI zr}1HY0DtOU3)xLi@c(6b+Wh%Cj%nwwUq>&u+8=)GY>VhfnR#+4g<{0D*eUIV zrxAPg5$6*zhHhg}w2`!{B27B>^V=`9;aL&(gF49*RW>B7|739oGZzm2B`Aadl_`;e zqWg`-xs`7Po%N$#=1A;Rh=(*uD^wgOx4unN?=iWe6JACJR8p8HEWL7-S&n`y%CDd+ z!JXogQZHrk4GJcvNf`Tky|@@7q!7bTT>m{frUqn9^b7D+aDw z8SdW!09J4@?Q-kK1A7Gg2J2d`pOKi5aEqoc`KM^(d!;ek&Gw<<2Qf&ooGfI&ON$Sc zgGLZe8uTzBo?-DCP_0E*sR?ty$0bFm_y^&ua4Zn)?a50NV$i<=#SYmNziK= z&>Uk9*4x`d0p$7mDQai|*I-ksugb%`(E6D&HRab7#vo2FhdqZ=TLX#Re%;bB3=|d) zZcw|!JVhoS{a*iF_O*OeptgH>ayI80tyNMQ+7+}>_UqpMUGS)4HP&emk7&0A$r&ya zBhgOwR@;d1K@Q#gpgco-rv*xM0V;F0-t!}@=gA$+n_+R*7DySlJ{9sVVo=RJ8-s>N zXBYZ%x?%gsG#udZsv6}D&KU$HYDeOxBF!^!Uv93Gwd!mc?$u+s&q*hm6J?s&9E4|b zdAbW!0e04VqzXQzT?L_``AEGIzg+*0{PO7Vz}*PaBMR)SC-BXiw^95zESxjM{+-g@6r!(*Bz?kkS=kA4hL6F&a;fIsAP z1L;ImS%ANy24Ng)i=~SfJ6Nmsloh`wD6D(n?UA#|7C>>3%Bt{J zwD=Vn8%cp-)nC<&4oWEL6(z8i*<|BxN+Wn_o7DE>^aYeL6DLg)$93|sFN@!{ONx72 zA%Apw4`*KFjk$wEnu5Ux&`Z$mL~7h^${MgtGU7%L2d?_!5slW_ZI5eiTy_(6Dl7 zYT2w)kEkf7WCzGzuy??)ftTmTLcV9Tua>V^H=U#VE4s!p2nlgEl{XSUVk4v!@FY}hE6tL5vdZpI(K@~atm399PHMy!^BU$UGDHnlf)^S#+}sfGRLwH+ky0lVh2j( zv=bsNb)wA69QaZ#Oe~W3y}@b=_bOjn@xNREJ6uoa4fL5d?aGAu=mA9_P;9;yNcu6QgZ1fK4%a z93%!Qnar2~@97{PIqfm;|3T4UK1OkveY0(u8V8$##$+&4m1xK8Fvob^acmSEqv|c; zcKW?1=SpB=8c&eK@e!oMEf~i@Xlz$Mi3$P_2#7L#pVOBQ9SUOb{Gmvhc7{M#FbTOO z5J4on)JbmPC{VB(nK$DHw6^=(>wXp-%^-G0=Dr)SE=?^7q!qqjH)dYge`Nb81(;Ev z^I%0N5q4)wW(P)JP+Tqw?rW^Uy%RTCF#Q6M$mcTqnqmor;hVNSH~SS0AG)A{lm>W)tOrN5xeiIQy`Uou}o@ zTLn3XE=-83RqHF=ynDAlqKR@CX}ojOSg^(&iU1r|^K+eRF< zx4Fw8l~;M~#nhk?jxuw?C9fN2-P{?zymxsR=5Y-0;PXNhwKGhLd>rE48&$>9+6feV z`kMctqpm$rqO-E&Qtjs>)Dky}u2(H0)i|dDB7n8^?xFxuleKad`B>(y@S*_zmtx8l z_OK(fnd}Uf$_s2duw=66zXeI8mbyT8D>qL)YJm(%i&N~~)@&a_=C!UFdu%!f; zP)kEa95Xo)SE05Mv>;%ibB)LT?0x8n&Rciv$XoqwgmJa;b&aOps>xay=JN_ij?ire z_v@#<5l{Lddq-zf@EDRC0XQ7Tc4WIGxsvRXe$Y;69p^^mB7VU`pqGNx8ecEzu53HX zpE(R41=3;~0)dbtfC^s_2JW89D{=8Pr%oMpU@Wu=h=WNt2W=d=o$`iH&|25@wH#U@ zk;FKpyYIB{zq@qbP&oaVDF*eg(!SJYs5!0ze0X|nu=xDHnAil%5Z?YZngow zs4cw+xr);4%PG<)?xmNP%Q`+hPl{{3B^WJ+DQ%A=mDZ7z4j42@Y1d|sODcR8o^soa zhP=c+S#SX*njOwhp%$Uf%tyiW+U>bfXKT`vv#T0kF*q5gH+=Zc(Kv$HcWWj{FQp`$ z1aJb1C>EyuQI)}_zlN#eAO7sj{4PQm-TSI|i8uy;?aH>GmN|X;v?THXH}(JcYm7?< zdq}Prd>SJSI6KU#s|uHB6YH{>Y5?kXyR_7lBAcsMFNXzwAU_DjH~<#4L_N9fptg53 z4M46FWK1ny+@R#nykXL}b9_PgmUvrTzq)o{1@lKo(+qTTTLt7wLP;TqHiLZ)5=hgF zsY~=70l}gxT=;VBvpdl)`3c#D;`#OK*J#Rz;2Gtd;cu~%lgyf$(%Kq<@ym?OHp#In z6S&LG^y$*YmUj=UACpSP4xKn%zE(%rSD9QciA{HaJlwK{p{gOJ8 zRh|t3ve|a-yZX-tz9Es9RMm|^OmE93!qSblIEOOzw?n#BODRqRj)vQ|Z-*+HuIbN? zY7E7&jADjk7S~*^-#>r4HJVidtf5lgIQk&#aKCQ+#_*o1>Iqm7!5wIQq`6EZV)?SV zo6I4_c&=)}v}xdPUpNFzL?EI<3A=S`epT*l4y&yd7v~rfzv;m(gd^6m;{(q2`STM( zEMcv%UxHi)?F7H!g}GP{kilTFnge(vPv_AGMc;qS`SEt?YW66PyX#Kr^csK?H%4T| z$6pL>S;r7e^plY6am%Dzy=)oMsUW!?o*_1QKtkMa788Ia_>HSEwJ)_d7a2yHZd#@Y z(U2xZM`Nc2?qNPTHwf^Wo?B4yw*t;G9M_S3qbOsH6+B+#kRo|$q}!6zq5yK)&yUZV zGq~!bcVK(>@Nzkl`AZZ!WSwwDuq%Lg0$GL%m!ZYdsc{NK8pe>A7#mZ~RRocmbO;S? z0rw*3RLOnz=TOqttxG`$TZviUcm!e-WO%2K`hOCaY2)>&+Mz?n@#7RnSe6cV1q@`cjd>hx(a zJbrWCw|AOVHLhp}MDwdJdDCcvh?HV~*cG3vPAhFY;v&Ukms)iG30oJyNXVy;g4qTx zwiPOK`g0h<*afUUKzA=E=L?-A_)Ppw6TwOxz)%zbQ~c+rr`Gf}`r{(1sW}54jk$Rq zMhlz`Zuj@?*dZr~cC5yxx}zvLeihU$HlKPSaKVC21%4F!R6lrARM{su@bPKugSPbMxAj?GQ`f26OW>a@`*2@ zNK6+;dbAa%PQLy0X}etl;SYFyo1IgJCTp=pqoYX9AqcTvJ8Ed8>E3?G&@JSwP+9Da z)mI<~tJ8I3aUX|yxNu?nJmYW6ARVd42F{)9Gig%K`*HO9=#9F&Z}gtq=_&W5Da0lf zP!LLTD_yvT9v-mC^6W<+$gdDw(IyU@F(X}fbc<-nR20DaF|AwG*$Kh~gAf4e@c};F zG-oijw6TusUHpy3*QA`2_?@QML3)yVExZXVh71JcgkFVdRrc32Y;fhar}#MBg0oU{RSjn|hYDwM$5kcM72U(9SFv}w!f17^fNN0|AmO9;tskz-)Ah^EMk%~L>u&>-l z9p!W!0*G~t&N3_wj=wf$w1wKf$c(0tO>uEo1G3*d`!a;p$*C4}(Ms{S1G(PS_UTUR zdU)Cnq9qC2gvjAIK|lH$(pAE;)`als_upI!wEL{7rR8j_&cRybCF>q;n2W$4JsL;C z_&HR11X$>(9p-0C42It?CpNjC_-J^-HBxq650fpkXU;t1f32;jCKkPIg~YdRIL#co z9B3DTtq?ni(boyAwP}h>!OcPV_@LDf$#9?u@)$h7|8|>G*OQw5dyL4pz;c!kF~+6 zL6_abVfemb4@9cv%PU~_>*yBxZp z24NA?exyFCZnOFJqVuzx=X4zweFgW9OtWz6$h^1d4~m?c9*8_R0l+F4-UpfTy?Zp$ zYcRqQ9#T1^mXWH-3d~j48@3vY#JG|`^iHhZvkN`fUSnPoMp>G@gBR65w->@N?E(IK zgSuoigj{+*QiA-x6Z#9$QUlSGdok7#6I{V!epUZKInq=ipRAVXGpYAP@l;!y3ypK7 z&FFPtF@ioqaQC|Q0i-*Ic}h1r4hh8fMG)wY1dh%2&&*Fx?eclpt+q!N)Y9Lke7F3v z7#u(lI3JA671#F+?){~q;U_?6(bUrDtbABgg1{b(RO)GFCMzIf#gHekK#V?f6W_J1 zS_h%5CV`q&2%DzsP76s8AZ}k>=U1)NDU(=0B_VJpzjlzefrJLH6@!?4c!-PMmchMqVkW%#*B)fh?X5L4lXXQ z>7=|c4b`WyC$er=Wna~MMdw-&*k+L7uDON}w;l9s&8~LipGst9WEiL!P+NyEj#_B1lq!Vb}(2l@tber4qV0Mm1xK6J?oMb82e_xr*gWc zn5_>R_6JxVhf{9irp=qH357Azy50c&pk^uVTH}63u#C`utIgFU;_b8Wmu3PQp5gF@ zJocF{otuue{YuT)Z~ePWLC++SdrpDLL{ZG5;*5>u#hb^p5hfGZzPUW2WcZNc_PI^n zaR$38Ed+BQt*hQNr5pN!G4FQq%7Q+Gv6a&~>e99wa7se;WN*MAxDGri2pqA)Lx0Or z4#@7l1*=kn4~Hux2y4K91%jq;>b|J-9v(EVeR`Yn3l$WeL@K?sW^wz+292@j-B z8})3jRFAAAg%t!GQ|Rvri-%dgpA=Fi zL*>`n>D9?=Xe1>_Z0to#7LMmbU!(9>pyEmM=$M@J{_v?&ch2AFY=J04yuJYvm*NT>fW7yX`n zhkaC1yyokl$Vc)V#Kkk zmnZ4Bk=#KyPjZxP_!*+?d!wtoz4{VJEbQLvg@qxYgh9p9?PeCmX(C&puv~vJH2KGu zx{>&oP~qV{oTeG^K~Y7e554S?5|Bxwp0gOT!f(R4={Uhp^@B>knHVO9S{0aP8(*auoUuVGZEad|{dp6CYMCI!=y4N_ih?%e? zel^=qcn(E?IIbSnGx!+YHQT>UMq2Stv2i$YWvgl&2n2+r{kzoQg-S0=|3MGvK0jgg)k-Y<5mhcJfq z^2!G3kHOCv9bEPF>0Vc3*m{n~GDgl&;TV>e$6<<;R-@#PMqd9bz z1CCFW=xPkh9_J{8j~TiZJ>WW?g471B5t0|Zv2@+rV+`UIcnAv zALX#BxhXqH=|@AuBpiK$N+X*p~J_kYNl~ z%o!Vw#Fce5e)8nF+yeCmj9)ANtC0w6SVs&f(iZtmx;LOrgBDZU0Cp0Tmn@-xUj}~)j3ak; zC4LfBQgOOCFcBa5He^+-Wsyq_C-gmP>8$d&FlT?!gYOWezls#=ZTx(Jbx*E>1f{$$R_tjkwfI9CqRl)f8>3J_TJHD zw{Ne5701WpTy$}fOL1Qg_m9Q=;|CR$y|vxaOKX1*?A`kVy&1`zY%2e6Otq@7M>gPK zol7}&WCRI7TpYbmyX_ym8BFn|hnJ-k1EGF0u}iZ4W}<|CTdX@TN`;#Gk1)mg$|-H2 z`v-tiydcY(nE_!|sEm`LUfwo>A=!Me+wjS5-$ukOE#L)sp3{zUXZ31&#-&R$T&S%7 zvYZ% zz!Y3ydtV~_lHJ&+8KI2rq;RHB#Kj-zMk)*)$^dW1O#+9sPTL{2j%^W%kb%}9lmP*j z{#Rw}6|rfDRG_tDUWTS+{6iKWd@c%d{68660uhp%0NTvm;Cuj}Sv--#CjQ7XJePP3 z+!2nE+MyxfGZ6)XKu$XN4~LZ4JRQGH<#Bi$xzVXMp!PMovVDO{9Y*o>ot&cdE1^ty zij=5c%mJ!fEPL@Ew+lcXCKPkJn`w>EuI1X`-El{$NCsegfo^f}XMXanTZut%$22}1 z=7}6U=#oB$B$5m7XPR*I$Oa71H7Xm>?Iq9}bk%Blz(|P6|B-G^e#nvLWH}Bj?Mq!7 zA?^6_1$Y(nl&OZeXw<>jG)!vS6I@3$z5?e%SYyi!L_RcwR6a0VN7grpGmTYE96MlE z>ArUeQ0QM8?m=>vbJ!4WMwtWd z*8Aw~Y<_pcbh|{2bGY_v#q*V%tP``>Gcbm!tJr}cY)C%w=Yg-tC&Pd~`NV2%D6{5F zH$HOOByC;6ME(BvAqs*uF^FVD=qbDVr_Y`(+db$rMLYLiT-~*8cv`qxbG{XUzjyQf z9Ss11jRfsF2kXQN8!06usmPLcV^0g(lr|)lBt_GV zv}xZYDk>$upS$<{{r7wRnwci<=f1D|x{mWWj`KLlFJbiHZf0v~PU_|Bl1xEIRK0v) z2aIz}Pcw)I^+Fh;P||nMFpB+?5a!U*$cyQ&dSI+5iqt!_IYAn^SSR;DE$EC<%+|dA z23MQ-PdmIbEEo77=8z^mO`i1sya1Z;`GZl_S$k;1^e^w=T%Gh_CoN?f@}*oUXc!hO zM{|;$0LJ@!n)!zhl>WYhUJYFf3$~Y1HkY7k-870{1}F%GJ*SPZ#JJtsSbO<|ghb&F z0Hf{zsLb^7K^O4YZz0E>#HzI^tM?ly6s?-G3Im!xs|?DZTCizt+m`mKTS^3eBi}P& z`}Ui)wNBVewFsbnJ4w=n=Vp%Xtvd(fUy9chwq~2uafGO zQ_8%ZX}&m>02AJ}hNPEKR9_S;;XU0E+|B-AovaN48A*pPZFDyp&30;0ai~@9Y#_Nr0&IyLhIg3N5GV>ig2tV#AE@c*saq zL?wessc*>kQE6rRoHnoag9n3)?+qK>?qVR`xug0yhy|R1_03VtsIm4C4~$ZC1+*S5 z7|CZUqnuv9d`S*1Cc=8T*k8$PKvKbMHn`><;<(~nJ0gDw&G7ULr8}3p!RwCAx1X^> z;|nK+;1V9Y9b+v+-7iNp==D1zrV}&@CzU-hk{ z3+GnYT3i2sG&i_5>R-^iLo7-Og$DHxT9%h(ZNCxXv5a1+5+Eoh$&|f&nE}5qIr+)+ z=do@KKx-ykkot^7Vvfoa^kYb`-2o7xDR$1;(0O-ff0&R{RyNMk@|!@+7j>K1Vr_&N zVrx1S*$Djj3&=u!!<)yZv_~RS!m)lG+qp1E0m_?sGqkCg1-|^sLg08$I>{=#S0PL; z4g-#jI1R!4OZ2zv7hA-yu7GwRtOYd{^GL3yY_OY~8&b=#m9fosu5?53o#EDxP!TdY6}AYnX8WLMlpD1nQjNK|IYP!t*|pz9LHBnZ~=sk1&*v{N9aS z3IjMN>f=X`9ox*x=1yySC^RAH83j;P-O>OMLMSbs`{&U9q^*Cd z{T!1c@mQK5yK7HF4`gI;q2wq}XewNc%MxoGFbRRe>*Q8rU(CcpGOL%D?!ODt_+VVZ z!vr|FIz!f6@z)pFT>TvQz8}v46SKpNb8uP!9|h+pdiS-@Lqty)#|@b4!Ww$TcM@bT z1k=r^Ab?cN=Bk>S#kf0Xomm1}aj;fxSOdM`Gmsn3OM_Y6ZcV#CZCl@h&xN;Xy_el8 z*q(y+U^<}_)EwJYSdS+b%+TN6G$vtJBD{1%9~5gMa@Tx1<_mr&yzS0ZtQQ0#8$yjm ziwYY%yREa)h`sHM#D&U)4eu*TPH@7x5kF%Z#_Wpl=i=u^!N8YPI>lCP`>byyp11czdqi$h;X>kMtChX3eAS)+z|Brz&flTYj#&=TjT&(r| z`}(90cEagz)6-kgM!H=wtx>o}nT*Ojm)82c8IF#Z*?UAHOO4{jj|}dpDi3*BYAzDd z5(}73ND+rir%4%V7lo;wi6Wg-Lu& zZHECAveQV>e{?U;J0KtjFXf8#_u=vQuE^Jzx3e%W?{4@`39TI@wQQU}dYFRz){R+D zNgt8CbGPN|bToJ}b^FDeCkx}HgCl^FJvjPC^~znYu6~Wfgm9It>3xCG@iPdhiaa)w zC&Nso=>NUcp_GtBE%mVCT-ECRjwvTx!4)}8tmP$m6O?v&@^stG+jtO<&Fy{nkC95> zv<+<0uy8Qj>rZKG?JzYl(egV{c5oKqP#ow`-I@z`)?XLSq$;9zn6hH{>YI*(Y)rxZu%S}Ov z(6jJ$bdJ|Z={wO`Nuiws<#j-UOgD7rb{Q3qX#O&~XP{X`-W10woXg^gJK-s)H`z`% zwe5j4hrd$A1eLX!09*CJ#o5W!S1xQzo8S@+QgezkgR@u_YLJd zdt=ofpe|nMt@>_3c!f7P_Dluw$}_kiGIo-Xpd6 zVpn~Niox*VYD!8CElOs35$%MF7*MK|@kU{Rrl98hefGJF%=4=OH1rYC^xw>B>CJIE z4}PdRYAezx9~b4#YYxHX?XC69rwZm%&TyuOM=_84@?~Ad&0$E13CNzup(7A{yLZnZ z6OV2vBO^E{<%=X%xaKyX^u<@~f4R4Ev@8hmyMoE?SzcbBXxD(F)oZ1P1T8`& zq9y3R%nw^JpC^l)oT{RW1!)3eFLgU^9>MI%Wx!=2`jA-MHKTnl@e$+qY4_K6KVDke z`zCjX^alV1x_>3c* z(~aGBBvAdE~&Q=lMU=#w(J9Vm1?e&Yk^fZR<&OC&{FR|+Di=?Ai;fT zTIxtIIR(@JS@H((?SWW$txI9gOG`^3C&R)vSKUR~ES`N%dC(vRyDz{8%X))a!=C2X z|H2jqgx;>Lodi?q?jDK4As@dVV+Mw^pFqFnLCc}h)VFa0@FRuh(K~lglbP@Z*UEq4 zNdtCx>Tz*bea=3Ed|J3@QN{Wns$KTX2taY=lbib-auoIrD3#!>dw-srD_72>NGN@N z7P1gkiDgtzB&)yV87tSr&FwtOBR!`8492O@t2GL|TJmgAI$P4UtuR?s>|{*=(#zL< z#hZ>_4(kUW_q}FUQ8?w5vEhNb815r{uwA`>&->TGjX(*az*2P|l8${dio6hR*O{_6bl%C<=_A(8JplajbH9^4l0P>!~e^le(dT-KL7UpJB4c< zi4lXcB{~^n0;#8uy31L_juQ;OZnxp$v14ttN79(^!z5fAMdG|rRO2t_D6AXXyyV_- zd>0C>S>NIC`wtovL0>RNuK(C}1!9-w3MW__?4@Kkx5C-m16&3xn;IF789kaWBYeJm zVcT-DHg6(GfoLddCOS)E8S4j)0>Bo`?2U~x4u+)BXc50@6H#44gE>Bx%dy>gs<_S= zUkK2nEXNjw93tQEYpMEDy|Xr^;t6vgmEa!q-S-fm!q7LoDD0j%!A9`h>5ssxIsV!l z{23#L4(;2TWjl}&Nd(7;v}q=G%ZG%J!mQX-5oKpqju%m`HB{(xst;l`1CB_cW2pK$ zQC%QuHnIqsX_hB0gdybFx@ftfgk{*SKVMWN*P6BY1^Wftfr`v93ky|v0=%`WI1bj> z^neXOaP+*T@r(jzp~rAu)!n=a=wye+B?}d3edxrnp+n~rzsRD~Q(jDw4i$&OwTCVT zM*49Wk0p3bbDK262(u3fLKiH&Wo4RNG3LhPLdR65g{H7EU=?9?HzWnQ16ys^b{NDt zPVw}-cXs)F8dUEqbw0-yPqUWLtYC1#DVc$P$Rf|4#kebo%L)B0?kw-kaF@~c-=O{h zrSg_mzI$CJ8pwayB!|??-PLzhOf;JkEkty(#rbI-Xi;k{D z)`o=#zAqG7Fj6s(DkqpDe1JDf=0`t{b<5W+Goju}ShljA^B5QgB{^ZVWX+n+cihJt z@JdPlbNO2^Y6ABMk}Ry%WqDIGJu55qnN#`{Ei?N~(uu(wLch;llL(G_(MHIEUu_Tc z0rtVe3kIWjCO$}I>HytA)(_B)2oqyJfYQD=r6f0`c~oHY?km+}K4QW`X zWYA4v7Fh*tR5+VcBAsJ7KV-3nDJYm47%0viDJCGYk850yO{-DV*j7GaQS#7XNqw`6 zidsK>po8Bo)$yA6iHCl1+EeH=mlW}fT(gR^yZ`9;p~hSSi~31rJvXpU#K%u)o&gVp zFt&Nh>gI}or*k809&>{I_^@RDd>XlKy#7p3;qPk}KV#EjTPSDN>xqA3zP;KX!kIMQ z>#lvKdqrkcMdoYm32yFE&!E3?M-H5)ldH8v!tqWE4-6kROqKG{0`38yVtKjZ`N(f5PbWro?l=E16y%UPU?XJ-MlCATK7C}v<7ANXPZf|aX%51(%v_vN=`Y=ehSEpG_E#mlB3bq*re6^(JB}~%b8H-(!-yHC z)*d(R5g~|{O?dSif=aTT&6H74@F=-2SiEeRa5!$uGqBN85C;EU9z4@n2oo6i?o6@*(MIzdxlzRrym?>!Uy2y_RZ-+NE~t%R0Oa?Pp$) zu*~<#&fwHXr&|iA`~Eq8_vzDnYflcIWAUT@(Slh^%NOh}+7g`K(zmFjFuiYXKi_+C zsos7Ye>-$t{G-^#A-DFgygzcB1ik+8Px^bwYbcyd$1R5A-&f5g%BZY;6p|YUwn1R0ma%tZB>#Y^b#Bd9wgqj$sQBh71|V>6f_}t0GEj zi9)HvP!i{@SIwyHfg$^;mQyuzn4aEQ(`&uVZR;aKZHkKcxNTW~R9!`BCX!(&IOu(} zkLb~%LOJEwF_J4vqJCZhk8tf4Ayytl3ljdo?!@@2g zTEC68v&E>Pb4IRfWmjx7Bw?q*+;_WcIpb`$=UPN!sFIG^9(v`L&XJ-b36aoHs78ky zMyyfaLWQuSOYbiXwpjA*Wz-J41BMD2TL}Jy_D?#lSRvrRBbYx()G{^S+BN6M!0tsY z#|Hmqa;B~5(K5m=EQzr~Q&di1&KChfP9cN48b3*ev|~2}5nAk@tgX1kIl#;74%$w= zzOqbQ0G4u&WpS}S4vNwC3?8z|ir%pf0~2I!#L_#ycrXSG5OQ8icM|ymXMkUy*?B3h zFFvk8Qi`=+?W@ipK}~FPtCUW0&u> z7a*0MJ}kxc;+enk5~!)FQjRl-EMjRvZY3IIMP!#3gAP_}=W0f(N+*W#l&S56Ie?%L zO?jz*pW63UbAj}1VjaMSb@5y?x>rux%e5;D_DnrI&FkIn*$TN{l zaYd>--w<@gN_9tjWAov^->M`yTWTzWVBK?bbtHylj=_Adw?F61&p~a}(V548;ztbj zA8+tN2>+T<=%b{i<;VRY_q(ua`6;__<@Sc=!+yu8pwis(1tQ+qxWjS6mde>CjY1H* z>bBV?;I7UMBEK`JFdPija>4fD>)!1C^+OllI&j$QFbV);+(`HN*4Z+naOjExySYaL zG#?%RBjXlT08bv&3j?dc@ZPllDqpPDAaiQE6=xrHMtZ;s@pjYNt3WSp#8Z#{F%Ksh ztNtBiuAUgiS-ih)^J>d_duVHRPxt_G*g&-{p_o(&*kBQa!NByD{NwZRH=*MJ^jEDE z=hD{rBF$a@Z#Y~hN5^{t^OT@=ZT9BP&u~`bj}(IHwl{qFR)qE0S(jqA>*a#KIdot& zUG*+oDGniN=S3Av?mlT$1hNYA8e2{z8Q4>hy6L5szlcw&F_R%=_f8Pic*(0*3k&Bj zr@}49hoK=)7SQ(9#^q86?XSOnyXrh%tooo53_So979alK!dMv<^+aJ-l3TvA^d=IM z&dp9*?Hm>Dq3fFOmG5Qv?}@XOR1kC>DXXhflTR+3|8XLEzy|!om=b7}r;!0DBpc^= zc$$on>o{lqG=_bl|B8vYhp(8dpN3`fp_%k- ze@gXFV=-pgl872#)knl|KVAdQ*&i>T4>4V7m4UH?5XR6IE6haN#>Pv~w<&G3G^f_B zBq8WppxIDeU1E(|RxS<1QB<#U9Qv%Op&@#;r7e*S*F)IZ5}b38jYT3B@7NGO&R_P; z6G^qz`23kEo$dK6H1C;vl1#!EZYC(p3y#1Z#)oFtQm_*12=|ZqUbj{3h6W_0%`u1spXS1d&YrO9 z&~bKRZ1xAcxrM0RHd^xga2y1m{?6;nyXsqHp{pA}3IP^RY!_Qd@_4B8y}Rp_W417C zoR2nR@H8*c|oVxM4fv#@p?{Nq;<(oeC{9M-&=XY#E zBP{&&On5`ae#B_=<~t~gI~saI0#5}ib zPrlQ>S}L@LD5T#q)q)+u`zr8b3-aCdPd#W2H2dTC-_viuW*VfD7CAP>U)!4LUqJ%$ z#tb~|2vvs&Q^%a+{*`q0QDV${_1XNFU`d<-SvnpCf46i}I$8-iQo?QngsXeiGmC;x zGS)#q%}_<=Z2?Zmj;qIgXVKw__YkL3(enbHA|x6lan|Bvy&7-^2{nNyo8IFHV_914 zA4fcB$H)wi@CVV-{A*EpxnI5)Z!Dk1r+qs-)E$y}b14%7%|M|U9&P(gH?S1hl?59u z$zguEmKh!*(YC8@NW}oX$&)i|BFyf8QvD>)tB*Ue*asAsnN(lJ>gi6QHq sc#wT$c;qqK2KHb#9;}4H|NgksR9Y=3??aU2C=s8D<2{^<9sOhe4`JvAZ~y=R literal 0 HcmV?d00001 diff --git a/plugins/Generators_CAS/generators.irp.f b/plugins/Generators_CAS/generators.irp.f index f47341de..10fbfaee 100644 --- a/plugins/Generators_CAS/generators.irp.f +++ b/plugins/Generators_CAS/generators.irp.f @@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ] logical :: good call write_time(output_determinants) N_det_generators = 0 - do i=1,N_det + do i=1,N_det_ref do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) ) enddo if (good) then @@ -41,14 +41,14 @@ END_PROVIDER integer :: i, k, l, m logical :: good m=0 - do i=1,N_det + do i=1,N_det_ref do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -58,8 +58,8 @@ END_PROVIDER if (good) then m = m+1 do k=1,N_int - psi_det_generators(k,1,m) = psi_det(k,1,i) - psi_det_generators(k,2,m) = psi_det(k,2,i) + psi_det_generators(k,1,m) = psi_ref(k,1,i) + psi_det_generators(k,2,m) = psi_ref(k,2,i) enddo psi_coef_generators(m,:) = psi_coef(m,:) endif diff --git a/plugins/Integrals_erf/EZFIO.cfg b/plugins/Integrals_erf/EZFIO.cfg new file mode 100644 index 00000000..916bcd34 --- /dev/null +++ b/plugins/Integrals_erf/EZFIO.cfg @@ -0,0 +1,34 @@ +[disk_access_ao_integrals_erf] +type: Disk_access +doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + + +[disk_access_mo_integrals_erf] +type: Disk_access +doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[ao_integrals_threshold] +type: Threshold +doc: If || < ao_integrals_threshold then is zero +interface: ezfio,provider,ocaml +default: 1.e-15 +ezfio_name: threshold_ao + +[mo_integrals_threshold] +type: Threshold +doc: If || < ao_integrals_threshold then is zero +interface: ezfio,provider,ocaml +default: 1.e-15 +ezfio_name: threshold_mo + +[mu_erf] +type: double precision +doc: cutting of the interaction in the range separated model +interface: ezfio,provider,ocaml +default: 0.5 +ezfio_name: mu_erf + diff --git a/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES b/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..8361b2eb --- /dev/null +++ b/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Pseudo Bitmask ZMQ Integrals_Bielec diff --git a/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f b/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f new file mode 100644 index 00000000..2b4b2fad --- /dev/null +++ b/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f @@ -0,0 +1,570 @@ +double precision function ao_bielec_integral_erf(i,j,k,l) + implicit none + BEGIN_DOC + ! integral of the AO basis or (ij|kl) + ! i(r1) j(r1) 1/r12 k(r2) l(r2) + END_DOC + + integer,intent(in) :: i,j,k,l + integer :: p,q,r,s + double precision :: I_center(3),J_center(3),K_center(3),L_center(3) + integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) + double precision :: integral + include 'Utils/constants.include.F' + double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp + double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq + integer :: iorder_p(3), iorder_q(3) + double precision :: ao_bielec_integral_schwartz_accel_erf + + if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then + ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l) + return + endif + + dim1 = n_pt_max_integrals + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + ao_bielec_integral_erf = 0.d0 + + if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + I_center(p) = nucl_coord(num_i,p) + J_center(p) = nucl_coord(num_j,p) + K_center(p) = nucl_coord(num_k,p) + L_center(p) = nucl_coord(num_l,p) + enddo + + double precision :: coef1, coef2, coef3, coef4 + double precision :: p_inv,q_inv + double precision :: general_primitive_integral_erf + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & + I_power,J_power,I_center,J_center,dim1) + p_inv = 1.d0/pp + do r = 1, ao_prim_num(k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & + K_power,L_power,K_center,L_center,dim1) + q_inv = 1.d0/qq + integral = general_primitive_integral_erf(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) + ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + else + + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + enddo + double precision :: ERI_erf + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + do r = 1, ao_prim_num(k) + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + integral = ERI_erf( & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& + I_power(1),J_power(1),K_power(1),L_power(1), & + I_power(2),J_power(2),K_power(2),L_power(2), & + I_power(3),J_power(3),K_power(3),L_power(3)) + ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + endif + +end + +double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l) + implicit none + BEGIN_DOC + ! integral of the AO basis or (ij|kl) + ! i(r1) j(r1) 1/r12 k(r2) l(r2) + END_DOC + integer,intent(in) :: i,j,k,l + integer :: p,q,r,s + double precision :: I_center(3),J_center(3),K_center(3),L_center(3) + integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) + double precision :: integral + include 'Utils/constants.include.F' + double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp + double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq + integer :: iorder_p(3), iorder_q(3) + double precision, allocatable :: schwartz_kl(:,:) + double precision :: schwartz_ij + + dim1 = n_pt_max_integrals + + num_i = ao_nucl(i) + num_j = ao_nucl(j) + num_k = ao_nucl(k) + num_l = ao_nucl(l) + ao_bielec_integral_schwartz_accel_erf = 0.d0 + double precision :: thr + thr = ao_integrals_threshold*ao_integrals_threshold + + allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k))) + + + if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + I_center(p) = nucl_coord(num_i,p) + J_center(p) = nucl_coord(num_j,p) + K_center(p) = nucl_coord(num_k,p) + L_center(p) = nucl_coord(num_l,p) + enddo + + schwartz_kl(0,0) = 0.d0 + do r = 1, ao_prim_num(k) + coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) + schwartz_kl(0,r) = 0.d0 + do s = 1, ao_prim_num(l) + coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l) + call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & + K_power,L_power,K_center,L_center,dim1) + q_inv = 1.d0/qq + schwartz_kl(s,r) = general_primitive_integral_erf(dim1, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) & + * coef2 + schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) + enddo + schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) + enddo + + do p = 1, ao_prim_num(i) + double precision :: coef1 + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + double precision :: coef2 + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + double precision :: p_inv,q_inv + call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & + I_power,J_power,I_center,J_center,dim1) + p_inv = 1.d0/pp + schwartz_ij = general_primitive_integral_erf(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + P_new,P_center,fact_p,pp,p_inv,iorder_p) * & + coef2*coef2 + if (schwartz_kl(0,0)*schwartz_ij < thr) then + cycle + endif + do r = 1, ao_prim_num(k) + if (schwartz_kl(0,r)*schwartz_ij < thr) then + cycle + endif + double precision :: coef3 + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + double precision :: coef4 + if (schwartz_kl(s,r)*schwartz_ij < thr) then + cycle + endif + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + double precision :: general_primitive_integral_erf + call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & + K_power,L_power,K_center,L_center,dim1) + q_inv = 1.d0/qq + integral = general_primitive_integral_erf(dim1, & + P_new,P_center,fact_p,pp,p_inv,iorder_p, & + Q_new,Q_center,fact_q,qq,q_inv,iorder_q) + ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + else + + do p = 1, 3 + I_power(p) = ao_power(i,p) + J_power(p) = ao_power(j,p) + K_power(p) = ao_power(k,p) + L_power(p) = ao_power(l,p) + enddo + double precision :: ERI_erf + + schwartz_kl(0,0) = 0.d0 + do r = 1, ao_prim_num(k) + coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) + schwartz_kl(0,r) = 0.d0 + do s = 1, ao_prim_num(l) + coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l) + schwartz_kl(s,r) = ERI_erf( & + ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& + K_power(1),L_power(1),K_power(1),L_power(1), & + K_power(2),L_power(2),K_power(2),L_power(2), & + K_power(3),L_power(3),K_power(3),L_power(3)) * & + coef2 + schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) + enddo + schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) + enddo + + do p = 1, ao_prim_num(i) + coef1 = ao_coef_normalized_ordered_transp(p,i) + do q = 1, ao_prim_num(j) + coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) + schwartz_ij = ERI_erf( & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),& + I_power(1),J_power(1),I_power(1),J_power(1), & + I_power(2),J_power(2),I_power(2),J_power(2), & + I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2 + if (schwartz_kl(0,0)*schwartz_ij < thr) then + cycle + endif + do r = 1, ao_prim_num(k) + if (schwartz_kl(0,r)*schwartz_ij < thr) then + cycle + endif + coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) + do s = 1, ao_prim_num(l) + if (schwartz_kl(s,r)*schwartz_ij < thr) then + cycle + endif + coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) + integral = ERI_erf( & + ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& + I_power(1),J_power(1),K_power(1),L_power(1), & + I_power(2),J_power(2),K_power(2),L_power(2), & + I_power(3),J_power(3),K_power(3),L_power(3)) + ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral + enddo ! s + enddo ! r + enddo ! q + enddo ! p + + endif + deallocate (schwartz_kl) + +end + + +subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value) + implicit none + use map_module + + BEGIN_DOC + ! Compute AO 1/r12 integrals for all i and fixed j,k,l + END_DOC + + include 'Utils/constants.include.F' + integer, intent(in) :: j,k,l,sze + real(integral_kind), intent(out) :: buffer_value(sze) + double precision :: ao_bielec_integral_erf + + integer :: i + + if (ao_overlap_abs(j,l) < thresh) then + buffer_value = 0._integral_kind + return + endif + if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then + buffer_value = 0._integral_kind + return + endif + + do i = 1, ao_num + if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then + buffer_value(i) = 0._integral_kind + cycle + endif + if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then + buffer_value(i) = 0._integral_kind + cycle + endif + !DIR$ FORCEINLINE + buffer_value(i) = ao_bielec_integral_erf(i,k,j,l) + enddo + +end + +double precision function general_primitive_integral_erf(dim, & + P_new,P_center,fact_p,p,p_inv,iorder_p, & + Q_new,Q_center,fact_q,q,q_inv,iorder_q) + implicit none + BEGIN_DOC + ! Computes the integral where p,q,r,s are Gaussian primitives + END_DOC + integer,intent(in) :: dim + include 'Utils/constants.include.F' + double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv + double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv + integer, intent(in) :: iorder_p(3) + integer, intent(in) :: iorder_q(3) + + double precision :: r_cut,gama_r_cut,rho,dist + double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim) + integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz + double precision :: bla + integer :: ix,iy,iz,jx,jy,jz,i + double precision :: a,b,c,d,e,f,accu,pq,const + double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2 + integer :: n_pt_tmp,n_pt_out, iorder + double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim) + + general_primitive_integral_erf = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly + + ! Gaussian Product + ! ---------------- + double precision :: p_plus_q + p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) + pq = p_inv*0.5d0*q_inv + + pq_inv = 0.5d0/p_plus_q + p10_1 = q*pq ! 1/(2p) + p01_1 = p*pq ! 1/(2q) + pq_inv_2 = pq_inv+pq_inv + p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p) + p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq) + + + accu = 0.d0 + iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1) + !DIR$ VECTOR ALIGNED + do ix=0,iorder + Ix_pol(ix) = 0.d0 + enddo + n_Ix = 0 + do ix = 0, iorder_p(1) + if (abs(P_new(ix,1)) < thresh) cycle + a = P_new(ix,1) + do jx = 0, iorder_q(1) + d = a*Q_new(jx,1) + if (abs(d) < thresh) cycle + !DEC$ FORCEINLINE + call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx) + !DEC$ FORCEINLINE + call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix) + enddo + enddo + if (n_Ix == -1) then + return + endif + iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2) + !DIR$ VECTOR ALIGNED + do ix=0, iorder + Iy_pol(ix) = 0.d0 + enddo + n_Iy = 0 + do iy = 0, iorder_p(2) + if (abs(P_new(iy,2)) > thresh) then + b = P_new(iy,2) + do jy = 0, iorder_q(2) + e = b*Q_new(jy,2) + if (abs(e) < thresh) cycle + !DEC$ FORCEINLINE + call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny) + !DEC$ FORCEINLINE + call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy) + enddo + endif + enddo + if (n_Iy == -1) then + return + endif + + iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3) + do ix=0,iorder + Iz_pol(ix) = 0.d0 + enddo + n_Iz = 0 + do iz = 0, iorder_p(3) + if (abs(P_new(iz,3)) > thresh) then + c = P_new(iz,3) + do jz = 0, iorder_q(3) + f = c*Q_new(jz,3) + if (abs(f) < thresh) cycle + !DEC$ FORCEINLINE + call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz) + !DEC$ FORCEINLINE + call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz) + enddo + endif + enddo + if (n_Iz == -1) then + return + endif + + rho = p*q *pq_inv_2 ! le rho qui va bien + dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + & + (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + & + (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3)) + const = dist*rho + + n_pt_tmp = n_Ix+n_Iy + do i=0,n_pt_tmp + d_poly(i)=0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) + if (n_pt_tmp == -1) then + return + endif + n_pt_out = n_pt_tmp+n_Iz + do i=0,n_pt_out + d1(i)=0.d0 + enddo + + !DEC$ FORCEINLINE + call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) + double precision :: rint_sum + accu = accu + rint_sum(n_pt_out,const,d1) + + ! change p+q in dsqrt + general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q) +end + + +double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z) + implicit none + BEGIN_DOC + ! ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: + ! primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) + ! primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) + ! primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2) + ! primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2) + END_DOC + double precision, intent(in) :: delta,gama,alpha,beta + integer, intent(in) :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z + integer :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2 + integer :: i,j,k,l,n_pt + integer :: n_pt_sup + double precision :: p,q,denom,coeff + double precision :: I_f + integer :: nx,ny,nz + include 'Utils/constants.include.F' + nx = a_x+b_x+c_x+d_x + if(iand(nx,1) == 1) then + ERI_erf = 0.d0 + return + endif + + ny = a_y+b_y+c_y+d_y + if(iand(ny,1) == 1) then + ERI_erf = 0.d0 + return + endif + + nz = a_z+b_z+c_z+d_z + if(iand(nz,1) == 1) then + ERI_erf = 0.d0 + return + endif + + ASSERT (alpha >= 0.d0) + ASSERT (beta >= 0.d0) + ASSERT (delta >= 0.d0) + ASSERT (gama >= 0.d0) + p = alpha + beta + q = delta + gama + double precision :: p_plus_q + p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) + ASSERT (p+q >= 0.d0) + n_pt = ishft( nx+ny+nz,1 ) + + coeff = pi_5_2 / (p * q * dsqrt(p_plus_q)) + if (n_pt == 0) then + ERI_erf = coeff + return + endif + + call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt) + + ERI_erf = I_f * coeff +end + + + + +subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) + implicit none + use map_module + BEGIN_DOC + ! Parallel client for AO integrals + END_DOC + + integer, intent(in) :: j,l + integer,intent(out) :: n_integrals + integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) + real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) + + integer :: i,k + double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 + double precision :: integral, wall_0 + double precision :: thr + integer :: kk, m, j1, i1 + + thr = ao_integrals_threshold + + n_integrals = 0 + + j1 = j+ishft(l*l-l,-1) + do k = 1, ao_num ! r1 + i1 = ishft(k*k-k,-1) + if (i1 > j1) then + exit + endif + do i = 1, k + i1 += 1 + if (i1 > j1) then + exit + endif + if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then + cycle + endif + if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then + cycle + endif + !DIR$ FORCEINLINE + integral = ao_bielec_integral_erf(i,k,j,l) ! i,k : r1 j,l : r2 + if (abs(integral) < thr) then + cycle + endif + n_integrals += 1 + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) + buffer_value(n_integrals) = integral + enddo + enddo + +end diff --git a/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f b/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f new file mode 100644 index 00000000..36f0e492 --- /dev/null +++ b/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f @@ -0,0 +1,175 @@ +subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Computes a buffer of integrals. i is the ID of the current thread. + END_DOC + call ao_bielec_integrals_erf_in_map_slave(0,i) +end + + +subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i) + implicit none + integer, intent(in) :: i + BEGIN_DOC +! Computes a buffer of integrals. i is the ID of the current thread. + END_DOC + call ao_bielec_integrals_erf_in_map_slave(1,i) +end + + + +subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc) + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Computes a buffer of integrals + END_DOC + + integer, intent(in) :: thread, iproc + + integer :: j,l,n_integrals + integer :: rc + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + integer :: worker_id, task_id + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + character*(64) :: state + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + + allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) + + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) + if (task_id == 0) exit + read(task,*) j, l + call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) + call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) + enddo + + + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + deallocate( buffer_i, buffer_value ) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + +end + + +subroutine ao_bielec_integrals_erf_in_map_collector + use map_module + use f77_zmq + implicit none + BEGIN_DOC +! Collects results from the AO integral calculation + END_DOC + + integer :: j,l,n_integrals + integer :: rc + + real(integral_kind), allocatable :: buffer_value(:) + integer(key_kind), allocatable :: buffer_i(:) + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_pull_socket + integer(ZMQ_PTR) :: zmq_socket_pull + + integer*8 :: control, accu + integer :: task_id, more, sze + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_pull = new_zmq_pull_socket() + + sze = ao_num*ao_num + allocate ( buffer_i(sze), buffer_value(sze) ) + + accu = 0_8 + more = 1 + do while (more == 1) + + rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) + if (rc == -1) then + n_integrals = 0 + return + endif + if (rc /= 4) then + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' + stop 'error' + endif + + if (n_integrals >= 0) then + + if (n_integrals > sze) then + deallocate (buffer_value, buffer_i) + sze = n_integrals + allocate (buffer_value(sze), buffer_i(sze)) + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) + if (rc /= key_kind*n_integrals) then + print *, rc, key_kind, n_integrals + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) + if (rc /= integral_kind*n_integrals) then + print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' + stop 'error' + endif + + rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) + +! Activate if zmq_socket_pull is a REP + rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) + if (rc /= 4) then + print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' + stop 'error' + endif + + + call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value) + accu += n_integrals + if (task_id /= 0) then + call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) + endif + endif + + enddo + + deallocate( buffer_i, buffer_value ) + + integer (map_size_kind) :: get_ao_erf_map_size + control = get_ao_erf_map_size(ao_integrals_erf_map) + + if (control /= accu) then + print *, '' + print *, irp_here + print *, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation.' + print *, 'Try to reduce the number of threads.' + stop + endif + + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_pull_socket(zmq_socket_pull) + +end + diff --git a/plugins/Integrals_erf/integrals_3_index_erf.irp.f b/plugins/Integrals_erf/integrals_3_index_erf.irp.f new file mode 100644 index 00000000..d9b1e9f7 --- /dev/null +++ b/plugins/Integrals_erf/integrals_3_index_erf.irp.f @@ -0,0 +1,22 @@ + BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)] +&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)] + implicit none + integer :: i,j,k,l + double precision :: get_mo_bielec_integral_erf + double precision :: integral + + do k = 1, mo_tot_num + do i = 1, mo_tot_num + do j = 1, mo_tot_num + l = j + integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) + big_array_coulomb_integrals_erf(j,i,k) = integral + l = j + integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map) + big_array_exchange_integrals_erf(j,i,k) = integral + enddo + enddo + enddo + + +END_PROVIDER diff --git a/plugins/Integrals_erf/map_integrals_erf.irp.f b/plugins/Integrals_erf/map_integrals_erf.irp.f new file mode 100644 index 00000000..ecf72282 --- /dev/null +++ b/plugins/Integrals_erf/map_integrals_erf.irp.f @@ -0,0 +1,626 @@ +use map_module + +!! AO Map +!! ====== + +BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ] + implicit none + BEGIN_DOC + ! AO integrals + END_DOC + integer(key_kind) :: key_max + integer(map_size_kind) :: sze + call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) + sze = key_max + call map_init(ao_integrals_erf_map,sze) + print*, 'AO map initialized : ', sze +END_PROVIDER + + BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ] +&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ] + implicit none + BEGIN_DOC + ! Min and max values of the AOs for which the integrals are in the cache + END_DOC + ao_integrals_erf_cache_min = max(1,ao_num - 63) + ao_integrals_erf_cache_max = ao_num + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ] + use map_module + implicit none + BEGIN_DOC + ! Cache of AO integrals for fast access + END_DOC + PROVIDE ao_bielec_integrals_erf_in_map + integer :: i,j,k,l,ii + integer(key_kind) :: idx + real(integral_kind) :: integral + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) + do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max + do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max + do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max + do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(ao_integrals_erf_map,idx,integral) + ii = l-ao_integrals_erf_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) + ao_integrals_erf_cache(ii) = integral + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + +double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result) + use map_module + implicit none + BEGIN_DOC + ! Gets one AO bi-electronic integral from the AO map + END_DOC + integer, intent(in) :: i,j,k,l + integer(key_kind) :: idx + type(map_type), intent(inout) :: map + integer :: ii + real(integral_kind) :: tmp + PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min + !DIR$ FORCEINLINE + if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then + tmp = 0.d0 + else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then + tmp = 0.d0 + else + ii = l-ao_integrals_erf_cache_min + ii = ior(ii, k-ao_integrals_erf_cache_min) + ii = ior(ii, j-ao_integrals_erf_cache_min) + ii = ior(ii, i-ao_integrals_erf_cache_min) + if (iand(ii, -64) /= 0) then + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + tmp = tmp + else + ii = l-ao_integrals_erf_cache_min + ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) + ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) + ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) + tmp = ao_integrals_erf_cache(ii) + endif + endif + result = tmp +end + + +subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val) + use map_module + BEGIN_DOC + ! Gets multiple AO bi-electronic integral from the AO map . + ! All i are retrieved for j,k,l fixed. + END_DOC + implicit none + integer, intent(in) :: j,k,l, sze + real(integral_kind), intent(out) :: out_val(sze) + + integer :: i + integer(key_kind) :: hash + double precision :: thresh + PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map + thresh = ao_integrals_threshold + + if (ao_overlap_abs(j,l) < thresh) then + out_val = 0.d0 + return + endif + + double precision :: get_ao_bielec_integral_erf + do i=1,sze + out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map) + enddo + +end + +subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int) + use map_module + implicit none + BEGIN_DOC + ! Gets multiple AO bi-electronic integral from the AO map . + ! All non-zero i are retrieved for j,k,l fixed. + END_DOC + integer, intent(in) :: j,k,l, sze + real(integral_kind), intent(out) :: out_val(sze) + integer, intent(out) :: out_val_index(sze),non_zero_int + + integer :: i + integer(key_kind) :: hash + double precision :: thresh,tmp + PROVIDE ao_bielec_integrals_erf_in_map + thresh = ao_integrals_threshold + + non_zero_int = 0 + if (ao_overlap_abs(j,l) < thresh) then + out_val = 0.d0 + return + endif + + non_zero_int = 0 + do i=1,sze + integer, external :: ao_l4 + double precision, external :: ao_bielec_integral_erf + !DIR$ FORCEINLINE + if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then + cycle + endif + call bielec_integrals_index(i,j,k,l,hash) + call map_get(ao_integrals_erf_map, hash,tmp) + if (dabs(tmp) < thresh ) cycle + non_zero_int = non_zero_int+1 + out_val_index(non_zero_int) = i + out_val(non_zero_int) = tmp + enddo + +end + + +function get_ao_erf_map_size() + implicit none + integer (map_size_kind) :: get_ao_erf_map_size + BEGIN_DOC + ! Returns the number of elements in the AO map + END_DOC + get_ao_erf_map_size = ao_integrals_erf_map % n_elements +end + +subroutine clear_ao_erf_map + implicit none + BEGIN_DOC + ! Frees the memory of the AO map + END_DOC + call map_deinit(ao_integrals_erf_map) + FREE ao_integrals_erf_map +end + + + +BEGIN_TEMPLATE + +subroutine dump_$ao_integrals(filename) + use map_module + implicit none + BEGIN_DOC + ! Save to disk the $ao integrals + END_DOC + character*(*), intent(in) :: filename + integer(cache_key_kind), pointer :: key(:) + real(integral_kind), pointer :: val(:) + integer*8 :: i,j, n + call ezfio_set_work_empty(.False.) + open(unit=66,file=filename,FORM='unformatted') + write(66) integral_kind, key_kind + write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size, & + $ao_integrals_map%n_elements + do i=0_8,$ao_integrals_map%map_size + write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,& + $ao_integrals_map%map(i)%n_elements + enddo + do i=0_8,$ao_integrals_map%map_size + key => $ao_integrals_map%map(i)%key + val => $ao_integrals_map%map(i)%value + n = $ao_integrals_map%map(i)%n_elements + write(66) (key(j), j=1,n), (val(j), j=1,n) + enddo + close(66) + +end + +IRP_IF COARRAY +subroutine communicate_$ao_integrals() + use map_module + implicit none + BEGIN_DOC + ! Communicate the $ao integrals with co-array + END_DOC + integer(cache_key_kind), pointer :: key(:) + real(integral_kind), pointer :: val(:) + integer*8 :: i,j, k, nmax + integer*8, save :: n[*] + integer :: copy_n + + real(integral_kind), allocatable :: buffer_val(:)[:] + integer(cache_key_kind), allocatable :: buffer_key(:)[:] + real(integral_kind), allocatable :: copy_val(:) + integer(key_kind), allocatable :: copy_key(:) + + n = 0_8 + do i=0_8,$ao_integrals_map%map_size + n = max(n,$ao_integrals_map%map(i)%n_elements) + enddo + sync all + nmax = 0_8 + do j=1,num_images() + nmax = max(nmax,n[j]) + enddo + allocate( buffer_key(nmax)[*], buffer_val(nmax)[*]) + allocate( copy_key(nmax), copy_val(nmax)) + do i=0_8,$ao_integrals_map%map_size + key => $ao_integrals_map%map(i)%key + val => $ao_integrals_map%map(i)%value + n = $ao_integrals_map%map(i)%n_elements + do j=1,n + buffer_key(j) = key(j) + buffer_val(j) = val(j) + enddo + sync all + do j=1,num_images() + if (j /= this_image()) then + copy_n = n[j] + do k=1,copy_n + copy_val(k) = buffer_val(k)[j] + copy_key(k) = buffer_key(k)[j] + copy_key(k) = copy_key(k)+ishft(i,-map_shift) + enddo + call map_append($ao_integrals_map, copy_key, copy_val, copy_n ) + endif + enddo + sync all + enddo + deallocate( buffer_key, buffer_val, copy_val, copy_key) + +end +IRP_ENDIF + + +integer function load_$ao_integrals(filename) + implicit none + BEGIN_DOC + ! Read from disk the $ao integrals + END_DOC + character*(*), intent(in) :: filename + integer*8 :: i + integer(cache_key_kind), pointer :: key(:) + real(integral_kind), pointer :: val(:) + integer :: iknd, kknd + integer*8 :: n, j + load_$ao_integrals = 1 + open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') + read(66,err=98,end=98) iknd, kknd + if (iknd /= integral_kind) then + print *, 'Wrong integrals kind in file :', iknd + stop 1 + endif + if (kknd /= key_kind) then + print *, 'Wrong key kind in file :', kknd + stop 1 + endif + read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,& + $ao_integrals_map%n_elements + do i=0_8, $ao_integrals_map%map_size + read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted, & + $ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements + call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size) + enddo + do i=0_8, $ao_integrals_map%map_size + key => $ao_integrals_map%map(i)%key + val => $ao_integrals_map%map(i)%value + n = $ao_integrals_map%map(i)%n_elements + read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n) + enddo + call map_sort($ao_integrals_map) + load_$ao_integrals = 0 + return + 99 continue + call map_deinit($ao_integrals_map) + 98 continue + stop 'Problem reading $ao_integrals_map file in work/' + +end + +SUBST [ ao_integrals_map, ao_integrals, ao_num ] +ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;; +mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;; +END_TEMPLATE + + + + +BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ] + implicit none + BEGIN_DOC + ! MO integrals + END_DOC + integer(key_kind) :: key_max + integer(map_size_kind) :: sze + call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) + sze = key_max + call map_init(mo_integrals_erf_map,sze) + print*, 'MO map initialized' +END_PROVIDER + +subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values) + use map_module + implicit none + BEGIN_DOC + ! Create new entry into AO map + END_DOC + + integer, intent(in) :: n_integrals + integer(key_kind), intent(inout) :: buffer_i(n_integrals) + real(integral_kind), intent(inout) :: buffer_values(n_integrals) + + call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals) +end + +subroutine insert_into_mo_integrals_erf_map(n_integrals, & + buffer_i, buffer_values, thr) + use map_module + implicit none + + BEGIN_DOC + ! Create new entry into MO map, or accumulate in an existing entry + END_DOC + + integer, intent(in) :: n_integrals + integer(key_kind), intent(inout) :: buffer_i(n_integrals) + real(integral_kind), intent(inout) :: buffer_values(n_integrals) + real(integral_kind), intent(in) :: thr + call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr) +end + + BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ] +&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ] + implicit none + BEGIN_DOC + ! Min and max values of the MOs for which the integrals are in the cache + END_DOC + mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31) + mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ] + implicit none + BEGIN_DOC + ! Cache of MO integrals for fast access + END_DOC + PROVIDE mo_bielec_integrals_erf_in_map + integer :: i,j,k,l + integer :: ii + integer(key_kind) :: idx + real(integral_kind) :: integral + FREE ao_integrals_erf_cache + !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) + do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max + do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max + do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max + do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(mo_integrals_erf_map,idx,integral) + ii = l-mo_integrals_erf_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) + mo_integrals_erf_cache(ii) = integral + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + +double precision function get_mo_bielec_integral_erf(i,j,k,l,map) + use map_module + implicit none + BEGIN_DOC + ! Returns one integral in the MO basis + END_DOC + integer, intent(in) :: i,j,k,l + integer(key_kind) :: idx + integer :: ii + type(map_type), intent(inout) :: map + real(integral_kind) :: tmp + PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache + ii = l-mo_integrals_erf_cache_min + ii = ior(ii, k-mo_integrals_erf_cache_min) + ii = ior(ii, j-mo_integrals_erf_cache_min) + ii = ior(ii, i-mo_integrals_erf_cache_min) + if (iand(ii, -64) /= 0) then + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,idx) + !DIR$ FORCEINLINE + call map_get(map,idx,tmp) + get_mo_bielec_integral_erf = dble(tmp) + else + ii = l-mo_integrals_erf_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) + get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii) + endif +end + + +double precision function mo_bielec_integral_erf(i,j,k,l) + implicit none + BEGIN_DOC + ! Returns one integral in the MO basis + END_DOC + integer, intent(in) :: i,j,k,l + double precision :: get_mo_bielec_integral_erf + PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache + !DIR$ FORCEINLINE + PROVIDE mo_bielec_integrals_erf_in_map + mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) + return +end + +subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals in the MO basis, all + ! i for j,k,l fixed. + END_DOC + integer, intent(in) :: j,k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE mo_bielec_integrals_erf_in_map + + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(map, hash, out_val, sze) + else + call map_get_many(map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + +subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals in the MO basis, all + ! i(1)j(2) 1/r12 k(1)l(2) + ! i, j for k,l fixed. + END_DOC + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_array(sze,sze) + type(map_type), intent(inout) :: map + integer :: i,j,kk,ll,m + integer(key_kind),allocatable :: hash(:) + integer ,allocatable :: pairs(:,:), iorder(:) + real(integral_kind), allocatable :: tmp_val(:) + + PROVIDE mo_bielec_integrals_erf_in_map + allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), & + tmp_val(sze*sze)) + + kk=0 + out_array = 0.d0 + do j=1,sze + do i=1,sze + kk += 1 + !DIR$ FORCEINLINE + call bielec_integrals_index(i,j,k,l,hash(kk)) + pairs(1,kk) = i + pairs(2,kk) = j + iorder(kk) = kk + enddo + enddo + + logical :: integral_is_in_map + if (key_kind == 8) then + call i8radix_sort(hash,iorder,kk,-1) + else if (key_kind == 4) then + call iradix_sort(hash,iorder,kk,-1) + else if (key_kind == 2) then + call i2radix_sort(hash,iorder,kk,-1) + endif + + call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) + + do ll=1,kk + m = iorder(ll) + i=pairs(1,m) + j=pairs(2,m) + out_array(i,j) = tmp_val(ll) + enddo + + deallocate(pairs,hash,iorder,tmp_val) +end + +subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals + ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1) + ! for k,l fixed. + END_DOC + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE mo_bielec_integrals_erf_in_map + + integer :: kk + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(k,i,l,i,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(map, hash, out_val, sze) + else + call map_get_many(map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + +subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map) + use map_module + implicit none + BEGIN_DOC + ! Returns multiple integrals + ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1) + ! for k,l fixed. + END_DOC + integer, intent(in) :: k,l, sze + double precision, intent(out) :: out_val(sze) + type(map_type), intent(inout) :: map + integer :: i + integer(key_kind) :: hash(sze) + real(integral_kind) :: tmp_val(sze) + PROVIDE mo_bielec_integrals_erf_in_map + + integer :: kk + do i=1,sze + !DIR$ FORCEINLINE + call bielec_integrals_index(k,i,i,l,hash(i)) + enddo + + if (key_kind == 8) then + call map_get_many(map, hash, out_val, sze) + else + call map_get_many(map, hash, tmp_val, sze) + ! Conversion to double precision + do i=1,sze + out_val(i) = dble(tmp_val(i)) + enddo + endif +end + + +integer*8 function get_mo_erf_map_size() + implicit none + BEGIN_DOC + ! Return the number of elements in the MO map + END_DOC + get_mo_erf_map_size = mo_integrals_erf_map % n_elements +end diff --git a/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f b/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f new file mode 100644 index 00000000..b0c954c1 --- /dev/null +++ b/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f @@ -0,0 +1,616 @@ +subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1) + use map_module + implicit none + BEGIN_DOC + ! Computes an unique index for i,j,k,l integrals + END_DOC + integer, intent(in) :: i,j,k,l + integer(key_kind), intent(out) :: i1 + integer(key_kind) :: p,q,r,s,i2 + p = min(i,k) + r = max(i,k) + p = p+ishft(r*r-r,-1) + q = min(j,l) + s = max(j,l) + q = q+ishft(s*s-s,-1) + i1 = min(p,q) + i2 = max(p,q) + i1 = i1+ishft(i2*i2-i2,-1) +end + + +BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ] + use map_module + implicit none + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) + + BEGIN_DOC + ! If True, the map of MO bielectronic integrals is provided + END_DOC + + mo_bielec_integrals_erf_in_map = .True. + if (read_mo_integrals_erf) then + print*,'Reading the MO integrals_erf' + call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) + print*, 'MO integrals_erf provided' + return + else + PROVIDE ao_bielec_integrals_erf_in_map + endif + + !if(no_vvvv_integrals)then + ! integer :: i,j,k,l + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! + ! ! (core+inact+act) ^ 4 + ! ! + ! print*, '' + ! print*, '' + ! do i = 1,N_int + ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) + ! enddo + ! call add_integrals_to_map(mask_ijkl) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! + ! ! (core+inact+act) ^ 2 (virt) ^2 + ! ! = J_iv + ! print*, '' + ! print*, '' + ! do i = 1,N_int + ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,2) = virt_bitmask(i,1) + ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,4) = virt_bitmask(i,1) + ! enddo + ! call add_integrals_to_map(mask_ijkl) + ! + ! ! (core+inact+act) ^ 2 (virt) ^2 + ! ! = (iv|iv) + ! print*, '' + ! print*, '' + ! do i = 1,N_int + ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,3) = virt_bitmask(i,1) + ! mask_ijkl(i,4) = virt_bitmask(i,1) + ! enddo + ! call add_integrals_to_map(mask_ijkl) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! + ! if(.not.no_vvv_integrals)then + ! print*, '' + ! print*, ' and ' + ! do i = 1,N_int + ! mask_ijk(i,1) = virt_bitmask(i,1) + ! mask_ijk(i,2) = virt_bitmask(i,1) + ! mask_ijk(i,3) = virt_bitmask(i,1) + ! enddo + ! call add_integrals_to_map_three_indices(mask_ijk) + ! endif + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! + ! ! (core+inact+act) ^ 3 (virt) ^1 + ! ! + ! print*, '' + ! print*, '' + ! do i = 1,N_int + ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,4) = virt_bitmask(i,1) + ! enddo + ! call add_integrals_to_map(mask_ijkl) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! + ! ! (core+inact+act) ^ 1 (virt) ^3 + ! ! + ! if(.not.no_ivvv_integrals)then + ! print*, '' + ! print*, '' + ! do i = 1,N_int + ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + ! mask_ijkl(i,2) = virt_bitmask(i,1) + ! mask_ijkl(i,3) = virt_bitmask(i,1) + ! mask_ijkl(i,4) = virt_bitmask(i,1) + ! enddo + ! call add_integrals_to_map_no_exit_34(mask_ijkl) + ! endif + ! + !else + call add_integrals_erf_to_map(full_ijkl_bitmask_4) + !endif + if (write_mo_integrals_erf) then + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) + call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read") + endif + +END_PROVIDER + +subroutine add_integrals_erf_to_map(mask_ijkl) + use bitmasks + implicit none + + BEGIN_DOC + ! Adds integrals to tha MO map according to some bitmask + END_DOC + + integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) + + integer :: i,j,k,l + integer :: i0,j0,k0,l0 + double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 + + integer, allocatable :: list_ijkl(:,:) + integer :: n_i, n_j, n_k, n_l + integer, allocatable :: bielec_tmp_0_idx(:) + real(integral_kind), allocatable :: bielec_tmp_0(:,:) + double precision, allocatable :: bielec_tmp_1(:) + double precision, allocatable :: bielec_tmp_2(:,:) + double precision, allocatable :: bielec_tmp_3(:,:,:) + !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 + + integer :: n_integrals + integer :: size_buffer + integer(key_kind),allocatable :: buffer_i(:) + real(integral_kind),allocatable :: buffer_value(:) + real :: map_mb + + integer :: i1,j1,k1,l1, ii1, kmax, thread_num + integer :: i2,i3,i4 + double precision,parameter :: thr_coef = 1.d-10 + + PROVIDE ao_bielec_integrals_erf_in_map mo_coef + + !Get list of MOs for i,j,k and l + !------------------------------- + + allocate(list_ijkl(mo_tot_num,4)) + call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) + call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) + call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) + call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) + character*(2048) :: output(1) + print*, 'i' + call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,1)) + enddo + if(j==0)then + return + endif + + print*, 'j' + call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,2)) + enddo + if(j==0)then + return + endif + + print*, 'k' + call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,3)) + enddo + if(j==0)then + return + endif + + print*, 'l' + call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) + print *, trim(output(1)) + j = 0 + do i = 1, N_int + j += popcnt(mask_ijkl(i,4)) + enddo + if(j==0)then + return + endif + + size_buffer = min(ao_num*ao_num*ao_num,16000000) + print*, 'Providing the molecular integrals ' + print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& + ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' + + call wall_time(wall_1) + call cpu_time(cpu_1) + double precision :: accu_bis + accu_bis = 0.d0 + + !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & + !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& + !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & + !$OMP wall_0,thread_num,accu_bis) & + !$OMP DEFAULT(NONE) & + !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& + !$OMP mo_coef_transp, & + !$OMP mo_coef_transp_is_built, list_ijkl, & + !$OMP mo_coef_is_built, wall_1, & + !$OMP mo_coef,mo_integrals_threshold,mo_integrals_erf_map) + n_integrals = 0 + wall_0 = wall_1 + allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & + bielec_tmp_1(mo_tot_num_align), & + bielec_tmp_0(ao_num,ao_num), & + bielec_tmp_0_idx(ao_num), & + bielec_tmp_2(mo_tot_num_align, n_j), & + buffer_i(size_buffer), & + buffer_value(size_buffer) ) + + thread_num = 0 + !$ thread_num = omp_get_thread_num() + !$OMP DO SCHEDULE(guided) + do l1 = 1,ao_num + !DEC$ VECTOR ALIGNED + bielec_tmp_3 = 0.d0 + do k1 = 1,ao_num + !DEC$ VECTOR ALIGNED + bielec_tmp_2 = 0.d0 + do j1 = 1,ao_num + call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) + enddo + do j1 = 1,ao_num + kmax = 0 + do i1 = 1,ao_num + c = bielec_tmp_0(i1,j1) + if (c == 0.d0) then + cycle + endif + kmax += 1 + bielec_tmp_0(kmax,j1) = c + bielec_tmp_0_idx(kmax) = i1 + enddo + + if (kmax==0) then + cycle + endif + + !DEC$ VECTOR ALIGNED + bielec_tmp_1 = 0.d0 + ii1=1 + do ii1 = 1,kmax-4,4 + i1 = bielec_tmp_0_idx(ii1) + i2 = bielec_tmp_0_idx(ii1+1) + i3 = bielec_tmp_0_idx(ii1+2) + i4 = bielec_tmp_0_idx(ii1+3) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + & + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & + mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & + mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & + mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) + enddo ! i + enddo ! ii1 + + i2 = ii1 + do ii1 = i2,kmax + i1 = bielec_tmp_0_idx(ii1) + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + enddo ! i + enddo ! ii1 + c = 0.d0 + + do i = list_ijkl(1,1), list_ijkl(n_i,1) + c = max(c,abs(bielec_tmp_1(i))) + if (c>mo_integrals_threshold) exit + enddo + if ( c < mo_integrals_threshold ) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + c = mo_coef_transp(j,j1) + if (abs(c) < thr_coef) then + cycle + endif + do i = list_ijkl(1,1), list_ijkl(n_i,1) + bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) + enddo ! i + enddo ! j + enddo !j1 + if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then + cycle + endif + + + do k0 = 1, n_k + k = list_ijkl(k0,3) + c = mo_coef_transp(k,k1) + if (abs(c) < thr_coef) then + cycle + endif + + do j0 = 1, n_j + j = list_ijkl(j0,2) + do i = list_ijkl(1,1), k + bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) + enddo!i + enddo !j + + enddo !k + enddo !k1 + + + + do l0 = 1,n_l + l = list_ijkl(l0,4) + c = mo_coef_transp(l,l1) + if (abs(c) < thr_coef) then + cycle + endif + j1 = ishft((l*l-l),-1) + do j0 = 1, n_j + j = list_ijkl(j0,2) + if (j > l) then + exit + endif + j1 += 1 + do k0 = 1, n_k + k = list_ijkl(k0,3) + i1 = ishft((k*k-k),-1) + if (i1<=j1) then + continue + else + exit + endif + bielec_tmp_1 = 0.d0 + do i0 = 1, n_i + i = list_ijkl(i0,1) + if (i>k) then + exit + endif + bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) + ! i1+=1 + enddo + + do i0 = 1, n_i + i = list_ijkl(i0,1) + if(i> min(k,j1-i1+list_ijkl(1,1)-1))then + exit + endif + if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then + cycle + endif + n_integrals += 1 + buffer_value(n_integrals) = bielec_tmp_1(i) + !DEC$ FORCEINLINE + call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals)) + if (n_integrals == size_buffer) then + call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + n_integrals = 0 + endif + enddo + enddo + enddo + enddo + + call wall_time(wall_2) + if (thread_num == 0) then + if (wall_2 - wall_0 > 1.d0) then + wall_0 = wall_2 + print*, 100.*float(l1)/float(ao_num), '% in ', & + wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB' + endif + endif + enddo + !$OMP END DO NOWAIT + deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) + + integer :: index_needed + + call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& + real(mo_integrals_threshold,integral_kind)) + deallocate(buffer_i, buffer_value) + !$OMP END PARALLEL + call map_unique(mo_integrals_erf_map) + + call wall_time(wall_2) + call cpu_time(cpu_2) + integer*8 :: get_mo_erf_map_size, mo_erf_map_size + mo_erf_map_size = get_mo_erf_map_size() + + deallocate(list_ijkl) + + + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB' + print*,' Number of MO integrals: ', mo_erf_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + +end + + + + BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] + BEGIN_DOC + ! mo_bielec_integral_jj_from_ao(i,j) = J_ij + ! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij + ! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij + END_DOC + implicit none + integer :: i,j,p,q,r,s + double precision :: c + real(integral_kind) :: integral + integer :: n, pp + real(integral_kind), allocatable :: int_value(:) + integer, allocatable :: int_idx(:) + + double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) + + if (.not.do_direct_integrals) then + PROVIDE ao_bielec_integrals_erf_in_map mo_coef + endif + + mo_bielec_integral_erf_jj_from_ao = 0.d0 + mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0 + + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr + + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & + !$OMP iqrs, iqsr,iqri,iqis) & + !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,& + !$OMP ao_integrals_threshold,do_direct_integrals) & + !$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao) + + allocate( int_value(ao_num), int_idx(ao_num), & + iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),& + iqsr(mo_tot_num_align,ao_num) ) + + !$OMP DO SCHEDULE (guided) + do s=1,ao_num + do q=1,ao_num + + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqrs(i,j) = 0.d0 + iqsr(i,j) = 0.d0 + enddo + enddo + + if (do_direct_integrals) then + double precision :: ao_bielec_integral_erf + do r=1,ao_num + call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value) + do p=1,ao_num + integral = int_value(p) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqrs(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value) + do p=1,ao_num + integral = int_value(p) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqsr(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + enddo + + else + + do r=1,ao_num + call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n) + do pp=1,n + p = int_idx(pp) + integral = int_value(pp) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqrs(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n) + do pp=1,n + p = int_idx(pp) + integral = int_value(pp) + if (abs(integral) > ao_integrals_threshold) then + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqsr(i,r) += mo_coef_transp(i,p) * integral + enddo + endif + enddo + enddo + endif + iqis = 0.d0 + iqri = 0.d0 + do r=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,mo_tot_num + iqis(i) += mo_coef_transp(i,r) * iqrs(i,r) + iqri(i) += mo_coef_transp(i,r) * iqsr(i,r) + enddo + enddo + do i=1,mo_tot_num + !DIR$ VECTOR ALIGNED + do j=1,mo_tot_num + c = mo_coef_transp(j,q)*mo_coef_transp(j,s) + mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i) + mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i) + enddo + enddo + + enddo + enddo + !$OMP END DO NOWAIT + deallocate(iqrs,iqsr,int_value,int_idx) + !$OMP END PARALLEL + + mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao + + +! end +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! mo_bielec_integral_jj(i,j) = J_ij + ! mo_bielec_integral_jj_exchange(i,j) = K_ij + ! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij + END_DOC + + integer :: i,j + double precision :: get_mo_bielec_integral_erf + + PROVIDE mo_bielec_integrals_erf_in_map + mo_bielec_integral_erf_jj = 0.d0 + mo_bielec_integral_erf_jj_exchange = 0.d0 + + do j=1,mo_tot_num + do i=1,mo_tot_num + mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map) + mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map) + mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j) + enddo + enddo + +END_PROVIDER + + +subroutine clear_mo_erf_map + implicit none + BEGIN_DOC + ! Frees the memory of the MO map + END_DOC + call map_deinit(mo_integrals_erf_map) + FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti + FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map + + +end + +subroutine provide_all_mo_integrals_erf + implicit none + provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti + provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map + +end diff --git a/plugins/Integrals_erf/providers_ao_erf.irp.f b/plugins/Integrals_erf/providers_ao_erf.irp.f new file mode 100644 index 00000000..1507d1be --- /dev/null +++ b/plugins/Integrals_erf/providers_ao_erf.irp.f @@ -0,0 +1,119 @@ + +BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ] + implicit none + use f77_zmq + use map_module + BEGIN_DOC + ! Map of Atomic integrals + ! i(r1) j(r2) 1/r12 k(r1) l(r2) + END_DOC + + integer :: i,j,k,l + double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 + double precision :: integral, wall_0 + include 'Utils/constants.include.F' + + ! For integrals file + integer(key_kind),allocatable :: buffer_i(:) + integer,parameter :: size_buffer = 1024*64 + real(integral_kind),allocatable :: buffer_value(:) + + integer :: n_integrals, rc + integer :: kk, m, j1, i1, lmax + character*(64) :: fmt + + integral = ao_bielec_integral_erf(1,1,1,1) + + real :: map_mb + PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf + if (read_ao_integrals_erf) then + print*,'Reading the AO integrals_erf' + call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) + print*, 'AO integrals_erf provided' + ao_bielec_integrals_erf_in_map = .True. + return + endif + + print*, 'Providing the AO integrals_erf' + call wall_time(wall_0) + call wall_time(wall_1) + call cpu_time(cpu_1) + + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf') + + character(len=:), allocatable :: task + allocate(character(len=ao_num*12) :: task) + write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' + do l=1,ao_num + write(task,fmt) (i,l, i=1,l) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) + enddo + deallocate(task) + + call zmq_set_running(zmq_to_qp_run_socket) + + PROVIDE nproc + !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1) + i = omp_get_thread_num() + if (i==0) then + call ao_bielec_integrals_erf_in_map_collector(i) + else + call ao_bielec_integrals_erf_in_map_slave_inproc(i) + endif + !$OMP END PARALLEL + + call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf') + + + print*, 'Sorting the map' + call map_sort(ao_integrals_erf_map) + call cpu_time(cpu_2) + call wall_time(wall_2) + integer(map_size_kind) :: get_ao_erf_map_size, ao_erf_map_size + ao_erf_map_size = get_ao_erf_map_size() + + print*, 'AO integrals provided:' + print*, ' Size of AO map : ', map_mb(ao_integrals_erf_map) ,'MB' + print*, ' Number of AO integrals :', ao_erf_map_size + print*, ' cpu time :',cpu_2 - cpu_1, 's' + print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' + + ao_bielec_integrals_erf_in_map = .True. + + if (write_ao_integrals_erf) then + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) + call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read") + endif + +END_PROVIDER + + + + +BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num) ] + implicit none + BEGIN_DOC + ! Needed to compute Schwartz inequalities + END_DOC + + integer :: i,k + double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 + + ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1) + !$OMP PARALLEL DO PRIVATE(i,k) & + !$OMP DEFAULT(NONE) & + !$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz) & + !$OMP SCHEDULE(dynamic) + do i=1,ao_num + do k=1,i + ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k)) + ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k) + enddo + enddo + !$OMP END PARALLEL DO + +END_PROVIDER + + diff --git a/plugins/Integrals_erf/qp_ao_erf_ints.irp.f b/plugins/Integrals_erf/qp_ao_erf_ints.irp.f new file mode 100644 index 00000000..df6d8d16 --- /dev/null +++ b/plugins/Integrals_erf/qp_ao_erf_ints.irp.f @@ -0,0 +1,32 @@ +program qp_ao_ints + use omp_lib + implicit none + BEGIN_DOC +! Increments a running calculation to compute AO integral_erfs + END_DOC + integer :: i + + call switch_qp_run_to_master + + zmq_context = f77_zmq_ctx_new () + + ! Set the state of the ZMQ + zmq_state = 'ao_integral_erfs' + + ! Provide everything needed + double precision :: integral_erf, ao_bielec_integral_erf + integral_erf = ao_bielec_integral_erf(1,1,1,1) + + character*(64) :: state + call wait_for_state(zmq_state,state) + do while (state /= 'Stopped') + !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) + i = omp_get_thread_num() + call ao_bielec_integrals_erf_in_map_slave_tcp(i) + !$OMP END PARALLEL + call wait_for_state(zmq_state,state) + enddo + + print *, 'Done' +end + diff --git a/plugins/Integrals_erf/read_write.irp.f b/plugins/Integrals_erf/read_write.irp.f new file mode 100644 index 00000000..12bbf0bc --- /dev/null +++ b/plugins/Integrals_erf/read_write.irp.f @@ -0,0 +1,47 @@ +BEGIN_PROVIDER [ logical, read_ao_integrals_erf ] +&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ] +&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ] +&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ] + + BEGIN_DOC +! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf + END_DOC +implicit none + + if (disk_access_ao_integrals_erf.EQ.'Read') then + read_ao_integrals_erf = .True. + write_ao_integrals_erf = .False. + + else if (disk_access_ao_integrals_erf.EQ.'Write') then + read_ao_integrals_erf = .False. + write_ao_integrals_erf = .True. + + else if (disk_access_ao_integrals_erf.EQ.'None') then + read_ao_integrals_erf = .False. + write_ao_integrals_erf = .False. + + else + print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type' + stop 1 + + endif + + if (disk_access_mo_integrals_erf.EQ.'Read') then + read_mo_integrals_erf = .True. + write_mo_integrals_erf = .False. + + else if (disk_access_mo_integrals_erf.EQ.'Write') then + read_mo_integrals_erf = .False. + write_mo_integrals_erf = .True. + + else if (disk_access_mo_integrals_erf.EQ.'None') then + read_mo_integrals_erf = .False. + write_mo_integrals_erf = .False. + + else + print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type' + stop 1 + + endif + +END_PROVIDER diff --git a/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES b/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..08317b5e --- /dev/null +++ b/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Integrals_Monoelec Integrals_erf Determinants DFT_Utils diff --git a/plugins/Integrals_restart_DFT/README.rst b/plugins/Integrals_restart_DFT/README.rst new file mode 100644 index 00000000..589e0a00 --- /dev/null +++ b/plugins/Integrals_restart_DFT/README.rst @@ -0,0 +1,12 @@ +============== +core_integrals +============== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f b/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f new file mode 100644 index 00000000..aeb2589c --- /dev/null +++ b/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f @@ -0,0 +1,79 @@ +BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)] + implicit none + integer :: i,j,k,l + logical :: exists + call ezfio_has_determinants_density_matrix_mo_disk(exists) + if(exists)then + print*, 'reading the density matrix from input' + call ezfio_get_determinants_density_matrix_mo_disk(exists) + print*, 'reading done' + else + print*, 'no density matrix found in EZFIO file ...' + print*, 'stopping ..' + stop + endif + +END_PROVIDER + + +BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)] + implicit none + integer :: i,j,k,l,m,n + double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf + double precision :: integral, integral_erf + effective_short_range_operator = 0.d0 + do i = 1, mo_tot_num + do j = 1, mo_tot_num + if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle + do k = 1, mo_tot_num + do l = 1, mo_tot_num + integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map) +! integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map) + effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral + enddo + enddo + enddo + enddo +END_PROVIDER + + +BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)] + implicit none + integer :: i,j,i_state + effective_one_e_potential = 0.d0 + do i_state = 1, N_states + do i = 1, mo_tot_num + do j = 1, mo_tot_num + effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) & + + 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state)) + enddo + enddo + enddo + +END_PROVIDER + +subroutine save_one_e_effective_potential + implicit none + double precision, allocatable :: tmp(:,:) + allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2))) + integer :: i,j + do i = 1, mo_tot_num + do j = 1, mo_tot_num + tmp(i,j) = effective_one_e_potential(i,j,1) + enddo + enddo + call write_one_e_integrals('mo_one_integral', tmp, & + size(tmp,1), size(tmp,2)) + call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read") + deallocate(tmp) + +end + +subroutine save_erf_bi_elec_integrals + implicit none + integer :: i,j,k,l + PROVIDE mo_bielec_integrals_erf_in_map + call ezfio_set_work_empty(.False.) + call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map) + call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") +end diff --git a/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f b/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f new file mode 100644 index 00000000..d89b965d --- /dev/null +++ b/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f @@ -0,0 +1,18 @@ +program write_integrals + implicit none + read_wf = .true. + touch read_wf + disk_access_only_mo_one_integrals = "None" + touch disk_access_only_mo_one_integrals + disk_access_mo_integrals = "None" + touch disk_access_mo_integrals + call routine + +end + +subroutine routine + implicit none + call save_one_e_effective_potential + call save_erf_bi_elec_integrals + +end diff --git a/plugins/Kohn_Sham/EZFIO.cfg b/plugins/Kohn_Sham/EZFIO.cfg new file mode 100644 index 00000000..33d3a793 --- /dev/null +++ b/plugins/Kohn_Sham/EZFIO.cfg @@ -0,0 +1,54 @@ +[thresh_scf] +type: Threshold +doc: Threshold on the convergence of the Hartree Fock energy +interface: ezfio,provider,ocaml +default: 1.e-10 + +[exchange_functional] +type: character*(256) +doc: name of the exchange functional +interface: ezfio, provider, ocaml +default: "LDA" + + +[correlation_functional] +type: character*(256) +doc: name of the correlation functional +interface: ezfio, provider, ocaml +default: "LDA" + +[HF_exchange] +type: double precision +doc: Percentage of HF exchange in the DFT model +interface: ezfio,provider,ocaml +default: 0. + +[n_it_scf_max] +type: Strictly_positive_int +doc: Maximum number of SCF iterations +interface: ezfio,provider,ocaml +default: 200 + +[level_shift] +type: Positive_float +doc: Energy shift on the virtual MOs to improve SCF convergence +interface: ezfio,provider,ocaml +default: 0.5 + +[mo_guess_type] +type: MO_guess +doc: Initial MO guess. Can be [ Huckel | HCore ] +interface: ezfio,provider,ocaml +default: Huckel + +[energy] +type: double precision +doc: Calculated HF energy +interface: ezfio + +[no_oa_or_av_opt] +type: logical +doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure +interface: ezfio,provider,ocaml +default: False + diff --git a/plugins/Kohn_Sham/Fock_matrix.irp.f b/plugins/Kohn_Sham/Fock_matrix.irp.f new file mode 100644 index 00000000..9c91ddc9 --- /dev/null +++ b/plugins/Kohn_Sham/Fock_matrix.irp.f @@ -0,0 +1,468 @@ + BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis. + ! For open shells, the ROHF Fock Matrix is + ! + ! | F-K | F + K/2 | F | + ! |---------------------------------| + ! | F + K/2 | F | F - K/2 | + ! |---------------------------------| + ! | F | F - K/2 | F + K | + ! + ! F = 1/2 (Fa + Fb) + ! + ! K = Fb - Fa + ! + END_DOC + integer :: i,j,n + if (elec_alpha_num == elec_beta_num) then + Fock_matrix_mo = Fock_matrix_alpha_mo + else + + do j=1,elec_beta_num + ! F-K + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + enddo + + do j=elec_beta_num+1,elec_alpha_num + ! F+K/2 + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + do j=elec_alpha_num+1, mo_tot_num + ! F + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K + do i=elec_alpha_num+1,mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & + + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + endif + + do i = 1, mo_tot_num + Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) + enddo +END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j) + Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j) + ao_potential_beta_xc(i,j) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Mono electronic an Coulomb matrix in AO basis set + END_DOC + + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) + Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) + enddo + enddo + +END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] + use map_module + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j,k,l,k1,r,s + integer :: i0,j0,k0,l0 + integer*8 :: p,q + double precision :: integral, c0, c1, c2 + double precision :: ao_bielec_integral, local_threshold + double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) + double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp + + ao_bi_elec_integral_alpha = 0.d0 + ao_bi_elec_integral_beta = 0.d0 + if (do_direct_integrals) then + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & + !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & + !$OMP local_threshold)& + !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& + !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & + !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + + allocate(keys(1), values(1)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + + q = ao_num*ao_num*ao_num*ao_num + !$OMP DO SCHEDULE(dynamic) + do p=1_8,q + call bielec_integrals_index_reverse(kk,ii,ll,jj,p) + if ( (kk(1)>ao_num).or. & + (ii(1)>ao_num).or. & + (jj(1)>ao_num).or. & + (ll(1)>ao_num) ) then + cycle + endif + k = kk(1) + i = ii(1) + l = ll(1) + j = jj(1) + + if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & + < ao_integrals_threshold) then + cycle + endif + local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) + if (local_threshold < ao_integrals_threshold) then + cycle + endif + i0 = i + j0 = j + k0 = k + l0 = l + values(1) = 0.d0 + local_threshold = ao_integrals_threshold/local_threshold + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) + c1 = HF_density_matrix_ao_alpha(k,i) + c2 = HF_density_matrix_ao_beta(k,i) + if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then + cycle + endif + if (values(1) == 0.d0) then + values(1) = ao_bielec_integral(k0,l0,i0,j0) + endif + integral = c0 * values(1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(1) + ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral + ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp + !$OMP END CRITICAL + !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp + !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) + !$OMP END PARALLEL + else + PROVIDE ao_bielec_integrals_in_map + + integer(omp_lock_kind) :: lck(ao_num) + integer*8 :: i8 + integer :: ii(8), jj(8), kk(8), ll(8), k2 + integer(cache_map_size_kind) :: n_elements_max, n_elements + integer(key_kind), allocatable :: keys(:) + double precision, allocatable :: values(:) + +! !$OMP PARALLEL DEFAULT(NONE) & +! !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & +! !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& +! !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& +! !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange) + + call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) + allocate(keys(n_elements_max), values(n_elements_max)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + +! !OMP DO SCHEDULE(dynamic) +! !DIR$ NOVECTOR + do i8=0_8,ao_integrals_map%map_size + n_elements = n_elements_max + call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) + do k1=1,n_elements + call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) + + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(k1) + ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral) + ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral) + enddo + enddo + enddo +! !$OMP END DO NOWAIT +! !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp +! !$OMP END CRITICAL +! !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp +! !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) +! !$OMP END PARALLEL + + endif + +END_PROVIDER + + + + + + +BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + + BEGIN_PROVIDER [ double precision, HF_energy ] +&BEGIN_PROVIDER [ double precision, two_electron_energy] +&BEGIN_PROVIDER [ double precision, one_electron_energy] + implicit none + BEGIN_DOC + ! Hartree-Fock energy + END_DOC + HF_energy = nuclear_repulsion + + integer :: i,j + double precision :: accu_mono,accu_fock + one_electron_energy = 0.d0 + two_electron_energy = 0.d0 + do j=1,ao_num + do i=1,ao_num + two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) & + +ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) ) + one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) ) + enddo + enddo + print*, 'one_electron_energy = ',one_electron_energy + print*, 'two_electron_energy = ',two_electron_energy + print*, 'e_exchange_dft = ',(1.d0 - HF_exchange) * e_exchange_dft +!print*, 'accu_cor = ',e_correlation_dft + HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy +!print*, 'HF_energy ' + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Fock matrix in AO basis set + END_DOC + + if ( (elec_alpha_num == elec_beta_num).and. & + (level_shift == 0.) ) & + then + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num_align + Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) + enddo + enddo + else + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + Fock_matrix_mo, size(Fock_matrix_mo,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + Fock_matrix_ao, size(Fock_matrix_ao,1)) + + + deallocate(T) + endif +END_PROVIDER + +subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) + implicit none + integer, intent(in) :: LDFMO ! size(FMO,1) + integer, intent(in) :: LDFAO ! size(FAO,1) + double precision, intent(in) :: FMO(LDFMO,*) + double precision, intent(out) :: FAO(LDFAO,*) + + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + FMO, size(FMO,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + FAO, size(FAO,1)) + deallocate(T,M) +end + diff --git a/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f b/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f new file mode 100644 index 00000000..e8585f59 --- /dev/null +++ b/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f @@ -0,0 +1,41 @@ +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 x Alpha density matrix in the AO basis x S^-1 + END_DOC + + call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & + mo_coef, size(mo_coef,1), & + mo_coef, size(mo_coef,1), 0.d0, & + HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Beta density matrix in the AO basis x S^-1 + END_DOC + + call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & + mo_coef, size(mo_coef,1), & + mo_coef, size(mo_coef,1), 0.d0, & + HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Density matrix in the AO basis S^-1 + END_DOC + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) + if (elec_alpha_num== elec_beta_num) then + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha + else + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta + endif + +END_PROVIDER + diff --git a/plugins/Kohn_Sham/KS_SCF.irp.f b/plugins/Kohn_Sham/KS_SCF.irp.f new file mode 100644 index 00000000..dead61ee --- /dev/null +++ b/plugins/Kohn_Sham/KS_SCF.irp.f @@ -0,0 +1,54 @@ +program scf + BEGIN_DOC +! Produce `Hartree_Fock` MO orbital +! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ +! output: hartree_fock.energy +! optional: mo_basis.mo_coef + END_DOC + call create_guess + call orthonormalize_mos + call run +end + +subroutine create_guess + implicit none + BEGIN_DOC +! Create an MO guess if no MOs are present in the EZFIO directory + END_DOC + logical :: exists + PROVIDE ezfio_filename + call ezfio_has_mo_basis_mo_coef(exists) + if (.not.exists) then + if (mo_guess_type == "HCore") then + mo_coef = ao_ortho_lowdin_coef + TOUCH mo_coef + mo_label = 'Guess' + call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label) + SOFT_TOUCH mo_coef mo_label + else if (mo_guess_type == "Huckel") then + call huckel_guess + else + print *, 'Unrecognized MO guess type : '//mo_guess_type + stop 1 + endif + endif +end + + +subroutine run + + use bitmasks + implicit none + BEGIN_DOC +! Run SCF calculation + END_DOC + double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem + double precision :: E0 + integer :: i_it, i, j, k + + E0 = HF_energy + + mo_label = "Canonical" + call damping_SCF + +end diff --git a/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES b/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..d8c28b56 --- /dev/null +++ b/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Integrals_Bielec MOGuess Bitmask DFT_Utils diff --git a/plugins/Kohn_Sham/damping_SCF.irp.f b/plugins/Kohn_Sham/damping_SCF.irp.f new file mode 100644 index 00000000..aa6f02b0 --- /dev/null +++ b/plugins/Kohn_Sham/damping_SCF.irp.f @@ -0,0 +1,132 @@ +subroutine damping_SCF + implicit none + double precision :: E + double precision, allocatable :: D_alpha(:,:), D_beta(:,:) + double precision :: E_new + double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) + double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) + double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min + + integer :: i,j,k + logical :: saving + character :: save_char + + allocate( & + D_alpha( ao_num_align, ao_num ), & + D_beta( ao_num_align, ao_num ), & + F_new( ao_num_align, ao_num ), & + D_new_alpha( ao_num_align, ao_num ), & + D_new_beta( ao_num_align, ao_num ), & + delta_alpha( ao_num_align, ao_num ), & + delta_beta( ao_num_align, ao_num )) + + do j=1,ao_num + do i=1,ao_num + D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) + D_beta (i,j) = HF_density_matrix_ao_beta (i,j) + enddo + enddo + + + call write_time(output_hartree_fock) + + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + + E = HF_energy + 1.d0 + E_min = HF_energy + delta_D = 0.d0 + do k=1,n_it_scf_max + + delta_E = HF_energy - E + E = HF_energy + + if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then + exit + endif + + saving = E < E_min + if (saving) then + call save_mos + save_char = 'X' + E_min = E + else + save_char = ' ' + endif + + write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & + k, E, delta_E, delta_D, save_char + + D_alpha = HF_density_matrix_ao_alpha + D_beta = HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + D_new_alpha = HF_density_matrix_ao_alpha + D_new_beta = HF_density_matrix_ao_beta + F_new = Fock_matrix_ao + E_new = HF_energy + + delta_alpha = D_new_alpha - D_alpha + delta_beta = D_new_beta - D_beta + + lambda = .5d0 + E_half = 0.d0 + do while (E_half > E) + HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha + HF_density_matrix_ao_beta = D_beta + lambda * delta_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + E_half = HF_energy + if ((E_half > E).and.(E_new < E)) then + lambda = 1.d0 + exit + else if ((E_half > E).and.(lambda > 5.d-4)) then + lambda = 0.5d0 * lambda + E_new = E_half + else + exit + endif + enddo + + a = (E_new + E - 2.d0*E_half)*2.d0 + b = -E_new - 3.d0*E + 4.d0*E_half + lambda = -lambda*b/(a+1.d-16) + D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha + D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta + delta_E = HF_energy - E + do j=1,ao_num + do i=1,ao_num + delta_D = delta_D + & + (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & + (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) + enddo + enddo + delta_D = dsqrt(delta_D/dble(ao_num)**2) + HF_density_matrix_ao_alpha = D_alpha + HF_density_matrix_ao_beta = D_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + + enddo + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' + write(output_hartree_fock,*) + + if(.not.no_oa_or_av_opt)then + call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) + endif + + call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') + call ezfio_set_hartree_fock_energy(E_min) + + call write_time(output_hartree_fock) + + deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) +end diff --git a/plugins/Kohn_Sham/diagonalize_fock.irp.f b/plugins/Kohn_Sham/diagonalize_fock.irp.f new file mode 100644 index 00000000..c80077b3 --- /dev/null +++ b/plugins/Kohn_Sham/diagonalize_fock.irp.f @@ -0,0 +1,119 @@ + BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] +&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Diagonal Fock matrix in the MO basis + END_DOC + + integer :: i,j + integer :: liwork, lwork, n, info + integer, allocatable :: iwork(:) + double precision, allocatable :: work(:), F(:,:), S(:,:) + + + allocate( F(mo_tot_num_align,mo_tot_num) ) + do j=1,mo_tot_num + do i=1,mo_tot_num + F(i,j) = Fock_matrix_mo(i,j) + enddo + enddo + if(no_oa_or_av_opt)then + integer :: iorb,jorb + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_core_orb + jorb = list_core(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + enddo + endif + + + + + ! Insert level shift here + do i = elec_beta_num+1, elec_alpha_num + F(i,i) += 0.5d0*level_shift + enddo + + do i = elec_alpha_num+1, mo_tot_num + F(i,i) += level_shift + enddo + + n = mo_tot_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork), iwork(liwork) ) + + lwork = -1 + liwork = -1 + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(work,iwork) + allocate(work(lwork), iwork(liwork) ) + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + + call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & + mo_coef, size(mo_coef,1), F, size(F,1), & + 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) + deallocate(work, iwork, F) + + +! endif + +END_PROVIDER + +BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] + implicit none + BEGIN_DOC + ! diagonal element of the fock matrix calculated as the sum over all the interactions + ! with all the electrons in the RHF determinant + ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij + END_DOC + integer :: i,j + double precision :: accu + do j = 1,elec_alpha_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + do j = elec_alpha_num+1,mo_tot_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + +END_PROVIDER diff --git a/plugins/Kohn_Sham/potential_functional.irp.f b/plugins/Kohn_Sham/potential_functional.irp.f new file mode 100644 index 00000000..3502581b --- /dev/null +++ b/plugins/Kohn_Sham/potential_functional.irp.f @@ -0,0 +1,31 @@ + BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)] +&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)] + implicit none + integer :: i,j,k,l + ao_potential_alpha_xc = 0.d0 + ao_potential_beta_xc = 0.d0 +!if(exchange_functional == "LDA")then + do i = 1, ao_num + do j = 1, ao_num + ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1) + ao_potential_beta_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1) + enddo + enddo +!endif +END_PROVIDER + +BEGIN_PROVIDER [double precision, e_exchange_dft] + implicit none +!if(exchange_functional == "LDA")then + e_exchange_dft = lda_exchange(1) +!endif + +END_PROVIDER + +BEGIN_PROVIDER [double precision, e_correlation_dft] + implicit none +!if(correlation_functional == "LDA")then + e_correlation_dft = 0.d0 +!endif + +END_PROVIDER diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 801d2f51..3dc21fd0 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index 1dcf2a2b..ccbe700d 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -121,7 +121,8 @@ END_PROVIDER double precision :: phase logical :: ok integer, external :: searchDet - + + PROVIDE psi_non_ref_sorted_idx psi_ref_coef !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& @@ -158,6 +159,7 @@ END_PROVIDER wk += 1 do s=1,N_states active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) + enddo active_excitation_to_determinants_idx(wk, ppp) = i else if(lref(i) < 0) then @@ -190,7 +192,7 @@ END_PROVIDER double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref + PROVIDE psi_non_ref active_excitation_to_determinants_val mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -198,7 +200,6 @@ END_PROVIDER mrcc_N_col(:) = 0 AtA_size = 0 - !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 41435688..7ba210ca 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -678,6 +678,53 @@ END_PROVIDER call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int) END_PROVIDER + BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ] + implicit none + integer :: i, j, k + double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) + double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) + integer :: number_of_holes, number_of_particles,nh,np + do i = 1, N_det_non_ref + print*,'i',i + nh = number_of_holes(psi_non_ref(1,1,i)) + np = number_of_particles(psi_non_ref(1,1,i)) + do j = 1, N_det_ref + do k = 1, N_States + coef_array(k) = psi_ref_coef(j,k) + enddo + call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j)) + call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e) +! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:) + do k = 1, N_states + delta_e_Array(j,k) = delta_e(k) + enddo + enddo + coef_mrpt = 0.d0 + do k = 1, N_states + do j = 1, N_det_Ref + coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) + enddo + enddo + + write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2) + print*, nh,np + do k = 1, N_States + if(dabs(coef_mrpt(k)) .le.1.d-10)then + rho_mrpt(i,k) = 0.d0 + exit + endif + if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then + rho_mrpt(i,k) = 1.d0 + else + rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k) + endif + enddo + print*,'rho',rho_mrpt(i,:) + write(33,*)i,rho_mrpt(i,:) + enddo + + END_PROVIDER + BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] @@ -957,7 +1004,7 @@ END_PROVIDER double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint double precision, external :: get_dij - double precision :: HIi, phase + double precision :: HIi, phase,delta_e_final(N_states) if(lambda_type == 0) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) @@ -969,7 +1016,11 @@ double precision function get_dij_index(II, i, s, Nint) else if(lambda_type == 2) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index * rho_mrcc(i,s) + get_dij_index = get_dij_index + else if(lambda_type == 3) then + call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) + call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final) + get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s) end if end function diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index 13c8228a..1b6efb4f 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -10,34 +10,42 @@ end subroutine routine_3 implicit none + integer :: i,j !provide fock_virt_total_spin_trace provide delta_ij print *, 'N_det = ', N_det print *, 'N_states = ', N_states - print *, 'PT2 = ', second_order_pt_new(1) - print *, 'E = ', CI_energy(1) - print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) - print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' - print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) + do i = 1, N_States + print*,'State',i + write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) + write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) + write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) + print*,'coef before and after' + do j = 1, N_det_ref + print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) + enddo + enddo + if(save_heff_eigenvectors)then + call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors) + endif + if(N_states.gt.1)then + print*, 'Energy differences : E(i) - E(0)' + do i = 2, N_States + print*,'State',i + write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) + write(*,'(A12,X,I3,A3,XX,F20.16)') 'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i)) + write(*,'(A12,X,I3,A3,XX,F20.16)') 'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i))) + write(*,'(A12,X,I3,A3,XX,F20.16)') 'Dressed ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) ) + enddo + endif end subroutine routine_2 implicit none - integer :: i - do i = 1, n_core_inact_orb - print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i) - enddo - double precision :: accu - accu = 0.d0 - do i = 1, n_act_orb - integer :: j_act_orb - j_act_orb = list_act(i) - accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1) - print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) - enddo - print*,'accu = ',accu - + provide electronic_psi_ref_average_value end diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES index 7340c609..041b0136 100644 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MRPT_Utils Selectors_full Generators_full +MRPT_Utils Selectors_full Psiref_CAS Generators_CAS diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index d10e1fb5..f20f12b6 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -7,45 +7,52 @@ end subroutine routine implicit none - double precision,allocatable :: matrix_1h2p(:,:,:) - allocate (matrix_1h2p(N_det,N_det,N_states)) - integer :: i,j,istate - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 - enddo - enddo - enddo - if(.False.)then - call give_1h2p_contrib(matrix_1h2p) - double precision :: accu - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - print*, 'second order ', accu - endif + provide one_anhil_one_creat_inact_virt - if(.True.)then - do i = 1, N_det - do j = 1, N_det - do istate = 1, N_states - matrix_1h2p(i,j,istate) = 0.d0 +end + +subroutine routine_2 + implicit none + integer :: i,j,degree + double precision :: hij + do i =1, n_core_inact_orb + write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1) + enddo + print*,'' + do i =1, n_virt_orb + write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1) + enddo + stop + do i = 1, n_virt_orb + do j = 1, n_inact_orb + if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle + write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1) + enddo + enddo + + +end + +subroutine routine_3 + implicit none + double precision,allocatable :: matrix_1h2p(:,:,:) + double precision :: accu(2) + allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states)) + integer :: i,j,istate + accu = 0.d0 + matrix_1h2p = 0.d0 +!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref) + call give_1h2p_contrib(matrix_1h2p) + do istate = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate) enddo enddo + print*,accu(istate) enddo - call give_1h2p_new(matrix_1h2p) - accu = 0.d0 - do i = 1, N_det - do j = 1, N_det - accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) - enddo - enddo - endif - print*, 'third order ', accu + call contrib_1h2p_dm_based(accu) + print*,accu(:) deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg index 2fcc26ad..cb16fcea 100644 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -5,3 +5,10 @@ interface: ezfio,provider,ocaml default: True +[save_heff_eigenvectors] +type: logical +doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation +interface: ezfio,provider,ocaml +default: False + + diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index 6f17ab05..a7adc480 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -23,6 +23,7 @@ print s s = H_apply("mrpt_1h") s.filter_only_1h() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -43,6 +44,7 @@ print s s = H_apply("mrpt_1p") s.filter_only_1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -63,6 +65,7 @@ print s s = H_apply("mrpt_1h1p") s.filter_only_1h1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -83,6 +86,7 @@ print s s = H_apply("mrpt_2p") s.filter_only_2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -103,6 +107,7 @@ print s s = H_apply("mrpt_2h") s.filter_only_2h() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -124,6 +129,7 @@ print s s = H_apply("mrpt_1h2p") s.filter_only_1h2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -144,6 +150,7 @@ print s s = H_apply("mrpt_2h1p") s.filter_only_2h1p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -164,6 +171,7 @@ print s s = H_apply("mrpt_2h2p") s.filter_only_2h2p() +s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet diff --git a/plugins/MRPT_Utils/MRMP2_density.irp.f b/plugins/MRPT_Utils/MRMP2_density.irp.f new file mode 100644 index 00000000..1051edf9 --- /dev/null +++ b/plugins/MRPT_Utils/MRMP2_density.irp.f @@ -0,0 +1,46 @@ +BEGIN_PROVIDER [double precision, MRMP2_density, (mo_tot_num_align, mo_tot_num)] + implicit none + integer :: i,j,k,l + double precision :: accu, mp2_dm(mo_tot_num) + MRMP2_density = one_body_dm_mo + call give_2h2p_density(mp2_dm) + accu = 0.d0 + do i = 1, n_virt_orb + j = list_virt(i) + accu += mp2_dm(j) + MRMP2_density(j,j)+= mp2_dm(j) + enddo + +END_PROVIDER + +subroutine give_2h2p_density(mp2_density_diag_alpha_beta) + implicit none + double precision, intent(out) :: mp2_density_diag_alpha_beta(mo_tot_num) + integer :: i,j,k,l,m + integer :: iorb,jorb,korb,lorb + + double precision :: get_mo_bielec_integral + double precision :: direct_int + double precision :: coef_double + + mp2_density_diag_alpha_beta = 0.d0 + do k = 1, n_virt_orb + korb = list_virt(k) + do i = 1, n_inact_orb + iorb = list_inact(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + do l = 1, n_virt_orb + lorb = list_virt(l) + direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map) + coef_double = direct_int/(fock_core_inactive_total_spin_trace(iorb,1) + fock_core_inactive_total_spin_trace(jorb,1) & + -fock_virt_total_spin_trace(korb,1) - fock_virt_total_spin_trace(lorb,1)) + mp2_density_diag_alpha_beta(korb) += coef_double * coef_double + enddo + enddo + enddo + print*, mp2_density_diag_alpha_beta(korb) + enddo + +end + diff --git a/plugins/MRPT_Utils/density_matrix_based.irp.f b/plugins/MRPT_Utils/density_matrix_based.irp.f new file mode 100644 index 00000000..ac135807 --- /dev/null +++ b/plugins/MRPT_Utils/density_matrix_based.irp.f @@ -0,0 +1,193 @@ +subroutine contrib_1h2p_dm_based(accu) + implicit none + integer :: i_i,i_r,i_v,i_a,i_b + integer :: i,r,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 +!do i_i = 1, 1 + do i_i = 1, n_inact_orb + i = list_inact(i_i) +! do i_r = 1, 1 + do i_r = 1, n_virt_orb + r = list_virt(i_r) +! do i_v = 1, 1 + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 + delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) & + - fock_virt_total_spin_trace(r,istate) & + - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> r) + do jspin = 1, 2 ! spin of (a --> v) + if(ispin == jspin .and. r.le.v)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + +subroutine contrib_2h1p_dm_based(accu) + implicit none + integer :: i_i,i_j,i_v,i_a,i_b + integer :: i,j,v,a,b + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,2) + double precision :: delta_e(n_act_orb,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 + do i_i = 1, n_inact_orb + i = list_inact(i_i) + do i_j = 1, n_inact_orb + j = list_inact(i_j) + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct + active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange + do istate = 1, N_states + do jspin=1, 2 +! delta_e(i_a,jspin,istate) = +! + delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) & + + fock_core_inactive_total_spin_trace(i,istate) & + + fock_core_inactive_total_spin_trace(j,istate) + delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) + enddo + enddo + enddo + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb +! do i_b = i_a, i_a + b = list_act(i_b) + do ispin = 1, 2 ! spin of (i --> v) + do jspin = 1, 2 ! spin of (j --> a) + if(ispin == jspin .and. i.le.j)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) & + * (active_int(i_b,1) - active_int(i_b,2)) & + * delta_e(i_a,jspin,istate) + else + accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & + * active_int(i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + + +subroutine contrib_2p_dm_based(accu) + implicit none + integer :: i_r,i_v,i_a,i_b,i_c,i_d + integer :: r,v,a,b,c,d + integer :: ispin,jspin + integer :: istate + double precision, intent(out) :: accu(N_states) + double precision :: active_int(n_act_orb,n_act_orb,2) + double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) + double precision :: get_mo_bielec_integral + accu = 0.d0 + do i_r = 1, n_virt_orb + r = list_virt(i_r) + do i_v = 1, n_virt_orb + v = list_virt(i_v) + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb + b = list_act(i_b) + active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct + active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct + do istate = 1, N_states + do jspin=1, 2 ! spin of i_a + do ispin = 1, 2 ! spin of i_b + delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) & + - fock_virt_total_spin_trace(r,istate) & + - fock_virt_total_spin_trace(v,istate) + delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate) + enddo + enddo + enddo + enddo + enddo + ! diagonal terms + do i_a = 1, n_act_orb + a = list_act(i_a) + do i_b = 1, n_act_orb + b = list_act(i_b) + do ispin = 1, 2 ! spin of (a --> r) + do jspin = 1, 2 ! spin of (b --> v) + if(ispin == jspin .and. r.le.v)cycle ! condition not to double count + if(ispin == jspin .and. a.le.b)cycle ! condition not to double count + do istate = 1, N_states + if(ispin == jspin)then + double precision :: contrib_spin + if(ispin == 1)then + contrib_spin = two_body_dm_aa_diag_act(i_a,i_b) + else + contrib_spin = two_body_dm_bb_diag_act(i_a,i_b) + endif + accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin & + * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & + * delta_e(i_a,i_b,ispin,jspin,istate) + else + accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & + * active_int(i_a,i_b,1) + endif + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + +end + diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index dd79edbe..e8d19166 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -1,9 +1,9 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -13,38 +13,72 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] implicit none integer :: i - double precision :: energies(N_states_diag) + double precision :: energies(N_states) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo END_PROVIDER +BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange_bis, (N_states)] + implicit none + integer :: i,j + double precision :: energies(N_states) + integer(bit_kind), allocatable :: psi_in_ref(:,:,:) + allocate (psi_in_ref(N_int,2,n_det_ref)) + integer(bit_kind), allocatable :: psi_in_active(:,:,:) + allocate (psi_in_active(N_int,2,n_det_ref)) + double precision, allocatable :: psi_ref_coef_in(:, :) + allocate(psi_ref_coef_in(N_det_ref, N_states)) + + do i = 1, N_det_ref + do j = 1, N_int + psi_in_ref(j,1,i) = psi_ref(j,1,i) + psi_in_ref(j,2,i) = psi_ref(j,2,i) + + psi_in_active(j,1,i) = psi_active(j,1,i) + psi_in_active(j,2,i) = psi_active(j,2,i) + enddo + do j = 1, N_states + psi_ref_coef_in(i,j) = psi_ref_coef(i,j) + enddo + enddo + do i = 1, N_states + call u0_H_dyall_u0_no_exchange_bis(energies,psi_in_ref,psi_ref_coef_in,n_det_ref,n_det_ref,n_det_ref,N_states,i) + energy_cas_dyall_no_exchange_bis(i) = energies(i) + print*, 'energy_cas_dyall(i)_no_exchange_bis', energy_cas_dyall_no_exchange_bis(i) + enddo + deallocate (psi_in_ref) + deallocate (psi_in_active) + deallocate(psi_ref_coef_in) +END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) use bitmasks integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = 1 spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -53,9 +87,9 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + one_creat(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -68,23 +102,23 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = -1 spin_exc = ispin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -93,9 +127,9 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + one_anhil(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -109,15 +143,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -128,9 +162,9 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = 1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -139,11 +173,11 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -159,16 +193,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target state_target = 1 - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -179,21 +213,23 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + do state_target = 1 , N_states + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + enddo enddo enddo enddo @@ -208,15 +244,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -227,9 +263,9 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -238,16 +274,16 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + !if(orb_i == orb_j .and. ispin .ne. jspin)then + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - else - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - endif + !else + ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + ! one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + !endif enddo enddo enddo @@ -257,23 +293,24 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 END_PROVIDER -BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] + BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +&BEGIN_PROVIDER [ double precision, two_anhil_one_creat_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -289,9 +326,9 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -301,13 +338,14 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) enddo enddo enddo @@ -319,23 +357,70 @@ BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_a END_PROVIDER -BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] + + BEGIN_PROVIDER [ double precision, two_anhil_one_creat_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) + double precision :: accu + do iorb = 1,n_act_orb + orb_i = list_act(iorb) + do jorb = 1, n_act_orb + orb_j = list_act(jorb) + do korb = 1, n_act_orb + orb_k = list_act(korb) + do state_target = 1, N_states + accu = 0.d0 + do ispin = 1,2 + do jspin = 1,2 + do kspin = 1,2 + two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) += two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target)* & + two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) + accu += two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) + enddo + enddo + enddo + two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) = two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) /accu + enddo + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +&BEGIN_PROVIDER [ double precision, two_creat_one_anhil_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + + integer :: iorb,jorb + integer :: korb + integer :: state_target + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -351,24 +436,27 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - do state_target = 1, N_states - call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + + do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) +! print*, norm_out(state_target) enddo enddo enddo @@ -380,6 +468,136 @@ BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_a END_PROVIDER + + BEGIN_PROVIDER [ double precision, two_creat_one_anhil_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] +implicit none + integer :: i,j + integer :: ispin,jspin,kspin + integer :: orb_i, hole_particle_i,spin_exc_i + integer :: orb_j, hole_particle_j,spin_exc_j + integer :: orb_k, hole_particle_k,spin_exc_k + double precision :: norm_out(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + + integer :: iorb,jorb + integer :: korb + integer :: state_target + double precision :: energies(n_states),accu + do iorb = 1,n_act_orb + orb_i = list_act(iorb) + do jorb = 1, n_act_orb + orb_j = list_act(jorb) + do korb = 1, n_act_orb + orb_k = list_act(korb) + do state_target = 1, N_states + accu = 0.d0 + do ispin = 1,2 + do jspin = 1,2 + do kspin = 1,2 + two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) += two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) * & + two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) + accu += two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) + print*, accu + enddo + enddo + enddo + two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) = two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) / accu + enddo + enddo + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef) + +END_PROVIDER + +!BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] +!implicit none +!integer :: i,j +!integer :: ispin,jspin,kspin +!integer :: orb_i, hole_particle_i,spin_exc_i +!integer :: orb_j, hole_particle_j,spin_exc_j +!integer :: orb_k, hole_particle_k,spin_exc_k +!double precision :: norm_out(N_states) +!integer(bit_kind), allocatable :: psi_in_out(:,:,:) +!double precision, allocatable :: psi_in_out_coef(:,:) +!use bitmasks +!allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + +!integer :: iorb,jorb +!integer :: korb +!integer :: state_target +!double precision :: energies(n_states) +!double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) +!double precision :: thresh_norm +!thresh_norm = 1.d-10 +!do iorb = 1,n_act_orb +! orb_i = list_act(iorb) +! hole_particle_i = 1 +! do jorb = 1, n_act_orb +! orb_j = list_act(jorb) +! hole_particle_j = 1 +! do korb = 1, n_act_orb +! orb_k = list_act(korb) +! hole_particle_k = -1 + +! ! loop on the spins +! ! By definition, orb_i is the particle of spin ispin +! ! a^+_{ispin , orb_i} +! do ispin = 1, 2 +! do jspin = 1, 2 +! ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin +! ! a^+_{jspin , orb_j} a_{jspin , orb_k} +! ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > +! ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > +! do i = 1, n_det_ref +! do j = 1, n_states +! psi_in_out_coef(i,j) = psi_ref_coef(i,j) +! enddo +! do j = 1, N_int +! psi_in_out(j,1,i) = psi_active(j,1,i) +! psi_in_out(j,2,i) = psi_active(j,2,i) +! enddo +! enddo +! do state_target = 1, N_states +! ! hole :: hole_particle_k, jspin +! call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & +! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) +! if(dabs(norm_out(state_target)).lt.thresh_norm)then +! norm_spins(ispin,jspin,state_target) = 0.d0 +! else +! norm_spins(ispin,jspin,state_target) = 1.d0 +! endif +! call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) +! energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) +! enddo +! enddo +! enddo +! integer :: icount +! ! averaging over all possible spin permutations with Heaviside norm +! do state_target = 1, N_states +! icount = 0 +! do jspin = 1, 2 +! do ispin = 1, 2 +! icount += 1 +! two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) +! enddo +! enddo +! two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) +! enddo +! enddo +! enddo +!enddo +!deallocate(psi_in_out,psi_in_out_coef) + +!END_PROVIDER + BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j @@ -387,16 +605,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -412,9 +630,9 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = 1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -423,13 +641,13 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -448,16 +666,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -473,9 +691,9 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det - do j = 1, n_states_diag - psi_in_out_coef(i,j) = psi_coef(i,j) + do i = 1, n_det_ref + do j = 1, n_states + psi_in_out_coef(i,j) = psi_ref_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -484,13 +702,13 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) enddo enddo enddo @@ -511,24 +729,32 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + integer(bit_kind), allocatable :: psi_in_active(:,:,:) + allocate (psi_in_active(N_int,2,n_det_ref)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij + double precision :: energies(n_states) + double precision :: hij,hij_test double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) double precision :: thresh_norm + integer :: other_spin(2) + other_spin(1) = 2 + other_spin(2) = 1 - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 +!do i = 1, N_det_ref +! print*, psi_ref_coef(i,1) +!enddo do vorb = 1,n_virt_orb @@ -541,10 +767,10 @@ END_PROVIDER do state_target =1 , N_states one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 enddo - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -552,11 +778,12 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + integer :: exc(0:2,2,2) + double precision :: phase + call get_mono_excitation(psi_in_out(1,1,i),psi_ref(1,1,i),exc,phase,N_int) do j = 1, n_states - double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + psi_in_out_coef(i,j) = psi_ref_coef(i,j)* hij * phase norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo @@ -567,38 +794,36 @@ END_PROVIDER one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 else norm_no_inv(j,ispin) = norm(j,ispin) - one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) endif enddo - do i = 1, N_det + integer :: iorb_annil,hole_particle,spin_exc,orb + double precision :: norm_out_bis(N_states) + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo + enddo + + do i = 1, N_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) -! energies_alpha_beta(state_target, ispin) = 0.d0 + energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & -! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & -! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 @@ -616,15 +841,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer :: i,iorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -632,7 +857,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta double precision :: thresh_norm - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -645,10 +870,10 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) if(i_ok.ne.1)then @@ -656,11 +881,11 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo endif @@ -675,7 +900,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -688,24 +913,20 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & +! one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & + one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_inact(iorb,aorb,state_target) = 0.d0 endif -! print*, '********' -! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) -! print*, norm_bis(state_target,1) , norm_bis(state_target,2) -! print*, one_anhil_inact(iorb,aorb,state_target) -! print*, one_creat(aorb,1,state_target) enddo enddo enddo @@ -719,15 +940,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag) + double precision :: norm_out(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -735,7 +956,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State double precision :: thresh_norm - thresh_norm = 1.d-10 + thresh_norm = 1.d-20 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -748,10 +969,10 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -759,16 +980,21 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) do j = 1, n_states - double precision :: coef,contrib - coef = psi_coef(i,j) !* psi_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij + double precision :: contrib + psi_in_out_coef(i,j) = psi_ref_coef(i,j) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) + !if(orb_a == 6 .and. orb_v == 12)then + ! print*, j,psi_ref_coef(i,j),psi_in_out_coef(i,j) + !endif enddo endif enddo do j = 1, N_states +! if(orb_a == 6 .and. orb_v == 12)then +! print*, 'norm',norm(j,ispin) +! endif if (dabs(norm(j,ispin)) .le. thresh_norm)then norm(j,ispin) = 0.d0 norm_no_inv(j,ispin) = norm(j,ispin) @@ -778,7 +1004,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det + do i = 1, N_det_ref do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -791,18 +1017,18 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) -! print*, energies(state_target) + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & + one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else +! one_creat_virt(aorb,vorb,state_target) = 0.5d0 * (one_anhil(aorb, 1,state_target) + one_anhil(aorb, 2,state_target) ) one_creat_virt(aorb,vorb,state_target) = 0.d0 endif ! print*, '********' @@ -815,190 +1041,42 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State enddo deallocate(psi_in_out,psi_in_out_coef) -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] -&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] - implicit none - integer :: i,vorb,j - integer :: ispin,jspin - integer :: orb_i, hole_particle_i - integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) - double precision :: delta_e_inact_virt(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1)) - - integer :: iorb,jorb,i_ok - integer :: state_target - double precision :: energies(n_states_diag) - double precision :: hij - double precision :: energies_alpha_beta(N_states,2) - - - double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) - - corr_e_from_1h1p = 0.d0 - do vorb = 1,n_virt_orb - orb_v = list_virt(vorb) - do iorb = 1, n_inact_orb - orb_i = list_inact(iorb) -! print*, '---------------------------------------------------------------------------' - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - - fock_virt_total_spin_trace(orb_v,j) - enddo - do ispin = 1,2 - do i = 1, n_det - do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) - enddo - call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) - if(i_ok.ne.1)then - print*, orb_i,orb_v - call debug_det(psi_in_out,N_int) - print*, 'pb, i_ok ne 0 !!!' - endif - interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - interact_psi0(i) += hij * psi_coef(j,1) - enddo - do j = 1, N_int - psi_in_out(j,1,i) = psi_active(j,1,i) - psi_in_out(j,2,i) = psi_active(j,2,i) - enddo - call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) - diag_elem(i) = hij - enddo - do state_target = 1, N_states - ! Building the Hamiltonian matrix - H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det - ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) - ! diagonal elements - H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) -! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det - call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) - H_matrix(i+1,j+1) = hij !0.d0 ! - H_matrix(j+1,i+1) = hij !0.d0 ! - enddo - enddo - print*, '***' - do i = 1, N_det+1 - write(*,'(100(F16.10,1X))')H_matrix(i,:) - enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) - corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - norm = 0.d0 - do i = 1, N_det - psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) -!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then - if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then -! if(dabs(interact_psi0(i)) .gt. 1.d-8)then - delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) -! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) - amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) - else - amplitudes_alpha_beta(i,ispin) = 0.d0 - delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) - endif -!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) - norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) - enddo - print*, 'Coef ' - write(*,'(100(1X,F16.10))')psi_coef(1:N_det,state_target) - write(*,'(100(1X,F16.10))')psi_in_out_coef(:,state_target) - double precision :: coef_tmp(N_det) - do i = 1, N_det - coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) - enddo - write(*,'(100(1X,F16.10))')coef_tmp(:) - print*, 'naked interactions' - write(*,'(100(1X,F16.10))')interact_psi0(:) - print*, '' - - print*, 'norm ',norm - norm = 1.d0/(norm) - accu(state_target) = 0.d0 - do i = 1, N_det - accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) - do j = i+1, N_det - accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) - enddo - enddo - accu(state_target) = accu(state_target) * norm - print*, delta_e_inact_virt(state_target) - print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) - print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) - - enddo - enddo ! ispin - do state_target = 1, N_states - do i = 1, N_det - one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & - ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) - enddo - enddo - print*, '***' - write(*,'(100(1X,F16.10))') - write(*,'(100(1X,F16.10))')delta_e_alpha_beta(:,2) - ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) - ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) - print*, '---------------------------------------------------------------------------' - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) - print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) - END_PROVIDER subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,N_states) double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) integer :: i,vorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: norm_out(N_states),diag_elem(N_det_ref),interact_psi0(N_det_ref) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) double precision, allocatable :: delta_e_det(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) - allocate (eigenvectors(size(H_matrix,1),N_det+1)) - allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) - allocate (delta_e_det(N_det,N_det)) + allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) + allocate (eigenvectors(size(H_matrix,1),N_det_ref+1)) + allocate (eigenvalues(N_det_ref+1),interact_cas(N_det_ref,N_det_ref)) + allocate (delta_e_det(N_det_ref,N_det_ref)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states_diag) + double precision :: energies(n_states) double precision :: hij double precision :: energies_alpha_beta(N_states,2) - double precision :: lamda_pt2(N_det) + double precision :: lamda_pt2(N_det_ref) double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det,2) - double precision :: delta_e_alpha_beta(N_det,2) + double precision :: amplitudes_alpha_beta(N_det_ref,2) + double precision :: delta_e_alpha_beta(N_det_ref,2) double precision :: coef_array(N_states) - double precision :: coef_perturb(N_det) - double precision :: coef_perturb_bis(N_det) + double precision :: coef_perturb(N_det_ref) + double precision :: coef_perturb_bis(N_det_ref) do vorb = 1,n_virt_orb orb_v = list_virt(vorb) @@ -1009,10 +1087,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det + do i = 1, n_det_ref do j = 1, N_int - psi_in_out(j,1,i) = psi_det(j,1,i) - psi_in_out(j,2,i) = psi_det(j,2,i) + psi_in_out(j,1,i) = psi_ref(j,1,i) + psi_in_out(j,2,i) = psi_ref(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -1021,11 +1099,11 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'pb, i_ok ne 0 !!!' endif interact_psi0(i) = 0.d0 - do j = 1 , N_det - call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + do j = 1 , N_det_ref + call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) interact_cas(i,j) = hij - interact_psi0(i) += hij * psi_coef(j,1) + interact_psi0(i) += hij * psi_ref_coef(j,1) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -1037,27 +1115,27 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from do state_target = 1, N_states ! Building the Hamiltonian matrix H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det + do i = 1, N_det_ref ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(1,i+1) = interact_psi0(i)!* psi_ref_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_ref_coef(i,state_target) ! diagonal elements H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) ! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det + do j = i+1, N_det_ref call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) H_matrix(i+1,j+1) = hij !0.d0 ! H_matrix(j+1,i+1) = hij !0.d0 ! enddo enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det_ref+1) e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - do i = 1, N_det + do i = 1, N_det_ref psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) coef_perturb(i) = 0.d0 - do j = 1, N_det - coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) + do j = 1, N_det_ref + coef_perturb(i) += psi_ref_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) enddo coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) if(dabs(interact_psi0(i)) .gt. 1.d-12)then @@ -1068,22 +1146,22 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from enddo if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then print*, '' - do i = 1, N_det+1 + do i = 1, N_det_ref+1 write(*,'(100(F16.10))') H_matrix(i,:) enddo accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) enddo print*, '' print*, 'e corr diagonal ',accu(state_target) accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += coef_perturb(i) * interact_psi0(i) enddo print*, 'e corr perturb ',accu(state_target) accu = 0.d0 - do i = 1, N_det + do i = 1, N_det_ref accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) enddo print*, 'e corr perturb EN',accu(state_target) @@ -1096,10 +1174,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from write(*,'(100(F16.10,1X))')coef_perturb_bis(:) endif integer :: k - do k = 1, N_det - do i = 1, N_det + do k = 1, N_det_ref + do i = 1, N_det_ref matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) - do j = i+1, N_det + do j = i+1, N_det_ref matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) enddo diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 491cda58..9376e0cc 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -25,6 +25,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor +! print*, orb,hole_particle,spin_exc elec_num_tab_local = 0 do i = 1, ndet @@ -36,6 +37,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & exit endif enddo +! print*, elec_num_tab_local(1),elec_num_tab_local(2) if(hole_particle == 1)then do i = 1, ndet call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) @@ -212,52 +214,97 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo -! print*,'core_act = ',core_act -! print*,'alpha_alpha = ',alpha_alpha -! print*,'alpha_beta = ',alpha_beta -! print*,'beta_beta = ',beta_beta -! print*,'mono_elec = ',mono_elec - -! do i = 1, n_core_inact_orb -! iorb = list_core_inact(i) -! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) -! enddo - - -!!!!!!!!!!!! -return -!!!!!!!!!!!! - - - ! alpha - alpha - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) - do j = i+1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) - enddo - enddo - - do i = 1, n_core_inact_orb - iorb = list_core_inact(i) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - enddo - enddo end + + + +double precision function diag_H_mat_elem_no_elec_check_no_spin(det_in,Nint) + implicit none + BEGIN_DOC + ! Computes + END_DOC + integer,intent(in) :: Nint + integer(bit_kind),intent(in) :: det_in(Nint,2) + + integer :: i, j, iorb, jorb + integer :: occ(Nint*bit_kind_size,2) + integer :: elec_num_tab_local(2) + + double precision :: core_act + double precision :: alpha_alpha + double precision :: alpha_beta + double precision :: beta_beta + double precision :: mono_elec + core_act = 0.d0 + alpha_alpha = 0.d0 + alpha_beta = 0.d0 + beta_beta = 0.d0 + mono_elec = 0.d0 + + diag_H_mat_elem_no_elec_check_no_spin = 0.d0 + call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) + call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) + ! alpha - alpha + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + alpha_alpha += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + ! beta - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) + mono_elec += mo_mono_elec_integral(iorb,iorb) + do j = i+1, elec_num_tab_local(2) + jorb = occ(j,2) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + beta_beta += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - beta + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, elec_num_tab_local(1) + jorb = occ(j,1) + diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) + alpha_beta += mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + + ! alpha - core-act + do i = 1, elec_num_tab_local(1) + iorb = occ(i,1) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + + ! beta - core-act + do i = 1, elec_num_tab_local(2) + iorb = occ(i,2) + do j = 1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + enddo + enddo + +end + + subroutine i_H_j_dyall(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -389,6 +436,133 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) end +subroutine i_H_j_dyall_no_spin(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2 + integer :: n_occ_ab(2) + logical :: has_mipi(Nint*bit_kind_size) + double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) + PROVIDE mo_bielec_integrals_in_map mo_integrals_map + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )then + hij = 0.d0 + else + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*get_mo_bielec_integral( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_map) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*get_mo_bielec_integral( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_map) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + has_mipi = .False. + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) !- miip(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) + enddo + + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + do k = 1, n_occ_ab(2) + i = occ(k,2) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + do k = 1, n_occ_ab(1) + i = occ(k,1) + if (.not.has_mipi(i)) then + mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) + has_mipi(i) = .True. + endif + enddo + + do k = 1, n_occ_ab(1) + hij = hij + mipi(occ(k,1)) + enddo + do k = 1, n_occ_ab(2) + hij = hij + mipi(occ(k,2)) !- miip(occ(k,2)) + enddo + + endif + hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) + + case (0) + double precision :: diag_H_mat_elem_no_elec_check_no_spin + hij = diag_H_mat_elem_no_elec_check_no_spin(key_i,Nint) + end select +end + + + subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) use bitmasks implicit none @@ -414,6 +588,7 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe do j = 1, ndet if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) +! call i_H_j_dyall_no_spin(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo @@ -502,6 +677,7 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size) + double precision :: diag_H_mat_elem PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) @@ -598,9 +774,12 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) +! hij = phase*(hij + mo_mono_elec_integral(m,p) ) case (0) hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) +! hij = diag_H_mat_elem(key_i,Nint) +! hij = 0.d0 end select end @@ -625,7 +804,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! alpha - alpha do i = 1, elec_num_tab_local(1) iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -635,7 +814,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! beta - beta do i = 1, elec_num_tab_local(2) iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -653,13 +832,16 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) enddo +! return + ! alpha - core-act do i = 1, elec_num_tab_local(1) iorb = occ(i,1) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1) enddo enddo @@ -669,7 +851,8 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) +! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2) enddo enddo @@ -706,3 +889,45 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in energies(state_target) = accu deallocate(psi_coef_tmp) end + + + +!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) +subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) + use bitmasks + implicit none + integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target +!integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in),psi_in_active(N_int,2,dim_psi_in) + integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) + double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) + double precision, intent(out) :: energies(N_states_in) + + integer :: i,j + double precision :: hij,accu + energies = 0.d0 + accu = 0.d0 + double precision, allocatable :: psi_coef_tmp(:) + allocate(psi_coef_tmp(ndet)) + + do i = 1, ndet + psi_coef_tmp(i) = psi_in_coef(i,state_target) + enddo + + double precision :: hij_bis,diag_H_mat_elem + do i = 1, ndet + if(psi_coef_tmp(i)==0.d0)cycle + do j = i+1, ndet + if(psi_coef_tmp(j)==0.d0)cycle +! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij) + call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) + accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij + enddo + enddo + do i = 1, N_det + if(psi_coef_tmp(i)==0.d0)cycle + accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int) + enddo + energies(state_target) = accu + deallocate(psi_coef_tmp) +end + diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index d4ce0661..f16aba26 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -197,7 +197,7 @@ k_inact_core_orb = list_core_inact(k) coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) - accu += 2.d0 * coulomb - exchange + accu += 2.d0 * coulomb - exchange enddo fock_operator_active_from_core_inact(iorb,jorb) = accu enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index 275af0e4..a08b6108 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -44,11 +44,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: N_miniList, leng double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j - double precision :: phase_array(N_det),phase + double precision :: phase_array(N_det_ref),phase integer :: exc(0:2,2,2),degree - leng = max(N_det_generators, N_det) + leng = max(N_det_generators, N_det_generators) allocate(miniList(Nint, 2, leng), idx_miniList(leng)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) @@ -59,35 +59,81 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip end if - call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then - call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) + call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint) end if + double precision :: coef_array(N_states) do i_alpha=1,N_tq +! do i = 1, N_det_ref +! do i_state = 1, N_states +! coef_array(i_state) = psi_ref_coef(i,i_state) +! enddo +! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha) +! if(dabs(hialpha).le.1.d-20)then +! do i_state = 1, N_states +! delta_e(i_state) = 1.d+20 +! enddo +! else +! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) +! endif +! hij_array(i) = hialpha +! do i_state = 1,N_states +! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state) +! enddo +! enddo +! do i = 1, N_det_ref +! do j = 1, N_det_ref +! do i_state = 1, N_states +! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state) +! enddo +! enddo +! enddo +! cycle + + + + ! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) do j=1,idx_alpha(0) idx_alpha(j) = idx_miniList(idx_alpha(j)) enddo -! double precision :: ihpsi0,coef_pert -! ihpsi0 = 0.d0 -! coef_pert = 0.d0 phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) - double precision :: coef_array(N_states) + call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) do i_state = 1, N_states - coef_array(i_state) = psi_coef(index_i,i_state) + coef_array(i_state) = psi_ref_coef(index_i,i_state) enddo - call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) + integer :: degree_scalar + + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) +! if(degree_scalar == 2)then +! hialpha = 0.d0 +! endif + if(dabs(hialpha).le.1.d-20)then + do i_state = 1, N_states + delta_e(i_state) = 1.d+20 + enddo + else + call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e) + if(degree_scalar.eq.1)then + delta_e = 1.d+20 + endif +! print*, 'delta_e',delta_e + !!!!!!!!!!!!! SHIFTED BK +! double precision :: hjj +! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) +! delta_e(1) = electronic_psi_ref_average_value(1) - hjj +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + endif hij_array(index_i) = hialpha - call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) -! phase_array(index_i) = phase +! print*, 'hialpha ',hialpha do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -99,18 +145,14 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) -! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) -! if(index_j.ne.index_i)then -! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then -! print*, phase_array(index_j) , phase_array(index_i) ,phase -! call debug_det(psi_det(1,1,index_i),N_int) -! call debug_det(psi_det(1,1,index_j),N_int) -! call debug_det(tq(1,1,i_alpha),N_int) -! stop -! endif -! endif + !!!!!!!!!!!!!!!!!! WARNING TEST + !!!!!!!!!!!!!!!!!! WARNING TEST +! if(index_j .ne. index_i)cycle + !!!!!!!!!!!!!!!!!! WARNING TEST + !!!!!!!!!!!!!!!!!! WARNING TEST + !!!!!!!!!!!!!!!!!! WARNING TEST do i_state=1,N_states -! standard dressing first order + ! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) enddo enddo @@ -122,23 +164,23 @@ end - BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] -&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] - gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) - gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) - call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) - call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ] + gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref) + gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int) END_PROVIDER -subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) +subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) use bitmasks implicit none - integer, intent(in) :: i_generator,n_selected, Nint + integer, intent(in) :: n_selected, Nint integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,m @@ -155,7 +197,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N logical, external :: is_connected_to - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref) integer,intent(in) :: N_miniList @@ -168,7 +210,7 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N cycle end if - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then N_tq += 1 do k=1,N_int tq(k,1,N_tq) = det_buffer(k,1,i) @@ -179,8 +221,3 @@ subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N end - - - - - diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index d7b1f0f6..79aa624f 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -34,43 +34,44 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h(i_state) = accu(i_state) enddo print*, '1h = ',accu - ! 1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1p(i_state) = accu(i_state) - enddo - print*, '1p = ',accu +!! 1p +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_1p(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_1p(i_state) = accu(i_state) +!enddo +!print*, '1p = ',accu ! 1h1p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) - double precision :: e_corr_from_1h1p_singles(N_states) -!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) -!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h1p(i_state) = accu(i_state) - enddo - print*, '1h1p = ',accu +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) +!double precision :: e_corr_from_1h1p_singles(N_states) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_1h1p(i_state) = accu(i_state) +!enddo +!print*, '1h1p = ',accu ! 1h1p third order if(do_third_order_1h1p)then @@ -83,75 +84,80 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo + write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h1p(i_state) = accu(i_state) enddo print*, '1h1p(3)',accu endif - ! 2h - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2h(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h(i_state) = accu(i_state) - enddo - print*, '2h = ',accu +!! 2h +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_2h(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_2h(i_state) = accu(i_state) +!enddo +!print*, '2h = ',accu - ! 2p - delta_ij_tmp = 0.d0 - call H_apply_mrpt_2p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2p(i_state) = accu(i_state) - enddo - print*, '2p = ',accu +!! 2p +!delta_ij_tmp = 0.d0 +!call H_apply_mrpt_2p(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_2p(i_state) = accu(i_state) +!enddo +!print*, '2p = ',accu ! 1h2p delta_ij_tmp = 0.d0 !call give_1h2p_contrib(delta_ij_tmp) - call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_1h2p(i_state) = accu(i_state) - enddo - print*, '1h2p = ',accu +!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_1h2p(i_state) = accu(i_state) +!enddo +!print*, '1h2p = ',accu - ! 2h1p - delta_ij_tmp = 0.d0 +!! 2h1p +!delta_ij_tmp = 0.d0 !call give_2h1p_contrib(delta_ij_tmp) - call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) - accu = 0.d0 - do i_state = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) - delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) - enddo - enddo - second_order_pt_new_2h1p(i_state) = accu(i_state) - enddo - print*, '2h1p = ',accu +!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) +!accu = 0.d0 +!do i_state = 1, N_states +!do i = 1, N_det +! do j = 1, N_det +! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) +! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) +! enddo +! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) +!enddo +!second_order_pt_new_2h1p(i_state) = accu(i_state) +!enddo +!print*, '2h1p = ',accu - ! 2h2p +!! 2h2p !delta_ij_tmp = 0.d0 !call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) !accu = 0.d0 @@ -178,10 +184,13 @@ ! total + print*, '' + print*, 'total dressing' + print*, '' accu = 0.d0 do i_state = 1, N_states do i = 1, N_det -! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) + write(*,'(1000(F16.10,x))')delta_ij(i,:,:) do j = i_state, N_det accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) enddo @@ -223,7 +232,7 @@ END_PROVIDER enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] + BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_electronic_energy, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] BEGIN_DOC @@ -245,7 +254,7 @@ END_PROVIDER integer, allocatable :: iorder(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states_diag,N_det) + do j=1,min(N_states,N_det) do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) enddo @@ -267,7 +276,7 @@ END_PROVIDER allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + Hmatrix_dressed_pt2_new_symmetrized,size(H_matrix_all_dets,1),N_det) CI_electronic_energy(:) = 0.d0 if (s2_eig) then i_state = 0 @@ -276,8 +285,10 @@ END_PROVIDER good_state_array = .False. call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& N_det,size(eigenvectors,1)) + print*,'N_det',N_det do j=1,N_det ! Select at least n_states states with S^2 values closed to "expected_s2" + print*, s2_eigvalues(j),expected_s2 if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then i_state +=1 index_good_state_array(i_state) = j @@ -291,10 +302,10 @@ END_PROVIDER ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo - CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 do j = 1, N_det @@ -304,10 +315,10 @@ END_PROVIDER exit endif do i=1,N_det - CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo - CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + CI_dressed_pt2_new_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) enddo else @@ -322,10 +333,10 @@ END_PROVIDER print*,'' do j=1,min(N_states_diag,N_det) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) - CI_eigenvectors_s2(j) = s2_eigvalues(j) + CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) enddo endif deallocate(index_good_state_array,good_state_array) @@ -336,9 +347,9 @@ END_PROVIDER ! Select the "N_states_diag" states of lowest energy do j=1,min(N_det,N_states_diag) do i=1,N_det - CI_eigenvectors(i,j) = eigenvectors(i,j) + CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_electronic_energy(j) = eigenvalues(j) + CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) @@ -358,7 +369,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] character*(8) :: st call write_time(output_determinants) do j=1,N_states_diag - CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion + CI_dressed_pt2_new_energy(j) = CI_dressed_pt2_new_electronic_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index fa5812e1..a007e761 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -1,7 +1,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p) active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det,3) + integer :: index_orb_act_mono(N_det_ref,3) - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a @@ -129,6 +129,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer :: kspin do jdet = 1, idx(0) if(idx(jdet).ne.idet)then +! cycle ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator ! are connected by the presence of the perturbers determinants |det_tmp> aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} @@ -150,7 +151,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,2) - active_int(borb,1) ) else @@ -195,7 +196,7 @@ end subroutine give_1h2p_contrib(matrix_1h2p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*) integer :: i,v,r,a,b integer :: iorb, vorb, rorb, aorb, borb integer :: ispin,jspin @@ -213,16 +214,18 @@ subroutine give_1h2p_contrib(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_1h2p = 0.d0 - elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo +!do i = 1, 1 ! First inactive do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) +! do v = 1, 1 do v = 1, n_virt_orb ! First virtual vorb = list_virt(v) +! do r = 1, 1 do r = 1, n_virt_orb ! Second virtual rorb = list_virt(r) ! take all the integral you will need for i,j,r fixed @@ -232,14 +235,14 @@ subroutine give_1h2p_contrib(matrix_1h2p) active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det,3) + integer :: index_orb_act_mono(N_det_ref,3) - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -247,8 +250,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) aorb = list_act(a) if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -258,7 +261,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_det(idet) + ! Check if the excitation is possible or not on psi_ref(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -280,7 +283,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & @@ -308,7 +311,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a @@ -350,7 +353,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -393,130 +396,10 @@ subroutine give_1h2p_contrib(matrix_1h2p) end -subroutine give_1h1p_contrib(matrix_1h1p) - use bitmasks - implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) - integer :: i,j,r,a,b - integer :: iorb, jorb, rorb, aorb, borb - integer :: ispin,jspin - integer :: idet,jdet - integer :: inint - integer :: elec_num_tab_local(2),acu_elec - integer(bit_kind) :: det_tmp(N_int,2) - integer :: exc(0:2,2,2) - integer :: accu_elec - double precision :: get_mo_bielec_integral - double precision :: active_int(n_act_orb,2) - double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) - integer :: istate - double precision :: hja,delta_e_inact_virt(N_states) - integer :: kspin,degree_scalar -!matrix_1h1p = 0.d0 - - elec_num_tab_local = 0 - do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) - enddo - do i = 1, n_inact_orb ! First inactive - iorb = list_inact(i) - do r = 1, n_virt_orb ! First virtual - rorb = list_virt(r) - do j = 1, N_states - delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - - fock_virt_total_spin_trace(rorb,j) - enddo - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations - do jdet = 1, idx(0) - do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) - enddo - ! Do the excitation inactive -- > virtual - double precision :: himono,delta_e(N_states),coef_mono(N_states) - call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin - call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) - - do state_target = 1, N_states -! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) - delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) - coef_mono(state_target) = himono / delta_e(state_target) - enddo - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - ! Mono beta - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - if(ispin == jspin )then - hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & - + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) - else - hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) - endif - hij = hij * phase - double precision :: hij_test - integer :: state_target - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - if(dabs(hij - hij_test).gt.1.d-10)then - print*, 'ahah pb !!' - print*, 'hij .ne. hij_test' - print*, hij,hij_test - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - print*, ispin, jspin - print*,iorb,borb,rorb,aorb - print*, phase - call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - stop - endif - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) - enddo - else - do state_target = 1, N_states - matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) - enddo - endif - enddo - enddo - - - - enddo - enddo - enddo -end - subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -533,8 +416,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer :: kspin,degree_scalar @@ -542,13 +425,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) do r = 1, n_virt_orb ! First virtual @@ -563,13 +446,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -619,9 +502,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do r = 1, n_virt_orb ! First virtual rorb = list_virt(r) do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - do state_target = 1, N_states - coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) - enddo + !do state_target = 1, N_states + ! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) + !enddo do inint = 1, N_int det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) @@ -629,37 +512,37 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) enddo do jdet = 1, idx(0) ! - if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) - if (exc(0,1,1) == 1) then - ! Mono alpha - aorb = (exc(1,2,1)) !!! a^{\dagger}_a - borb = (exc(1,1,1)) !!! a_{b} - jspin = 1 - else - aorb = (exc(1,2,2)) !!! a^{\dagger}_a - borb = (exc(1,1,2)) !!! a_{b} - jspin = 2 - endif - - call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - if(degree_scalar .ne. 2)then - print*, 'pb !!!' - print*, degree_scalar - call debug_det(psi_det(1,1,idx(jdet)),N_int) - call debug_det(det_tmp,N_int) - stop - endif - call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) double precision :: hij_test - hij_test = 0.d0 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) - do state_target = 1, N_states - matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - enddo + if(idx(jdet).ne.idet)then + ! call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + ! if (exc(0,1,1) == 1) then + ! ! Mono alpha + ! aorb = (exc(1,2,1)) !!! a^{\dagger}_a + ! borb = (exc(1,1,1)) !!! a_{b} + ! jspin = 1 + ! else + ! aorb = (exc(1,2,2)) !!! a^{\dagger}_a + ! borb = (exc(1,1,2)) !!! a_{b} + ! jspin = 2 + ! endif + ! + ! call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + ! if(degree_scalar .ne. 2)then + ! print*, 'pb !!!' + ! print*, degree_scalar + ! call debug_det(psi_ref(1,1,idx(jdet)),N_int) + ! call debug_det(det_tmp,N_int) + ! stop + ! endif + ! call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + ! hij_test = 0.d0 + ! call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) + ! do state_target = 1, N_states + ! matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + ! enddo else hij_test = 0.d0 - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo @@ -676,7 +559,7 @@ end subroutine give_1p_sec_order_singles_contrib(matrix_1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -692,8 +575,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) integer :: accu_elec double precision :: get_mo_bielec_integral double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_act_virt(N_states) integer :: kspin,degree_scalar @@ -701,13 +584,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det - call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) do i = 1, n_act_orb ! First active iorb = list_act(i) do r = 1, n_virt_orb ! First virtual @@ -721,8 +604,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation active -- > virtual call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) @@ -739,7 +622,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo cycle endif - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -801,10 +684,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) enddo - do jdet = 1,N_det + do jdet = 1,N_det_ref double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) do state_target = 1, N_states ! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) @@ -822,7 +705,7 @@ end subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -835,8 +718,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_ref) + integer :: idx(0:N_det_ref) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) @@ -850,8 +733,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -861,8 +744,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - fock_virt_total_spin_trace(rorb,j) enddo - do idet = 1, N_det - call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + do idet = 1, N_det_ref + call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do ispin = 1, 2 @@ -872,8 +755,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) do b = 1, n_act_orb borb = list_act(b) do inint = 1, N_int - det_tmp(inint,1) = psi_det(inint,1,idet) - det_tmp(inint,2) = psi_det(inint,2,idet) + det_tmp(inint,1) = psi_ref(inint,1,idet) + det_tmp(inint,2) = psi_ref(inint,2,idet) enddo ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) integer :: i_ok,corb,dorb @@ -904,7 +787,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) enddo - call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) + call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble) do state_target = 1, N_states delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) @@ -915,7 +798,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) enddo do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) integer :: c,d,state_target integer(bit_kind) :: det_tmp_bis(N_int,2) ! excitation from I --> J @@ -935,8 +818,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) enddo double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) enddo diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 781be55b..b67f7498 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) perturb_dets_phase(a,2,1) = -1000.d0 enddo - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate @@ -376,8 +376,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,6) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index 794742b4..f86947d8 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end -subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) +subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) BEGIN_DOC ! routine that returns the delta_e with the Moller Plesset and Dyall operators ! @@ -170,7 +170,6 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) use bitmasks double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) - double precision, intent(in) :: coef_array(N_states),hij integer :: i,j,k,l integer :: i_state @@ -355,7 +354,8 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) kspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) do i_state = 1, N_states - delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) +! delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) + delta_e_act(i_state) += two_anhil_one_creat_spin_average(i_particle_act,i_hole_act,j_hole_act,i_state) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then @@ -370,7 +370,9 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) j_particle_act = particle_list_practical(2,2) do i_state = 1, N_states - delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) +! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) + delta_e_act(i_state) += 0.5d0 * (two_creat_one_anhil_spin_average(i_particle_act,j_particle_act,i_hole_act,i_state) & + +two_creat_one_anhil_spin_average(j_particle_act,i_particle_act,i_hole_act,i_state)) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then @@ -433,3 +435,4 @@ subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) end + diff --git a/plugins/Perturbation/pt2_new.irp.f b/plugins/MRPT_Utils/pt2_new.irp.f similarity index 100% rename from plugins/Perturbation/pt2_new.irp.f rename to plugins/MRPT_Utils/pt2_new.irp.f diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index ba3b421b..2a61eece 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: delta_e_inactive_virt(N_states) @@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: fock_operator_local(n_act_orb,n_act_orb,2) double precision :: delta_e_inactive_virt(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f index 11ae18da..d086b6c5 100644 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p) double precision :: active_int(n_act_orb,n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det) - integer :: idx(0:N_det) + integer :: degree(N_det_Ref) + integer :: idx(0:N_det_Ref) double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inactive_virt(N_states) diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index 25b89c5f..f7999340 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock Davidson MRPT_Utils +Determinants Properties Hartree_Fock Davidson diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index b29e130f..5839c20c 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -46,36 +46,6 @@ subroutine pt2_epstein_nesbet ($arguments) end -subroutine pt2_decontracted ($arguments) - use bitmasks - implicit none - $declarations - - BEGIN_DOC - END_DOC - - integer :: i,j - double precision :: diag_H_mat_elem_fock, h - double precision :: i_H_psi_array(N_st) - double precision :: coef_pert - PROVIDE selection_criterion - - ASSERT (Nint == N_int) - ASSERT (Nint > 0) - !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) - call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) - H_pert_diag = 0.d0 - - - c_pert(1) = coef_pert - e_2_pert(1) = coef_pert * i_H_psi_array(1) -! print*,coef_pert,i_H_psi_array(1) - -end - - - - subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index 87439764..8380d668 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,6 +67,27 @@ END_PROVIDER END_PROVIDER + + BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)] +&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)] + implicit none + integer :: i,j + electronic_psi_ref_average_value = psi_energy + do i = 1, N_states + psi_ref_average_value(i) = psi_energy(i) + nuclear_repulsion + enddo + double precision :: accu,hij + accu = 0.d0 + do i = 1, N_det_ref + do j = 1, N_det_ref + call i_H_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij) + accu += psi_ref_coef(i,1) * psi_ref_coef(j,1) * hij + enddo + enddo + electronic_psi_ref_average_value(1) = accu + psi_ref_average_value(1) = electronic_psi_ref_average_value(1) + nuclear_repulsion + +END_PROVIDER BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] &BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] implicit none diff --git a/plugins/SCF_density/.gitignore b/plugins/SCF_density/.gitignore new file mode 100644 index 00000000..9f1c0929 --- /dev/null +++ b/plugins/SCF_density/.gitignore @@ -0,0 +1,25 @@ +# Automatically created by $QP_ROOT/scripts/module/module_handler.py +.ninja_deps +.ninja_log +AO_Basis +Bitmask +Electrons +Ezfio_files +Huckel_guess +IRPF90_man +IRPF90_temp +Integrals_Bielec +Integrals_Monoelec +MOGuess +MO_Basis +Makefile +Makefile.depend +Nuclei +Pseudo +SCF +Utils +ZMQ +ezfio_interface.irp.f +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/SCF_density/EZFIO.cfg b/plugins/SCF_density/EZFIO.cfg new file mode 100644 index 00000000..2fa29cf0 --- /dev/null +++ b/plugins/SCF_density/EZFIO.cfg @@ -0,0 +1,35 @@ +[thresh_scf] +type: Threshold +doc: Threshold on the convergence of the Hartree Fock energy +interface: ezfio,provider,ocaml +default: 1.e-10 + +[n_it_scf_max] +type: Strictly_positive_int +doc: Maximum number of SCF iterations +interface: ezfio,provider,ocaml +default: 200 + +[level_shift] +type: Positive_float +doc: Energy shift on the virtual MOs to improve SCF convergence +interface: ezfio,provider,ocaml +default: 0.5 + +[mo_guess_type] +type: MO_guess +doc: Initial MO guess. Can be [ Huckel | HCore ] +interface: ezfio,provider,ocaml +default: Huckel + +[energy] +type: double precision +doc: Calculated HF energy +interface: ezfio + +[no_oa_or_av_opt] +type: logical +doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure +interface: ezfio,provider,ocaml +default: False + diff --git a/plugins/SCF_density/Fock_matrix.irp.f b/plugins/SCF_density/Fock_matrix.irp.f new file mode 100644 index 00000000..af9255c8 --- /dev/null +++ b/plugins/SCF_density/Fock_matrix.irp.f @@ -0,0 +1,437 @@ + BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis. + ! For open shells, the ROHF Fock Matrix is + ! + ! | F-K | F + K/2 | F | + ! |---------------------------------| + ! | F + K/2 | F | F - K/2 | + ! |---------------------------------| + ! | F | F - K/2 | F + K | + ! + ! F = 1/2 (Fa + Fb) + ! + ! K = Fb - Fa + ! + END_DOC + integer :: i,j,n + if (elec_alpha_num == elec_beta_num) then + Fock_matrix_mo = Fock_matrix_alpha_mo + else + + do j=1,elec_beta_num + ! F-K + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + enddo + + do j=elec_beta_num+1,elec_alpha_num + ! F+K/2 + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_alpha_num+1, mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + do j=elec_alpha_num+1, mo_tot_num + ! F + do i=1,elec_beta_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) + enddo + ! F-K/2 + do i=elec_beta_num+1,elec_alpha_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& + - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + ! F+K + do i=elec_alpha_num+1,mo_tot_num + Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & + + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) + enddo + enddo + + endif + + do i = 1, mo_tot_num + Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) + enddo +END_PROVIDER + + + + BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) + Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] +&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] + use map_module + implicit none + BEGIN_DOC + ! Alpha Fock matrix in AO basis set + END_DOC + + integer :: i,j,k,l,k1,r,s + integer :: i0,j0,k0,l0 + integer*8 :: p,q + double precision :: integral, c0, c1, c2 + double precision :: ao_bielec_integral, local_threshold + double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) + double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp + + ao_bi_elec_integral_alpha = 0.d0 + ao_bi_elec_integral_beta = 0.d0 + if (do_direct_integrals) then + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & + !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & + !$OMP local_threshold)& + !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& + !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & + !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + + allocate(keys(1), values(1)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + + q = ao_num*ao_num*ao_num*ao_num + !$OMP DO SCHEDULE(dynamic) + do p=1_8,q + call bielec_integrals_index_reverse(kk,ii,ll,jj,p) + if ( (kk(1)>ao_num).or. & + (ii(1)>ao_num).or. & + (jj(1)>ao_num).or. & + (ll(1)>ao_num) ) then + cycle + endif + k = kk(1) + i = ii(1) + l = ll(1) + j = jj(1) + + if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & + < ao_integrals_threshold) then + cycle + endif + local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) + if (local_threshold < ao_integrals_threshold) then + cycle + endif + i0 = i + j0 = j + k0 = k + l0 = l + values(1) = 0.d0 + local_threshold = ao_integrals_threshold/local_threshold + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) + c1 = HF_density_matrix_ao_alpha(k,i) + c2 = HF_density_matrix_ao_beta(k,i) + if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then + cycle + endif + if (values(1) == 0.d0) then + values(1) = ao_bielec_integral(k0,l0,i0,j0) + endif + integral = c0 * values(1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(1) + ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral + ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp + !$OMP END CRITICAL + !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp + !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) + !$OMP END PARALLEL + else + PROVIDE ao_bielec_integrals_in_map + + integer(omp_lock_kind) :: lck(ao_num) + integer*8 :: i8 + integer :: ii(8), jj(8), kk(8), ll(8), k2 + integer(cache_map_size_kind) :: n_elements_max, n_elements + integer(key_kind), allocatable :: keys(:) + double precision, allocatable :: values(:) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & + !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& + !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& + !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) + + call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) + allocate(keys(n_elements_max), values(n_elements_max)) + allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & + ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) + ao_bi_elec_integral_alpha_tmp = 0.d0 + ao_bi_elec_integral_beta_tmp = 0.d0 + + !$OMP DO SCHEDULE(dynamic) + !DIR$ NOVECTOR + do i8=0_8,ao_integrals_map%map_size + n_elements = n_elements_max + call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) + do k1=1,n_elements + call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) + + do k2=1,8 + if (kk(k2)==0) then + cycle + endif + i = ii(k2) + j = jj(k2) + k = kk(k2) + l = ll(k2) + integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) + ao_bi_elec_integral_alpha_tmp(i,j) += integral + ao_bi_elec_integral_beta_tmp (i,j) += integral + integral = values(k1) + ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral + ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp + !$OMP END CRITICAL + !$OMP CRITICAL + ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp + !$OMP END CRITICAL + deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) + !$OMP END PARALLEL + + endif + +END_PROVIDER + + + + + + +BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Fock matrix on the MO basis + END_DOC + double precision, allocatable :: T(:,:) + allocate ( T(ao_num_align,mo_tot_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & + mo_coef, size(mo_coef,1), & + 0.d0, T, ao_num_align) + call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & + 1.d0, mo_coef,size(mo_coef,1), & + T, size(T,1), & + 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) + deallocate(T) +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_energy ] + implicit none + BEGIN_DOC + ! Hartree-Fock energy + END_DOC + HF_energy = nuclear_repulsion + + integer :: i,j + do j=1,ao_num + do i=1,ao_num + HF_energy += 0.5d0 * ( & + (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& + (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) ) + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Fock matrix in AO basis set + END_DOC + + if ( (elec_alpha_num == elec_beta_num).and. & + (level_shift == 0.) ) & + then + integer :: i,j + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num_align + Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) + enddo + enddo + else + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + Fock_matrix_mo, size(Fock_matrix_mo,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + Fock_matrix_ao, size(Fock_matrix_ao,1)) + + + deallocate(T) + endif +END_PROVIDER + +subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) + implicit none + integer, intent(in) :: LDFMO ! size(FMO,1) + integer, intent(in) :: LDFAO ! size(FAO,1) + double precision, intent(in) :: FMO(LDFMO,*) + double precision, intent(out) :: FAO(LDFAO,*) + + double precision, allocatable :: T(:,:), M(:,:) + integer :: ierr + ! F_ao = S C F_mo C^t S + allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) + if (ierr /=0 ) then + print *, irp_here, ' : allocation failed' + endif + +! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) +! -> M(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & + ao_overlap, size(ao_overlap,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) +! -> T(ao_num,mo_tot_num) + call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & + M, size(M,1), & + FMO, size(FMO,1), & + 0.d0, & + T, size(T,1)) + +! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) +! -> M(ao_num,ao_num) + call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & + T, size(T,1), & + mo_coef, size(mo_coef,1), & + 0.d0, & + M, size(M,1)) + +! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) +! -> Fock_matrix_ao(ao_num,ao_num) + call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & + M, size(M,1), & + ao_overlap, size(ao_overlap,1), & + 0.d0, & + FAO, size(FAO,1)) + deallocate(T,M) +end + diff --git a/plugins/SCF_density/HF_density_matrix_ao.irp.f b/plugins/SCF_density/HF_density_matrix_ao.irp.f new file mode 100644 index 00000000..a9d601c7 --- /dev/null +++ b/plugins/SCF_density/HF_density_matrix_ao.irp.f @@ -0,0 +1,66 @@ +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 x Alpha density matrix in the AO basis x S^-1 + END_DOC + +! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & +! mo_coef, size(mo_coef,1), & +! mo_coef, size(mo_coef,1), 0.d0, & +! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) + integer :: i,j,k,l + double precision :: test_alpha + HF_density_matrix_ao_alpha = 0.d0 + do i = 1, mo_tot_num + do j = 1, mo_tot_num + if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle + do k = 1, ao_num + do l = 1, ao_num + HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Beta density matrix in the AO basis x S^-1 + END_DOC + +! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & +! mo_coef, size(mo_coef,1), & +! mo_coef, size(mo_coef,1), 0.d0, & +! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) + integer :: i,j,k,l + double precision :: test_beta + HF_density_matrix_ao_beta = 0.d0 + do i = 1, mo_tot_num + do j = 1, mo_tot_num + do k = 1, ao_num + do l = 1, ao_num + HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j) + enddo + enddo + enddo + enddo + +END_PROVIDER + +BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] + implicit none + BEGIN_DOC + ! S^-1 Density matrix in the AO basis S^-1 + END_DOC + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) + if (elec_alpha_num== elec_beta_num) then + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha + else + ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) + HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta + endif + +END_PROVIDER + diff --git a/plugins/SCF_density/NEEDED_CHILDREN_MODULES b/plugins/SCF_density/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..a52d6e8e --- /dev/null +++ b/plugins/SCF_density/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Integrals_Bielec MOGuess Bitmask diff --git a/plugins/SCF_density/README.rst b/plugins/SCF_density/README.rst new file mode 100644 index 00000000..0699bf28 --- /dev/null +++ b/plugins/SCF_density/README.rst @@ -0,0 +1,175 @@ +=================== +SCF_density Module +=================== + +From the 140 molecules of the G2 set, only LiO, ONa don't converge well. + +Needed Modules +============== + +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + +.. image:: tree_dependency.png + +* `Integrals_Bielec `_ +* `MOGuess `_ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +.. image:: tree_dependency.png + +* `Integrals_Bielec `_ +* `MOGuess `_ +* `Bitmask `_ + +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. + + +`ao_bi_elec_integral_alpha `_ + Alpha Fock matrix in AO basis set + + +`ao_bi_elec_integral_beta `_ + Alpha Fock matrix in AO basis set + + +`create_guess `_ + Create an MO guess if no MOs are present in the EZFIO directory + + +`damping_scf `_ + Undocumented + + +`diagonal_fock_matrix_mo `_ + Diagonal Fock matrix in the MO basis + + +`diagonal_fock_matrix_mo_sum `_ + diagonal element of the fock matrix calculated as the sum over all the interactions + with all the electrons in the RHF determinant + diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij + + +`eigenvectors_fock_matrix_mo `_ + Diagonal Fock matrix in the MO basis + + +`fock_matrix_alpha_ao `_ + Alpha Fock matrix in AO basis set + + +`fock_matrix_alpha_mo `_ + Fock matrix on the MO basis + + +`fock_matrix_ao `_ + Fock matrix in AO basis set + + +`fock_matrix_beta_ao `_ + Alpha Fock matrix in AO basis set + + +`fock_matrix_beta_mo `_ + Fock matrix on the MO basis + + +`fock_matrix_diag_mo `_ + Fock matrix on the MO basis. + For open shells, the ROHF Fock Matrix is + .br + | F-K | F + K/2 | F | + |---------------------------------| + | F + K/2 | F | F - K/2 | + |---------------------------------| + | F | F - K/2 | F + K | + .br + F = 1/2 (Fa + Fb) + .br + K = Fb - Fa + .br + + +`fock_matrix_mo `_ + Fock matrix on the MO basis. + For open shells, the ROHF Fock Matrix is + .br + | F-K | F + K/2 | F | + |---------------------------------| + | F + K/2 | F | F - K/2 | + |---------------------------------| + | F | F - K/2 | F + K | + .br + F = 1/2 (Fa + Fb) + .br + K = Fb - Fa + .br + + +`fock_mo_to_ao `_ + Undocumented + + +`guess `_ + Undocumented + + +`hf_density_matrix_ao `_ + S^-1 Density matrix in the AO basis S^-1 + + +`hf_density_matrix_ao_alpha `_ + S^-1 x Alpha density matrix in the AO basis x S^-1 + + +`hf_density_matrix_ao_beta `_ + S^-1 Beta density matrix in the AO basis x S^-1 + + +`hf_energy `_ + Hartree-Fock energy + + +`huckel_guess `_ + Build the MOs using the extended Huckel model + + +`level_shift `_ + Energy shift on the virtual MOs to improve SCF convergence + + +`mo_guess_type `_ + Initial MO guess. Can be [ Huckel | HCore ] + + +`n_it_scf_max `_ + Maximum number of SCF iterations + + +`no_oa_or_av_opt `_ + If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure + + +`run `_ + Run SCF calculation + + +`scf `_ + Produce `Hartree_Fock` MO orbital + output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ + output: hartree_fock.energy + optional: mo_basis.mo_coef + + +`thresh_scf `_ + Threshold on the convergence of the Hartree Fock energy + diff --git a/plugins/SCF_density/damping_SCF.irp.f b/plugins/SCF_density/damping_SCF.irp.f new file mode 100644 index 00000000..aa6f02b0 --- /dev/null +++ b/plugins/SCF_density/damping_SCF.irp.f @@ -0,0 +1,132 @@ +subroutine damping_SCF + implicit none + double precision :: E + double precision, allocatable :: D_alpha(:,:), D_beta(:,:) + double precision :: E_new + double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) + double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) + double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min + + integer :: i,j,k + logical :: saving + character :: save_char + + allocate( & + D_alpha( ao_num_align, ao_num ), & + D_beta( ao_num_align, ao_num ), & + F_new( ao_num_align, ao_num ), & + D_new_alpha( ao_num_align, ao_num ), & + D_new_beta( ao_num_align, ao_num ), & + delta_alpha( ao_num_align, ao_num ), & + delta_beta( ao_num_align, ao_num )) + + do j=1,ao_num + do i=1,ao_num + D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) + D_beta (i,j) = HF_density_matrix_ao_beta (i,j) + enddo + enddo + + + call write_time(output_hartree_fock) + + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & + '====','================','================','================', '====' + + E = HF_energy + 1.d0 + E_min = HF_energy + delta_D = 0.d0 + do k=1,n_it_scf_max + + delta_E = HF_energy - E + E = HF_energy + + if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then + exit + endif + + saving = E < E_min + if (saving) then + call save_mos + save_char = 'X' + E_min = E + else + save_char = ' ' + endif + + write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & + k, E, delta_E, delta_D, save_char + + D_alpha = HF_density_matrix_ao_alpha + D_beta = HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + D_new_alpha = HF_density_matrix_ao_alpha + D_new_beta = HF_density_matrix_ao_beta + F_new = Fock_matrix_ao + E_new = HF_energy + + delta_alpha = D_new_alpha - D_alpha + delta_beta = D_new_beta - D_beta + + lambda = .5d0 + E_half = 0.d0 + do while (E_half > E) + HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha + HF_density_matrix_ao_beta = D_beta + lambda * delta_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + E_half = HF_energy + if ((E_half > E).and.(E_new < E)) then + lambda = 1.d0 + exit + else if ((E_half > E).and.(lambda > 5.d-4)) then + lambda = 0.5d0 * lambda + E_new = E_half + else + exit + endif + enddo + + a = (E_new + E - 2.d0*E_half)*2.d0 + b = -E_new - 3.d0*E + 4.d0*E_half + lambda = -lambda*b/(a+1.d-16) + D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha + D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta + delta_E = HF_energy - E + do j=1,ao_num + do i=1,ao_num + delta_D = delta_D + & + (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & + (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) + enddo + enddo + delta_D = dsqrt(delta_D/dble(ao_num)**2) + HF_density_matrix_ao_alpha = D_alpha + HF_density_matrix_ao_beta = D_beta + TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta + mo_coef = eigenvectors_fock_matrix_mo + TOUCH mo_coef + + + enddo + write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' + write(output_hartree_fock,*) + + if(.not.no_oa_or_av_opt)then + call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) + endif + + call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') + call ezfio_set_hartree_fock_energy(E_min) + + call write_time(output_hartree_fock) + + deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) +end diff --git a/plugins/SCF_density/diagonalize_fock.irp.f b/plugins/SCF_density/diagonalize_fock.irp.f new file mode 100644 index 00000000..2983abeb --- /dev/null +++ b/plugins/SCF_density/diagonalize_fock.irp.f @@ -0,0 +1,124 @@ + BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] +&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] + implicit none + BEGIN_DOC + ! Diagonal Fock matrix in the MO basis + END_DOC + + integer :: i,j + integer :: liwork, lwork, n, info + integer, allocatable :: iwork(:) + double precision, allocatable :: work(:), F(:,:), S(:,:) + + + allocate( F(mo_tot_num_align,mo_tot_num) ) + do j=1,mo_tot_num + do i=1,mo_tot_num + F(i,j) = Fock_matrix_mo(i,j) + enddo + enddo +! print*, no_oa_or_av_opt + if(no_oa_or_av_opt)then + integer :: iorb,jorb + do i = 1, n_act_orb + iorb = list_act(i) + do j = 1, n_inact_orb + jorb = list_inact(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_virt_orb + jorb = list_virt(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + do j = 1, n_core_orb + jorb = list_core(j) + F(iorb,jorb) = 0.d0 + F(jorb,iorb) = 0.d0 + enddo + enddo +! do i = 1, n_act_orb +! iorb = list_act(i) +! write(*,'(100(F16.10,X))')F(iorb,:) +! enddo + endif + + + + + ! Insert level shift here + do i = elec_beta_num+1, elec_alpha_num + F(i,i) += 0.5d0*level_shift + enddo + + do i = elec_alpha_num+1, mo_tot_num + F(i,i) += level_shift + enddo + + n = mo_tot_num + lwork = 1+6*n + 2*n*n + liwork = 3 + 5*n + + allocate(work(lwork), iwork(liwork) ) + + lwork = -1 + liwork = -1 + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + lwork = int(work(1)) + liwork = iwork(1) + deallocate(work,iwork) + allocate(work(lwork), iwork(liwork) ) + + call dsyevd( 'V', 'U', mo_tot_num, F, & + size(F,1), diagonal_Fock_matrix_mo, & + work, lwork, iwork, liwork, info) + + if (info /= 0) then + print *, irp_here//' failed : ', info + stop 1 + endif + + call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & + mo_coef, size(mo_coef,1), F, size(F,1), & + 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) + deallocate(work, iwork, F) + + +! endif + +END_PROVIDER + +BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] + implicit none + BEGIN_DOC + ! diagonal element of the fock matrix calculated as the sum over all the interactions + ! with all the electrons in the RHF determinant + ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij + END_DOC + integer :: i,j + double precision :: accu + do j = 1,elec_alpha_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + do j = elec_alpha_num+1,mo_tot_num + accu = 0.d0 + do i = 1, elec_alpha_num + accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) + enddo + diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) + enddo + +END_PROVIDER diff --git a/plugins/SCF_density/huckel.irp.f b/plugins/SCF_density/huckel.irp.f new file mode 100644 index 00000000..103de83a --- /dev/null +++ b/plugins/SCF_density/huckel.irp.f @@ -0,0 +1,32 @@ +subroutine huckel_guess + implicit none + BEGIN_DOC +! Build the MOs using the extended Huckel model + END_DOC + integer :: i,j + double precision :: accu + double precision :: c + character*(64) :: label + + label = "Guess" + call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & + size(mo_mono_elec_integral,1), & + size(mo_mono_elec_integral,2),label,1) + TOUCH mo_coef + + c = 0.5d0 * 1.75d0 + + do j=1,ao_num + !DIR$ VECTOR ALIGNED + do i=1,ao_num + Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + & + ao_mono_elec_integral_diag(j)) + enddo + Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j) + enddo + TOUCH Fock_matrix_ao + mo_coef = eigenvectors_fock_matrix_mo + SOFT_TOUCH mo_coef + call save_mos + +end diff --git a/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES b/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..994f4bf6 --- /dev/null +++ b/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants Integrals_restart_DFT Davidson diff --git a/plugins/Slater_rules_DFT/README.rst b/plugins/Slater_rules_DFT/README.rst new file mode 100644 index 00000000..f492095e --- /dev/null +++ b/plugins/Slater_rules_DFT/README.rst @@ -0,0 +1,12 @@ +================ +Slater_rules_DFT +================ + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f b/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f new file mode 100644 index 00000000..3d99e376 --- /dev/null +++ b/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f @@ -0,0 +1,38 @@ +program Slater_rules_DFT + implicit none + BEGIN_DOC +! TODO + END_DOC + print *, ' _/ ' + print *, ' -:\_?, _Jm####La ' + print *, 'J"(:" > _]#AZ#Z#UUZ##, ' + print *, '_,::./ %(|i%12XmX1*1XL _?, ' + print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' + print *, ' .:< ]J=mQD?WXn|,)nr" ' + print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' + print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' + print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' + print *, ' miX#L -~`""!!1}oSoe|i7 ' + print *, ' 4cn#m, v221=|v[ ' + print *, ' ]hI3Zma,;..__wXSe=+vo ' + print *, ' ]Zov*XSUXXZXZXSe||vo2 ' + print *, ' ]Z#>=|< ' + print *, ' -ziiiii||||||+||==+> ' + print *, ' -%|+++||=|=+|=|==/ ' + print *, ' -a>====+|====-:- ' + print *, ' "~,- -- /- ' + print *, ' -. )> ' + print *, ' .~ +- ' + print *, ' . .... : . ' + print *, ' -------~ ' + print *, '' +end diff --git a/plugins/Slater_rules_DFT/energy.irp.f b/plugins/Slater_rules_DFT/energy.irp.f new file mode 100644 index 00000000..7734d73e --- /dev/null +++ b/plugins/Slater_rules_DFT/energy.irp.f @@ -0,0 +1,7 @@ +! BEGIN_PROVIDER [double precision, energy_total] +!&BEGIN_PROVIDER [double precision, energy_one_electron] +!&BEGIN_PROVIDER [double precision, energy_hartree] +!&BEGIN_PROVIDER [double precision, energy] +! implicit none +! +!END_PROVIDER diff --git a/plugins/Slater_rules_DFT/slater_rules_erf.irp.f b/plugins/Slater_rules_DFT/slater_rules_erf.irp.f new file mode 100644 index 00000000..64d5d217 --- /dev/null +++ b/plugins/Slater_rules_DFT/slater_rules_erf.irp.f @@ -0,0 +1,445 @@ + +subroutine i_H_j_erf(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_erf + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_erf, phase,phase_2 + integer :: n_occ_ab(2) + PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + integer :: spin + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,2,2) )then + hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) + else if (exc(1,2,1) ==exc(1,1,2))then + hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) + else + hij = phase*get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_erf_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_erf_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_erf_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + spin = 1 + do i = 1, n_occ_ab(1) + hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + do i = 1, n_occ_ab(2) + hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + spin = 2 + do i = 1, n_occ_ab(2) + hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + do i = 1, n_occ_ab(1) + hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + endif + hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + hij = hij * phase + case (0) + hij = diag_H_mat_elem_erf(key_i,Nint) + end select +end + +double precision function diag_H_mat_elem_erf(key_i,Nint) + implicit none + integer(bit_kind), intent(in) :: key_i(N_int,2) + integer, intent(in) :: Nint + integer :: i,j + integer :: occ(Nint*bit_kind_size,2) + integer :: n_occ_ab(2) + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + diag_H_mat_elem_erf = 0.d0 + ! alpha - alpha + do i = 1, n_occ_ab(1) + diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + do j = i+1, n_occ_ab(1) + diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) + enddo + enddo + + ! beta - beta + do i = 1, n_occ_ab(2) + diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + do j = i+1, n_occ_ab(2) + diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) + enddo + enddo + + ! alpha - beta + do i = 1, n_occ_ab(1) + do j = 1, n_occ_ab(2) + diag_H_mat_elem_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) + enddo + enddo + +end + + + +subroutine i_H_j_erf_and_short_coulomb(key_i,key_j,Nint,hij) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_erf + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_erf, phase,phase_2 + integer :: n_occ_ab(2) + PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij = 0.d0 + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + integer :: spin + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,2,2) )then + hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) + else if (exc(1,2,1) ==exc(1,1,2))then + hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) + else + hij = phase*get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_erf_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij = phase*(get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_erf_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij = phase*(get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_erf_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + spin = 1 + do i = 1, n_occ_ab(1) + hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + do i = 1, n_occ_ab(2) + hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + spin = 2 + do i = 1, n_occ_ab(2) + hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + do i = 1, n_occ_ab(1) + hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + endif + hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + effective_short_range_operator(m,p) + hij = hij * phase + case (0) + hij = diag_H_mat_elem_erf(key_i,Nint) + end select +end + +double precision function diag_H_mat_elem_erf_and_short_coulomb(key_i,Nint) + implicit none + integer(bit_kind), intent(in) :: key_i(N_int,2) + integer, intent(in) :: Nint + integer :: i,j + integer :: occ(Nint*bit_kind_size,2) + integer :: n_occ_ab(2) + + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + diag_H_mat_elem_erf_and_short_coulomb = 0.d0 + ! alpha - alpha + do i = 1, n_occ_ab(1) + diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) & + + effective_short_range_operator(occ(i,1),occ(i,1)) + do j = i+1, n_occ_ab(1) + diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) + enddo + enddo + + ! beta - beta + do i = 1, n_occ_ab(2) + diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) & + + effective_short_range_operator(occ(i,2),occ(i,2)) + do j = i+1, n_occ_ab(2) + diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) + enddo + enddo + + ! alpha - beta + do i = 1, n_occ_ab(1) + do j = 1, n_occ_ab(2) + diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) + enddo + enddo + +end + + +subroutine i_H_j_erf_component(key_i,key_j,Nint,hij_core,hij_hartree,hij_erf,hij_total) + use bitmasks + implicit none + BEGIN_DOC + ! Returns where i and j are determinants + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) + double precision, intent(out) :: hij_core + double precision, intent(out) :: hij_hartree + double precision, intent(out) :: hij_erf + double precision, intent(out) :: hij_total + + integer :: exc(0:2,2,2) + integer :: degree + double precision :: get_mo_bielec_integral_erf + integer :: m,n,p,q + integer :: i,j,k + integer :: occ(Nint*bit_kind_size,2) + double precision :: diag_H_mat_elem_erf, phase,phase_2 + integer :: n_occ_ab(2) + PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf + + ASSERT (Nint > 0) + ASSERT (Nint == N_int) + ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) + ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) + ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) + + hij_core = 0.d0 + hij_hartree = 0.d0 + hij_erf = 0.d0 + + !DIR$ FORCEINLINE + call get_excitation_degree(key_i,key_j,degree,Nint) + integer :: spin + select case (degree) + case (2) + call get_double_excitation(key_i,key_j,exc,phase,Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha, mono beta + if(exc(1,1,1) == exc(1,2,2) )then + hij_erf = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) + else if (exc(1,2,1) ==exc(1,1,2))then + hij_erf = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) + else + hij_erf = phase*get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(1,1,2), & + exc(1,2,1), & + exc(1,2,2) ,mo_integrals_erf_map) + endif + else if (exc(0,1,1) == 2) then + ! Double alpha + hij_erf = phase*(get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(1,2,1), & + exc(2,2,1) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,1), & + exc(2,1,1), & + exc(2,2,1), & + exc(1,2,1) ,mo_integrals_erf_map) ) + else if (exc(0,1,2) == 2) then + ! Double beta + hij_erf = phase*(get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(1,2,2), & + exc(2,2,2) ,mo_integrals_erf_map) - & + get_mo_bielec_integral_erf( & + exc(1,1,2), & + exc(2,1,2), & + exc(2,2,2), & + exc(1,2,2) ,mo_integrals_erf_map) ) + endif + case (1) + call get_mono_excitation(key_i,key_j,exc,phase,Nint) + !DIR$ FORCEINLINE + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + if (exc(0,1,1) == 1) then + ! Mono alpha + m = exc(1,1,1) + p = exc(1,2,1) + spin = 1 + do i = 1, n_occ_ab(1) + hij_erf += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + do i = 1, n_occ_ab(2) + hij_erf += big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + else + ! Mono beta + m = exc(1,1,2) + p = exc(1,2,2) + spin = 2 + do i = 1, n_occ_ab(2) + hij_erf += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) + enddo + do i = 1, n_occ_ab(1) + hij_erf += big_array_coulomb_integrals_erf(occ(i,1),m,p) + enddo + endif + hij_core = mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + hij_hartree = effective_short_range_operator(m,p) + hij_total = (hij_erf + hij_core + hij_hartree) * phase + case (0) + call diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) + end select +end + +subroutine diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) + implicit none + integer(bit_kind), intent(in) :: key_i(N_int,2) + integer, intent(in) :: Nint + double precision, intent(out) :: hij_core + double precision, intent(out) :: hij_hartree + double precision, intent(out) :: hij_erf + double precision, intent(out) :: hij_total + integer :: i,j + integer :: occ(Nint*bit_kind_size,2) + integer :: n_occ_ab(2) + + call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) + hij_core = 0.d0 + hij_hartree = 0.d0 + hij_erf = 0.d0 + ! alpha - alpha + do i = 1, n_occ_ab(1) + hij_core += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + hij_hartree += effective_short_range_operator(occ(i,1),occ(i,1)) + do j = i+1, n_occ_ab(1) + hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) + enddo + enddo + + ! beta - beta + do i = 1, n_occ_ab(2) + hij_core += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + hij_hartree += effective_short_range_operator(occ(i,2),occ(i,2)) + do j = i+1, n_occ_ab(2) + hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) + enddo + enddo + + ! alpha - beta + do i = 1, n_occ_ab(1) + do j = 1, n_occ_ab(2) + hij_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) + enddo + enddo + hij_total = hij_erf + hij_hartree + hij_core + +end + + diff --git a/plugins/core_integrals/.gitignore b/plugins/core_integrals/.gitignore new file mode 100644 index 00000000..7ac9fbf6 --- /dev/null +++ b/plugins/core_integrals/.gitignore @@ -0,0 +1,5 @@ +IRPF90_temp/ +IRPF90_man/ +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/core_integrals/NEEDED_CHILDREN_MODULES b/plugins/core_integrals/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..6a4d0040 --- /dev/null +++ b/plugins/core_integrals/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Integrals_Monoelec Integrals_Bielec Bitmask diff --git a/plugins/core_integrals/README.rst b/plugins/core_integrals/README.rst new file mode 100644 index 00000000..589e0a00 --- /dev/null +++ b/plugins/core_integrals/README.rst @@ -0,0 +1,12 @@ +============== +core_integrals +============== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/core_integrals/core_integrals.main.irp.f b/plugins/core_integrals/core_integrals.main.irp.f new file mode 100644 index 00000000..f5e9fd1b --- /dev/null +++ b/plugins/core_integrals/core_integrals.main.irp.f @@ -0,0 +1,7 @@ +program core_integrals + implicit none + BEGIN_DOC +! TODO + END_DOC + print*,'core energy = ',core_energy +end diff --git a/plugins/core_integrals/core_quantities.irp.f b/plugins/core_integrals/core_quantities.irp.f new file mode 100644 index 00000000..ac547d2f --- /dev/null +++ b/plugins/core_integrals/core_quantities.irp.f @@ -0,0 +1,32 @@ +BEGIN_PROVIDER [double precision, core_energy] + implicit none + integer :: i,j,k,l + core_energy = 0.d0 + do i = 1, n_core_orb + j = list_core(i) + core_energy += 2.d0 * mo_mono_elec_integral(j,j) + mo_bielec_integral_jj(j,j) + do k = i+1, n_core_orb + l = list_core(k) + core_energy += 2.d0 * (2.d0 * mo_bielec_integral_jj(j,l) - mo_bielec_integral_jj_exchange(j,l)) + enddo + enddo + core_energy += nuclear_repulsion + +END_PROVIDER + +BEGIN_PROVIDER [double precision, core_fock_operator, (mo_tot_num,mo_tot_num)] + implicit none + integer :: i,j,k,l,m,n + double precision :: get_mo_bielec_integral + core_fock_operator = 0.d0 + do i = 1, n_act_orb + j = list_act(i) + do k = 1, n_act_orb + l = list_act(k) + do m = 1, n_core_orb + n = list_core(m) + core_fock_operator(j,l) += 2.d0 * get_mo_bielec_integral(j,n,l,n,mo_integrals_map) - get_mo_bielec_integral(j,n,n,l,mo_integrals_map) + enddo + enddo + enddo +END_PROVIDER diff --git a/plugins/loc_cele/loc.f b/plugins/loc_cele/loc.f index edc3aa7a..ed8b9a76 100644 --- a/plugins/loc_cele/loc.f +++ b/plugins/loc_cele/loc.f @@ -18,7 +18,7 @@ C zprt=.true. niter=1000000 - conv=1.d-8 + conv=1.d-10 C niter=1000000 C conv=1.d-6 diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 2d47c633..67e74f08 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -101,10 +101,29 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 11 - irot(2,1) = 12 - cmoref(15,1,1) = 1.d0 ! - cmoref(14,2,1) = 1.d0 ! + irot(1,1) = 14 + irot(2,1) = 15 +! cmoref(6,1,1) = 1.d0 +! cmoref(26,2,1) = 1.d0 + cmoref(36,1,1) = 1.d0 + cmoref(56,2,1) = 1.d0 + +! !!! H2O +! irot(1,1) = 4 +! irot(2,1) = 5 +! irot(3,1) = 6 +! irot(4,1) = 7 +! ! O pz +! cmoref(5,1,1) = 1.55362d0 +! cmoref(6,1,1) = 1.07578d0 + +! cmoref(5,2,1) = 1.55362d0 +! cmoref(6,2,1) = -1.07578d0 +! ! O px - pz +! ! H1 +! cmoref(16,3,1) = 1.d0 +! ! H1 +! cmoref(21,4,1) = 1.d0 ! ESATRIENE with 3 bonding and anti bonding orbitals ! First bonding orbital for esa @@ -150,19 +169,19 @@ ! ESATRIENE with 1 central bonding and anti bonding orbitals ! AND 4 radical orbitals ! First radical orbital - cmoref(7,1,1) = 1.d0 ! +! cmoref(7,1,1) = 1.d0 ! ! Second radical orbital - cmoref(26,2,1) = 1.d0 ! +! cmoref(26,2,1) = 1.d0 ! ! First bonding orbital - cmoref(45,3,1) = 1.d0 ! - cmoref(64,3,1) = 1.d0 ! +! cmoref(45,3,1) = 1.d0 ! +! cmoref(64,3,1) = 1.d0 ! ! Third radical orbital for esa - cmoref(83,4,1) = 1.d0 ! +! cmoref(83,4,1) = 1.d0 ! ! Fourth radical orbital for esa - cmoref(102,5,1) = 1.d0 ! +! cmoref(102,5,1) = 1.d0 ! ! First anti bonding orbital - cmoref(45,6,1) = 1.d0 ! - cmoref(64,6,1) =-1.d0 ! +! cmoref(45,6,1) = 1.d0 ! +! cmoref(64,6,1) =-1.d0 ! do i = 1, nrot(1) diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index 8bb47d89..eabdf35c 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -18,16 +18,17 @@ program loc_int do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -50,16 +51,17 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -82,16 +84,17 @@ program loc_int do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index f332dd5d..c4dcf75c 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -19,16 +19,17 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + if(list_core_inact_check(jorb) == .False.)then + exchange_int(jorb) = 0.d0 + else + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) + endif enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. - print*,indices(n_rot,1),indices(n_rot,2) - print*,'' - print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore new file mode 100644 index 00000000..7ac9fbf6 --- /dev/null +++ b/plugins/mrcepa0/.gitignore @@ -0,0 +1,5 @@ +IRPF90_temp/ +IRPF90_man/ +irpf90.make +irpf90_entities +tags \ No newline at end of file diff --git a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES index 8b6c5a18..fe8255d1 100644 --- a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES +++ b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ +Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 2820750f..d2311676 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -684,7 +684,7 @@ subroutine getHP(a,h,p,Nint) end do lh h = deg !isInCassd = .true. -end function +end subroutine BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] @@ -709,6 +709,9 @@ end function integer :: II, blok integer*8, save :: notf = 0 + + PROVIDE psi_ref_coef psi_non_ref_coef + call wall_time(wall) allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) @@ -832,8 +835,7 @@ END_PROVIDER delta_sub_ij(:,:,:) = 0d0 delta_sub_ii(:,:) = 0d0 - provide mo_bielec_integrals_in_map - + provide mo_bielec_integrals_in_map N_det_non_ref psi_ref_coef psi_non_ref_coef !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index b495019a..780a7a91 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -476,7 +476,7 @@ def ninja_irpf90_make_build(path_module, l_needed_molule, d_irp): # ~#~#~#~#~#~ # l_creation = [join(path_module.abs, i) - for i in ["irpf90.make", "irpf90_entities", "tags", + for i in ["irpf90_entities", "tags", "IRPF90_temp/build.ninja"]] str_creation = " ".join(l_creation) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 946cbe35..0c5e1b37 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -20,17 +20,18 @@ from functools import reduce # Add to the path # # ~#~#~#~#~#~#~#~ # - try: QP_ROOT = os.environ["QP_ROOT"] except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: + sys.path = [ QP_ROOT + "/install/EZFIO/Python", QP_ROOT + "/resultsFile", QP_ROOT + "/scripts"] + sys.path + # ~#~#~#~#~#~ # # I m p o r t # # ~#~#~#~#~#~ # @@ -364,20 +365,17 @@ def write_ezfio(res, filename): pseudo_str = "\n".join(pseudo_str) matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) - array_z_remove = map(float,array_z_remove) except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) - + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # - ezfio.set_pseudo_nucl_charge_remove(array_z_remove) - charge = ezfio.get_nuclei_nucl_charge() - charge = [ i - j for i, j in zip(charge, array_z_remove) ] - ezfio.set_nuclei_nucl_charge (charge) + ezfio.pseudo_charge_remove = array_z_remove + ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)] import math num_elec_diff = sum(array_z_remove)/2 diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index c7714e8a..5dd1e4f3 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -343,7 +343,7 @@ class H_apply(object): """ self.data["size_max"] = "8192" self.data["initialization"] = """ - PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit +! PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ if self.do_double_exc == True: self.data["keys_work"] = """ @@ -370,7 +370,7 @@ class H_apply(object): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) - PROVIDE N_det_generators +! PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 @@ -478,7 +478,7 @@ class H_apply_zmq(H_apply): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) - PROVIDE N_det_generators +! PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 0667c376..7c729827 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -253,6 +253,9 @@ if __name__ == '__main__': m.create_png(l_module) except RuntimeError: pass + except SyntaxError: + print "Warning: The graphviz API drop support of python 2.6." + pass if arguments["clean"] or arguments["create_git_ignore"]: @@ -298,6 +301,7 @@ if __name__ == '__main__': # Don't update if we are not in the main repository from is_master_repository import is_master_repository if not is_master_repository: + print >> sys.stderr, 'Not in the master repo' sys.exit() path = os.path.join(module_abs, ".gitignore") diff --git a/src/AO_Basis/ao_overlap.irp.f b/src/AO_Basis/ao_overlap.irp.f index edf48b25..08e57f73 100644 --- a/src/AO_Basis/ao_overlap.irp.f +++ b/src/AO_Basis/ao_overlap.irp.f @@ -129,3 +129,48 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num_align,ao_num) ] !$OMP END PARALLEL DO END_PROVIDER +BEGIN_PROVIDER [ double precision, ao_overlap_inv, (ao_num_align, ao_num) ] + implicit none + BEGIN_DOC + ! Inverse of the overlap matrix + END_DOC + call invert_matrix(ao_overlap, size(ao_overlap,1), ao_num, ao_overlap_inv, size(ao_overlap_inv,1)) +END_PROVIDER + +BEGIN_PROVIDER [double precision, ao_overlap_inv_1_2, (ao_num_align,ao_num)] + implicit none + integer :: i,j,k,l + double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) + call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) + ao_overlap_inv_1_2 = 0.d0 + double precision :: a_n + do i = 1, ao_num + a_n = 1.d0/dsqrt(eigvalues(i)) + if(a_n.le.1.d-10)cycle + do j = 1, ao_num + do k = 1, ao_num + ao_overlap_inv_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n + enddo + enddo + enddo + +END_PROVIDER + + +BEGIN_PROVIDER [double precision, ao_overlap_1_2, (ao_num_align,ao_num)] + implicit none + integer :: i,j,k,l + double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) + call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) + ao_overlap_1_2 = 0.d0 + double precision :: a_n + do i = 1, ao_num + a_n = dsqrt(eigvalues(i)) + do j = 1, ao_num + do k = 1, ao_num + ao_overlap_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n + enddo + enddo + enddo + +END_PROVIDER diff --git a/src/AO_Basis/aos_value.irp.f b/src/AO_Basis/aos_value.irp.f index a531ce50..4876844c 100644 --- a/src/AO_Basis/aos_value.irp.f +++ b/src/AO_Basis/aos_value.irp.f @@ -26,6 +26,7 @@ double precision function ao_value(i,r) do m=1,ao_prim_num(i) beta = ao_expo_ordered_transp(m,i) accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) +! accu += ao_coef_transp(m,i) * dexp(-beta*r2) enddo ao_value = accu * dx * dy * dz diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 87a02d10..5c170632 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -560,3 +560,24 @@ logical function is_i_in_virtual(i) endif end + +logical function is_i_in_active(i) + implicit none + integer,intent(in) :: i + integer(bit_kind) :: key(N_int) + integer :: k,j + integer :: accu + is_i_in_active = .False. + key= 0_bit_kind + k = ishft(i-1,-bit_kind_shift)+1 + j = i-ishft(k-1,bit_kind_shift)-1 + key(k) = ibset(key(k),j) + accu = 0 + do k = 1, N_int + accu += popcnt(iand(key(k),cas_bitmask(k,1,1))) + enddo + if(accu .ne. 0)then + is_i_in_active= .True. + endif + +end diff --git a/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f b/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f new file mode 100644 index 00000000..3bdc37c5 --- /dev/null +++ b/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f @@ -0,0 +1,16 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + call diagonalize_CI + print*,'N_det = ',N_det + call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + + + +end diff --git a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f index 3bdc37c5..393ff63a 100644 --- a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f +++ b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f @@ -9,7 +9,7 @@ subroutine routine implicit none call diagonalize_CI print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index a68a61a5..a9ecd806 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -119,3 +119,9 @@ doc: Maximum number of determinants for which the full H matrix is stored. Be ca interface: ezfio,provider,ocaml default: 90000 +[density_matrix_mo_disk] +type: double precision +doc: coefficient of the ith ao on the jth mo +interface: ezfio +size: (mo_basis.mo_tot_num,mo_basis.mo_tot_num) + diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index a6a7310f..561f7e89 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -195,6 +195,7 @@ subroutine copy_H_apply_buffer_to_wf !call remove_duplicates_in_psi_det(found_duplicates) end + subroutine remove_duplicates_in_psi_det(found_duplicates) implicit none logical, intent(out) :: found_duplicates @@ -270,6 +271,81 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) deallocate (duplicate,bit_tmp) end +subroutine remove_duplicates_in_psi_det_new(found_duplicates) + implicit none + logical, intent(out) :: found_duplicates + BEGIN_DOC +! Removes duplicate determinants in the wave function. + END_DOC + integer :: i,j,k + integer(bit_kind), allocatable :: bit_tmp(:) + logical,allocatable :: duplicate(:) + + allocate (duplicate(N_det), bit_tmp(N_det)) + + do i=1,N_det + integer, external :: det_search_key + !$DIR FORCEINLINE + bit_tmp(i) = det_search_key(psi_det_sorted_bit(1,1,i),N_int) + duplicate(i) = .False. + enddo + + do i=1,N_det-1 + if (duplicate(i)) then + cycle + endif + j = i+1 + do while (bit_tmp(j)==bit_tmp(i)) + if (duplicate(j)) then + j += 1 + if (j > N_det) then + exit + else + cycle + endif + endif + duplicate(j) = .True. + do k=1,N_int + if ( (psi_det_sorted_bit(k,1,i) /= psi_det_sorted_bit(k,1,j) ) & + .or. (psi_det_sorted_bit(k,2,i) /= psi_det_sorted_bit(k,2,j) ) ) then + duplicate(j) = .False. + exit + endif + enddo + j += 1 + if (j > N_det) then + exit + endif + enddo + enddo + + found_duplicates = .False. + do i=1,N_det + if (duplicate(i)) then + found_duplicates = .True. + exit + endif + enddo + + if (found_duplicates) then + k=0 + do i=1,N_det + if (.not.duplicate(i)) then + k += 1 + psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) + psi_coef(k,:) = psi_coef_sorted_bit(i,:) + else + psi_det(:,:,k) = 0_bit_kind + psi_coef(k,:) = 0.d0 + endif + enddo + N_det = k + call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') + SOFT_TOUCH N_det psi_det psi_coef + endif + deallocate (duplicate,bit_tmp) +end + subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f index 0c319fe3..5550d9d1 100644 --- a/src/Determinants/H_apply_nozmq.template.f +++ b/src/Determinants/H_apply_nozmq.template.f @@ -17,7 +17,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map !psi_det_generators psi_coef_generators nmax = mod( N_det_generators,nproc ) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index ddedc5a2..97f225b4 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -20,7 +20,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators +! PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators integer(ZMQ_PTR), external :: new_zmq_pair_socket integer(ZMQ_PTR) :: zmq_socket_pair diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 923318bc..541cfcb4 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -15,6 +15,72 @@ enddo END_PROVIDER + +subroutine save_density_matrix_mo + implicit none + double precision, allocatable :: dm(:,:) + allocate(dm(mo_tot_num,mo_tot_num)) + integer :: i,j + do i = 1, mo_tot_num + do j = 1, mo_tot_num + dm(i,j) = one_body_dm_mo_alpha_average(i,j) + enddo + enddo + call ezfio_set_determinants_density_matrix_mo_disk(dm) + +end + + BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + do i = 1, mo_tot_num + one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] + implicit none + integer :: i,j,ispin,istate + ispin = 1 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) + enddo + enddo + enddo + + ispin = 2 + do istate = 1, N_states + do j = 1, mo_tot_num + one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate) + do i = j+1, mo_tot_num + one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) + enddo + enddo + enddo + + END_PROVIDER + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none @@ -90,39 +156,16 @@ END_PROVIDER lcol = psi_bilinear_matrix_columns(l) enddo - l = psi_bilinear_matrix_order_reverse(k)+1 - ! Fix alpha determinant, loop over betas - lrow = psi_bilinear_matrix_transp_rows(l) - lcol = psi_bilinear_matrix_transp_columns(l) - do while ( lrow == krow ) - tmp_det2(:) = psi_det_beta_unique (:, lcol) - call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int) - if (degree == 1) then - call get_mono_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int) - call decode_exc_spin(exc,h1,p1,h2,p2) - do m=1,N_states - ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_transp_values(l,m) * phase - tmp_b(h1,p1,m) += ckl - tmp_b(p1,h1,m) += ckl - enddo - endif - l = l+1 - if (l>N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l) - lcol = psi_bilinear_matrix_transp_columns(l) - enddo - - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP END PARALLEL - + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] diff --git a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f deleted file mode 100644 index 97fed531..00000000 --- a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f +++ /dev/null @@ -1,27 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - integer :: igood_state_1,igood_state_2 - double precision, allocatable :: psi_coef_tmp(:,:) - integer :: i - print*,'N_det = ',N_det -!call diagonalize_CI - write(*,*)'Which couple of states would you like to save ?' - read(5,*)igood_state_1,igood_state_2 - allocate(psi_coef_tmp(n_det,2)) - do i = 1, N_det - psi_coef_tmp(i,1) = psi_coef(i,igood_state_1) - psi_coef_tmp(i,2) = psi_coef(i,igood_state_2) - enddo - call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp) - deallocate(psi_coef_tmp) - - - -end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index 737e4d3e..2120a512 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -32,29 +32,28 @@ subroutine routine call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*,'phase = ',phase -! if(degree == 1)then -! print*,'s1',s1 -! print*,'h1,p1 = ',h1,p1 -! if(s1 == 1)then -! norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) -! else -! norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) -! endif + if(degree == 1)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + if(s1 == 1)then + norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) + else + norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) + endif ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) -! double precision :: hmono,hdouble -! call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) -! print*,'hmono = ',hmono -! print*,'hdouble = ',hdouble -! print*,'hmono+hdouble = ',hmono+hdouble -! print*,'hij = ',hij -! else -! print*,'s1',s1 -! print*,'h1,p1 = ',h1,p1 -! print*,'s2',s2 -! print*,'h2,p2 = ',h2,p2 + double precision :: hmono,hdouble + call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) + print*,'hmono = ',hmono + print*,'hdouble = ',hdouble + print*,'hmono+hdouble = ',hmono+hdouble + print*,'hij = ',hij + else if (degree == 2)then + print*,'s1',s1 + print*,'h1,p1 = ',h1,p1 + print*,'s2',s2 + print*,'h2,p2 = ',h2,p2 ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) -! endif - + endif print*,' = ',hij endif print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 4d5b1bd3..78a35689 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2144,9 +2144,27 @@ subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) double precision, intent(in) :: u_0(sze) v_0 = 0.d0 call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) - end +subroutine H_s2_u_0_stored(v_0,u_0,hmatrix,s2matrix,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> + ! + ! n : number of determinants + ! + ! uses the big_matrix_stored array + END_DOC + integer, intent(in) :: sze + double precision, intent(in) :: hmatrix(sze,sze),s2matrix(sze,sze) + double precision, intent(out) :: v_0(sze) + double precision, intent(in) :: u_0(sze) + v_0 = 0.d0 + call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) +end + + subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) use bitmasks implicit none diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index aba16fa7..49b5e70a 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,8 +1,52 @@ program s2_eig_restart implicit none read_wf = .True. - call routine + call routine_2 end + +subroutine routine_2 + implicit none + integer :: i,j,k,l + use bitmasks + integer :: n_det_restart,degree + integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) + double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) + integer, allocatable :: index_restart(:) + allocate(index_restart(N_det)) + print*, 'How many Slater determinants would ou like ?' + read(5,*)N_det_restart + do i = 1, N_det_restart + index_restart(i) = i + enddo + allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) + accu = 0.d0 + do i = 1, N_det_restart + do j = 1, N_int + psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) + psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) + enddo + do j = 1,N_states + psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) + accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) + enddo + enddo + do j = 1, N_states + accu(j) = 1.d0/dsqrt(accu(j)) + enddo + do j = 1,N_states + do i = 1, N_det_restart + psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) + enddo + enddo + call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) + + deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) + + + +end + + subroutine routine implicit none call make_s2_eigenfunction diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index aa8f630b..bb1a341e 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -194,6 +194,8 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) end BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_aa_diag_act, (n_act_orb, n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_bb_diag_act, (n_act_orb, n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] @@ -234,6 +236,8 @@ end two_body_dm_ab_diag_all = 0.d0 two_body_dm_ab_diag_act = 0.d0 + two_body_dm_aa_diag_act = 0.d0 + two_body_dm_bb_diag_act = 0.d0 two_body_dm_ab_diag_core = 0.d0 two_body_dm_ab_diag_inact = 0.d0 two_body_dm_diag_core_a_act_b = 0.d0 @@ -269,8 +273,20 @@ end two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib enddo + do l = 1, n_occ_ab_act(2) + m = list_act_reverse(occ_act(l,2)) + two_body_dm_bb_diag_act(k,m) += 0.5d0 * contrib + two_body_dm_bb_diag_act(m,k) += 0.5d0 * contrib + enddo + enddo + do j = 1,n_occ_ab_act(1) + k = list_act_reverse(occ_act(j,1)) + do l = 1, n_occ_ab_act(1) + m = list_act_reverse(occ_act(l,1)) + two_body_dm_aa_diag_act(k,m) += 0.5d0 * contrib + two_body_dm_aa_diag_act(m,k) += 0.5d0 * contrib + enddo enddo - ! CORE PART of the diagonal part of the two body dm do j = 1, N_int key_tmp_core(j,1) = psi_det(j,1,i) @@ -325,6 +341,8 @@ end END_PROVIDER BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_aa_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] +&BEGIN_PROVIDER [double precision, two_body_dm_bb_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] implicit none use bitmasks @@ -394,14 +412,22 @@ END_PROVIDER call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ - if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J h1 = list_act_reverse(h1) h2 = list_act_reverse(h2) p1 = list_act_reverse(p1) p2 = list_act_reverse(p2) - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) - + if(s1==s2)then + if(s1==1)then + call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) +! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) + else + call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) +! call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) + endif + else ! alpha/beta two body density matrix + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + endif else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** print*,'h1 = ',h1 h1 = list_act_reverse(h1) @@ -417,6 +443,12 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo + do k = 1, n_occ_ab(1) + m = list_act_reverse(occ(k,1)) + ! * c_I * c_J + call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) +! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) + enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(2) @@ -432,6 +464,12 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo + do k = 1, n_occ_ab(2) + m = list_act_reverse(occ(k,2)) + ! * c_I * c_J + call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) +! call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) + enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(1) @@ -464,156 +502,3 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr end - -double precision function compute_extra_diag_two_body_dm_ab(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 - END_DOC - double precision :: r1(3), r2(3) - double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act - compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) -end - -double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - PROVIDE n_act_orb - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib - double precision :: contrib_tmp -!print*,'n_act_orb = ',n_act_orb - compute_extra_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! p2 - do k = 1, n_act_orb ! h2 - do j = 1, n_act_orb ! p1 - do i = 1,n_act_orb ! h1 - contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) - compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp - enddo - enddo - enddo - enddo - -end - -double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - BEGIN_DOC -! compute the extra diagonal contribution to the two body density at r1, r2 -! involving ONLY THE ACTIVE PART, which means that the four index of the excitations -! involved in the two body density matrix are ACTIVE - END_DOC - double precision, intent(in) :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_extra_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) - do i = 1, n_act_orb ! h1 - do j = 1, n_act_orb ! p1 - contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) - contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) - do k = 1,n_core_orb ! h2 - contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) - contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) - compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp - enddo - enddo - enddo - -end - -double precision function compute_diag_two_body_dm_ab_core(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_core = 0.d0 - call give_all_core_mos_at_r(r1,mos_array_r1) - call give_all_core_mos_at_r(r2,mos_array_r2) - do l = 1, n_core_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_core_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp - enddo - enddo - -end - - -double precision function compute_diag_two_body_dm_ab_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) - double precision :: contrib,contrib_tmp - compute_diag_two_body_dm_ab_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_r1) - call give_all_act_mos_at_r(r2,mos_array_r2) - do l = 1, n_act_orb ! - contrib = mos_array_r2(l)*mos_array_r2(l) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) - implicit none - double precision :: r1(3),r2(3) - integer :: i,j,k,l - double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) - double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) - double precision :: contrib_core_1,contrib_core_2 - double precision :: contrib_act_1,contrib_act_2 - double precision :: contrib_tmp - compute_diag_two_body_dm_ab_core_act = 0.d0 - call give_all_act_mos_at_r(r1,mos_array_act_r1) - call give_all_act_mos_at_r(r2,mos_array_act_r2) - call give_all_core_mos_at_r(r1,mos_array_core_r1) - call give_all_core_mos_at_r(r2,mos_array_core_r2) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do k = 1, n_act_orb ! - contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) - contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) - contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) -! if(dabs(contrib).lt.threshld_two_bod_dm)cycle - do l = 1, n_core_orb ! - contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) - contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) - compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp - enddo - enddo -end - -double precision function compute_diag_two_body_dm_ab(r1,r2) - implicit none - double precision,intent(in) :: r1(3),r2(3) - double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core - double precision :: compute_diag_two_body_dm_ab_core_act - compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & - + compute_diag_two_body_dm_ab_core_act(r1,r2) -end diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 4e7e494f..0576b811 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -51,3 +51,4 @@ doc: If || < ao_integrals_threshold then is zero interface: ezfio,provider,ocaml default: 1.e-15 ezfio_name: threshold_mo + diff --git a/src/Integrals_Monoelec/EZFIO.cfg b/src/Integrals_Monoelec/EZFIO.cfg index 04e49ec1..c8a8eaef 100644 --- a/src/Integrals_Monoelec/EZFIO.cfg +++ b/src/Integrals_Monoelec/EZFIO.cfg @@ -4,6 +4,14 @@ doc: Read/Write MO one-electron integrals from/to disk [ Write | Read | None ] interface: ezfio,provider,ocaml default: None + +[disk_access_only_mo_one_integrals] +type: Disk_access +doc: Read/Write MO for only the total one-electron integrals which can be anything [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + + [disk_access_ao_one_integrals] type: Disk_access doc: Read/Write AO one-electron integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Monoelec/mo_mono_ints.irp.f b/src/Integrals_Monoelec/mo_mono_ints.irp.f index 50ab7ffa..816dd277 100644 --- a/src/Integrals_Monoelec/mo_mono_ints.irp.f +++ b/src/Integrals_Monoelec/mo_mono_ints.irp.f @@ -6,10 +6,24 @@ BEGIN_PROVIDER [ double precision, mo_mono_elec_integral,(mo_tot_num_align,mo_to ! sum of the kinetic and nuclear electronic potential END_DOC print*,'Providing the mono electronic integrals' - do j = 1, mo_tot_num - do i = 1, mo_tot_num - mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & - mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) - enddo - enddo + if (read_only_mo_one_integrals) then + print*, 'Reading the mono electronic integrals from disk' + call read_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & + size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) + print *, 'MO N-e integrals read from disk' + else + do j = 1, mo_tot_num + do i = 1, mo_tot_num + mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) + enddo + enddo + endif + +! if (write_mo_one_integrals) then +! call write_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & +! size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) +! print *, 'MO N-e integrals written to disk' +! endif + END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index 7116d2c7..aef8a060 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -185,7 +185,7 @@ include 'Utils/constants.include.F' enddo const_factor = dist*rho const = p * dist_integral - if(const_factor > 80.d0)then + if(const_factor > 1000.d0)then NAI_pol_mult = 0.d0 return endif diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 22cceab9..bfe10b91 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential integrals END_DOC - + if (read_ao_one_integrals) then call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) @@ -53,7 +53,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) - thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & diff --git a/src/Integrals_Monoelec/read_write.irp.f b/src/Integrals_Monoelec/read_write.irp.f index 697bf356..0e758740 100644 --- a/src/Integrals_Monoelec/read_write.irp.f +++ b/src/Integrals_Monoelec/read_write.irp.f @@ -1,5 +1,6 @@ BEGIN_PROVIDER [ logical, read_ao_one_integrals ] &BEGIN_PROVIDER [ logical, read_mo_one_integrals ] +&BEGIN_PROVIDER [ logical, read_only_mo_one_integrals ] &BEGIN_PROVIDER [ logical, write_ao_one_integrals ] &BEGIN_PROVIDER [ logical, write_mo_one_integrals ] @@ -21,10 +22,14 @@ write_ao_one_integrals = .False. else - print *, 'bielec_integrals/disk_access_ao_integrals has a wrong type' + print *, 'monoelec_integrals/disk_access_ao_integrals has a wrong type' stop 1 endif + + if (disk_access_only_mo_one_integrals.EQ.'Read')then + read_only_mo_one_integrals = .True. + endif if (disk_access_mo_one_integrals.EQ.'Read') then read_mo_one_integrals = .True. @@ -39,7 +44,7 @@ write_mo_one_integrals = .False. else - print *, 'bielec_integrals/disk_access_mo_integrals has a wrong type' + print *, 'monoelec_integrals/disk_access_mo_integrals has a wrong type' stop 1 endif diff --git a/src/MO_Basis/cholesky_mo.irp.f b/src/MO_Basis/cholesky_mo.irp.f index 65184c1e..774198a3 100644 --- a/src/MO_Basis/cholesky_mo.irp.f +++ b/src/MO_Basis/cholesky_mo.irp.f @@ -50,12 +50,88 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) deallocate(W,work) end +!subroutine svd_mo(n,m,P,LDP,C,LDC) +!implicit none +!BEGIN_DOC +! Singular value decomposition of the AO Density matrix +! +! n : Number of AOs + +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! +! tol_in : tolerance +! +! rank : Nomber of local MOs (output) +! +!END_DOC +!integer, intent(in) :: n,m, LDC, LDP +!double precision, intent(in) :: P(LDP,n) +!double precision, intent(out) :: C(LDC,m) + +!integer :: info +!integer :: i,k +!integer :: ipiv(n) +!double precision:: tol +!double precision, allocatable :: W(:,:), work(:) + +!allocate(W(LDC,n),work(2*n)) +!call svd(P,LDP,C,LDC,W,size(W,1),m,n) + +!deallocate(W,work) +!end + subroutine svd_mo(n,m,P,LDP,C,LDC) implicit none BEGIN_DOC ! Singular value decomposition of the AO Density matrix ! ! n : Number of AOs +! +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! + END_DOC + integer, intent(in) :: n,m, LDC, LDP + double precision, intent(in) :: P(LDP,n) + double precision, intent(out) :: C(LDC,m) + + integer :: info + integer :: i,k + integer :: ipiv(n) + double precision:: tol + double precision, allocatable :: W(:,:), work(:), D(:) + + allocate(W(LDC,n),work(2*n),D(n)) + print*, '' + do i = 1, n + print*, P(i,i) + enddo + call svd(P,LDP,C,LDC,D,W,size(W,1),m,n) + double precision :: accu + accu = 0.d0 + print*, 'm',m + do i = 1, m + print*, D(i) + accu += D(i) + enddo + print*,'Sum of D',accu + + deallocate(W,work) +end + +subroutine svd_mo_new(n,m,m_physical,P,LDP,C,LDC) + implicit none + BEGIN_DOC +! Singular value decomposition of the AO Density matrix +! +! n : Number of AOs ! m : Number of MOs ! @@ -68,7 +144,7 @@ subroutine svd_mo(n,m,P,LDP,C,LDC) ! rank : Nomber of local MOs (output) ! END_DOC - integer, intent(in) :: n,m, LDC, LDP + integer, intent(in) :: n,m,m_physical, LDC, LDP double precision, intent(in) :: P(LDP,n) double precision, intent(out) :: C(LDC,m) @@ -76,10 +152,18 @@ subroutine svd_mo(n,m,P,LDP,C,LDC) integer :: i,k integer :: ipiv(n) double precision:: tol - double precision, allocatable :: W(:,:), work(:) + double precision, allocatable :: W(:,:), work(:), D(:) - allocate(W(LDC,n),work(2*n)) - call svd(P,LDP,C,LDC,W,size(W,1),m,n) + allocate(W(LDC,n),work(2*n),D(n)) + call svd(P,LDP,C,LDC,D,W,size(W,1),m_physical,n) + double precision :: accu + accu = 0.d0 + print*, 'm',m_physical + do i = 1, m_physical + print*, D(i) + accu += D(i) + enddo + print*,'Sum of D',accu deallocate(W,work) end diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 19835395..56ab8d2f 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -181,24 +181,146 @@ subroutine mo_to_ao(A_mo,LDA_mo,A_ao,LDA_ao) allocate ( T(mo_tot_num_align,ao_num) ) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T +! SC call dgemm('N','N', ao_num, mo_tot_num, ao_num, & 1.d0, ao_overlap,size(ao_overlap,1), & mo_coef, size(mo_coef,1), & 0.d0, SC, ao_num_align) +! A.CS call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & 1.d0, A_mo,LDA_mo, & SC, size(SC,1), & 0.d0, T, mo_tot_num_align) +! SC.A.CS call dgemm('N','N', ao_num, ao_num, mo_tot_num, & 1.d0, SC,size(SC,1), & T, mo_tot_num_align, & 0.d0, A_ao, LDA_ao) +! C(S.A.S)C +! SC.A.CS deallocate(T,SC) end + +subroutine mo_to_ao_s_inv_1_2(A_mo,LDA_mo,A_ao,LDA_ao) + implicit none + BEGIN_DOC + ! Transform A from the MO basis to the AO basis using the S^{-1} matrix + ! S^{-1} C A C^{+} S^{-1} + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_mo(LDA_mo) + double precision, intent(out) :: A_ao(LDA_ao) + double precision, allocatable :: T(:,:), SC_inv_1_2(:,:) + + allocate ( SC_inv_1_2(ao_num_align,mo_tot_num) ) + allocate ( T(mo_tot_num_align,ao_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + +! SC_inv_1_2 = S^{-1}C + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, ao_overlap_inv_1_2,size(ao_overlap_inv_1_2,1), & + mo_coef, size(mo_coef,1), & + 0.d0, SC_inv_1_2, ao_num_align) + +! T = A.(SC_inv_1_2)^{+} + call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & + 1.d0, A_mo,LDA_mo, & + SC_inv_1_2, size(SC_inv_1_2,1), & + 0.d0, T, mo_tot_num_align) + +! SC_inv_1_2.A.CS + call dgemm('N','N', ao_num, ao_num, mo_tot_num, & + 1.d0, SC_inv_1_2,size(SC_inv_1_2,1), & + T, mo_tot_num_align, & + 0.d0, A_ao, LDA_ao) + +! C(S.A.S)C +! SC_inv_1_2.A.CS + deallocate(T,SC_inv_1_2) +end + +subroutine mo_to_ao_s_1_2(A_mo,LDA_mo,A_ao,LDA_ao) + implicit none + BEGIN_DOC + ! Transform A from the MO basis to the AO basis using the S^{-1} matrix + ! S^{-1} C A C^{+} S^{-1} + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_mo(LDA_mo) + double precision, intent(out) :: A_ao(LDA_ao) + double precision, allocatable :: T(:,:), SC_1_2(:,:) + + allocate ( SC_1_2(ao_num_align,mo_tot_num) ) + allocate ( T(mo_tot_num_align,ao_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + +! SC_1_2 = S^{-1}C + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, ao_overlap_1_2,size(ao_overlap_1_2,1), & + mo_coef, size(mo_coef,1), & + 0.d0, SC_1_2, ao_num_align) + +! T = A.(SC_1_2)^{+} + call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & + 1.d0, A_mo,LDA_mo, & + SC_1_2, size(SC_1_2,1), & + 0.d0, T, mo_tot_num_align) + +! SC_1_2.A.CS + call dgemm('N','N', ao_num, ao_num, mo_tot_num, & + 1.d0, SC_1_2,size(SC_1_2,1), & + T, mo_tot_num_align, & + 0.d0, A_ao, LDA_ao) + +! C(S.A.S)C +! SC_1_2.A.CS + deallocate(T,SC_1_2) +end + + +subroutine mo_to_ao_s_inv(A_mo,LDA_mo,A_ao,LDA_ao) + implicit none + BEGIN_DOC + ! Transform A from the MO basis to the AO basis using the S^{-1} matrix + ! S^{-1} C A C^{+} S^{-1} + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_mo(LDA_mo) + double precision, intent(out) :: A_ao(LDA_ao) + double precision, allocatable :: T(:,:), SC_inv(:,:) + + allocate ( SC_inv(ao_num_align,mo_tot_num) ) + allocate ( T(mo_tot_num_align,ao_num) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + +! SC_inv = S^{-1}C + call dgemm('N','N', ao_num, mo_tot_num, ao_num, & + 1.d0, ao_overlap_inv,size(ao_overlap_inv,1), & + mo_coef, size(mo_coef,1), & + 0.d0, SC_inv, ao_num_align) + +! T = A.(SC_inv)^{+} + call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & + 1.d0, A_mo,LDA_mo, & + SC_inv, size(SC_inv,1), & + 0.d0, T, mo_tot_num_align) + +! SC_inv.A.CS + call dgemm('N','N', ao_num, ao_num, mo_tot_num, & + 1.d0, SC_inv,size(SC_inv,1), & + T, mo_tot_num_align, & + 0.d0, A_ao, LDA_ao) + +! C(S.A.S)C +! SC_inv.A.CS + deallocate(T,SC_inv) +end + + subroutine mo_to_ao_no_overlap(A_mo,LDA_mo,A_ao,LDA_ao) implicit none BEGIN_DOC diff --git a/src/MO_Basis/rotate_mos.irp.f b/src/MO_Basis/rotate_mos.irp.f new file mode 100644 index 00000000..a1c03bcd --- /dev/null +++ b/src/MO_Basis/rotate_mos.irp.f @@ -0,0 +1,8 @@ +program rotate + implicit none + integer :: iorb,jorb + print*, 'which mos would you like to rotate' + read(5,*)iorb,jorb + call mix_mo_jk(iorb,jorb) + call save_mos +end diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 750e3420..8afa8744 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -272,21 +272,13 @@ subroutine give_all_mos_at_r(r,mos_array) implicit none double precision, intent(in) :: r(3) double precision, intent(out) :: mos_array(mo_tot_num) - call give_specific_mos_at_r(r,mos_array, mo_coef) -end - -subroutine give_specific_mos_at_r(r,mos_array, mo_coef_specific) - implicit none - double precision, intent(in) :: r(3) - double precision, intent(in) :: mo_coef_specific(ao_num_align, mo_tot_num) - double precision, intent(out) :: mos_array(mo_tot_num) double precision :: aos_array(ao_num),accu integer :: i,j call give_all_aos_at_r(r,aos_array) do i = 1, mo_tot_num accu = 0.d0 do j = 1, ao_num - accu += mo_coef_specific(j,i) * aos_array(j) + accu += mo_coef(j,i) * aos_array(j) enddo mos_array(i) = accu enddo diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index fc23b678..04eea7c6 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -86,4 +86,16 @@ doc: QMC grid interface: ezfio size: (ao_basis.ao_num,-pseudo.pseudo_lmax:pseudo.pseudo_lmax,0:pseudo.pseudo_lmax,nuclei.nucl_num,pseudo.pseudo_grid_size) +[disk_access_pseudo_local_integrals] +type: Disk_access +doc: Read/Write the local ntegrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + +[disk_access_pseudo_no_local_integrals] +type: Disk_access +doc: Read/Write the no-local ntegrals from/to disk [ Write | Read | None ] +interface: ezfio,provider,ocaml +default: None + diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 9f94bb62..32090f01 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -19,6 +19,10 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) double precision,allocatable :: A_tmp(:,:) allocate (A_tmp(LDA,n)) + print*, '' + do i = 1, n + print*, A(i,i) + enddo A_tmp = A ! Find optimal size for temp arrays diff --git a/src/Utils/angular_integration.irp.f b/src/Utils/angular_integration.irp.f index 1efd4abc..757508a1 100644 --- a/src/Utils/angular_integration.irp.f +++ b/src/Utils/angular_integration.irp.f @@ -4,7 +4,7 @@ BEGIN_PROVIDER [integer, degree_max_integration_lebedev] ! needed for the angular integration according to LEBEDEV formulae END_DOC implicit none - degree_max_integration_lebedev= 15 + degree_max_integration_lebedev= 13 END_PROVIDER @@ -644,14 +644,14 @@ END_PROVIDER weights_angular_integration_lebedev(16) = 0.016604069565742d0 weights_angular_integration_lebedev(17) = 0.016604069565742d0 weights_angular_integration_lebedev(18) = 0.016604069565742d0 - weights_angular_integration_lebedev(19) = -0.029586038961039d0 - weights_angular_integration_lebedev(20) = -0.029586038961039d0 - weights_angular_integration_lebedev(21) = -0.029586038961039d0 - weights_angular_integration_lebedev(22) = -0.029586038961039d0 - weights_angular_integration_lebedev(23) = -0.029586038961039d0 - weights_angular_integration_lebedev(24) = -0.029586038961039d0 - weights_angular_integration_lebedev(25) = -0.029586038961039d0 - weights_angular_integration_lebedev(26) = -0.029586038961039d0 + weights_angular_integration_lebedev(19) = 0.029586038961039d0 + weights_angular_integration_lebedev(20) = 0.029586038961039d0 + weights_angular_integration_lebedev(21) = 0.029586038961039d0 + weights_angular_integration_lebedev(22) = 0.029586038961039d0 + weights_angular_integration_lebedev(23) = 0.029586038961039d0 + weights_angular_integration_lebedev(24) = 0.029586038961039d0 + weights_angular_integration_lebedev(25) = 0.029586038961039d0 + weights_angular_integration_lebedev(26) = 0.029586038961039d0 weights_angular_integration_lebedev(27) = 0.026576207082159d0 weights_angular_integration_lebedev(28) = 0.026576207082159d0 weights_angular_integration_lebedev(29) = 0.026576207082159d0 diff --git a/src/Utils/constants.include.F b/src/Utils/constants.include.F index 4974fd8e..4655a4fc 100644 --- a/src/Utils/constants.include.F +++ b/src/Utils/constants.include.F @@ -10,3 +10,8 @@ double precision, parameter :: dtwo_pi = 2.d0*dacos(-1.d0) double precision, parameter :: inv_sq_pi = 1.d0/dsqrt(dacos(-1.d0)) double precision, parameter :: inv_sq_pi_2 = 0.5d0/dsqrt(dacos(-1.d0)) double precision, parameter :: thresh = 1.d-15 +double precision, parameter :: cx_lda = -0.73855876638202234d0 +double precision, parameter :: c_2_4_3 = 2.5198420997897464d0 +double precision, parameter :: cst_lda = -0.93052573634909996d0 +double precision, parameter :: c_4_3 = 1.3333333333333333d0 +double precision, parameter :: c_1_3 = 0.3333333333333333d0 diff --git a/src/Utils/invert.irp.f b/src/Utils/invert.irp.f new file mode 100644 index 00000000..4c626cca --- /dev/null +++ b/src/Utils/invert.irp.f @@ -0,0 +1,19 @@ +subroutine invert_matrix(A,LDA,na,A_inv,LDA_inv) +implicit none +double precision, intent(in) :: A (LDA,na) +integer, intent(in) :: LDA, LDA_inv +integer, intent(in) :: na +double precision, intent(out) :: A_inv (LDA_inv,na) + + double precision :: work(LDA_inv*max(na,64)) +!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: work + integer :: inf + integer :: ipiv(LDA_inv) +!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: ipiv + integer :: lwork + A_inv(1:na,1:na) = A(1:na,1:na) + call dgetrf(na, na, A_inv, LDA_inv, ipiv, inf ) + lwork = SIZE(work) + call dgetri(na, A_inv, LDA_inv, ipiv, work, lwork, inf ) +end + diff --git a/tests/input/h2o.xyz b/tests/input/h2o.xyz index e8cd039b..99268e5d 100644 --- a/tests/input/h2o.xyz +++ b/tests/input/h2o.xyz @@ -1,6 +1,6 @@ 3 XYZ file: coordinates in Angstrom -H 0.7510000000 0.1940000000 0.0000000000 O 0.0000000000 -0.3880000000 0.0000000000 +H 0.7510000000 0.1940000000 0.0000000000 H -0.7510000000 0.1940000000 0.0000000000 From ca973a1e921d6b54ac3a462027686a8699740a8e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 08:45:56 +0200 Subject: [PATCH 43/48] Revert "Bugs to fix (#50)" (#51) This reverts commit 94f01c0892f031055bce8f519795d940b0b6ae97. --- config/gfortran.cfg | 4 +- config/ifort.cfg | 2 +- plugins/All_singles/.gitignore | 5 - plugins/CAS_SD_ZMQ/selection.irp.f | 1 - plugins/DDCI_selected/NEEDED_CHILDREN_MODULES | 2 +- plugins/DDCI_selected/ddci.irp.f | 2 +- plugins/DFT_Utils/EZFIO.cfg | 4 + plugins/DFT_Utils/angular.f | 6951 ----------------- plugins/DFT_Utils/functional.irp.f | 54 - plugins/DFT_Utils/grid_density.irp.f | 119 +- plugins/DFT_Utils/integration_3d.irp.f | 9 +- plugins/DFT_Utils/integration_radial.irp.f | 11 +- .../test_integration_3d_density.irp.f | 54 - plugins/FCIdump/NEEDED_CHILDREN_MODULES | 2 +- plugins/FCIdump/fcidump.irp.f | 48 +- plugins/FOBOCI/NEEDED_CHILDREN_MODULES | 2 +- plugins/FOBOCI/SC2_1h1p.irp.f | 2 +- plugins/FOBOCI/all_singles.irp.f | 1 - plugins/FOBOCI/create_1h_or_1p.irp.f | 133 +- plugins/FOBOCI/density.irp.f | 16 - plugins/FOBOCI/density_matrix.irp.f | 44 +- plugins/FOBOCI/dress_simple.irp.f | 59 +- plugins/FOBOCI/fobo_scf.irp.f | 7 +- .../foboci_lmct_mlct_threshold_old.irp.f | 23 +- plugins/FOBOCI/generators_restart_save.irp.f | 35 +- plugins/FOBOCI/routines_foboci.irp.f | 162 +- plugins/FOBOCI/track_orb.irp.f | 57 - plugins/Full_CI/H_apply.irp.f | 5 + plugins/Full_CI/NEEDED_CHILDREN_MODULES | 2 +- plugins/Full_CI_ZMQ/.gitignore | 5 - plugins/Full_CI_ZMQ/selection.irp.f | 1113 --- .../Generators_CAS/Generators_full/.gitignore | 25 - .../Generators_full/NEEDED_CHILDREN_MODULES | 1 - .../Generators_CAS/Generators_full/README.rst | 61 - .../Generators_full/generators.irp.f | 75 - .../Generators_full/tree_dependency.png | Bin 82663 -> 0 bytes plugins/Generators_CAS/generators.irp.f | 16 +- plugins/Integrals_erf/EZFIO.cfg | 34 - plugins/Integrals_erf/NEEDED_CHILDREN_MODULES | 1 - .../Integrals_erf/ao_bi_integrals_erf.irp.f | 570 -- ...ao_bielec_integrals_erf_in_map_slave.irp.f | 175 - .../Integrals_erf/integrals_3_index_erf.irp.f | 22 - plugins/Integrals_erf/map_integrals_erf.irp.f | 626 -- .../Integrals_erf/mo_bi_integrals_erf.irp.f | 616 -- plugins/Integrals_erf/providers_ao_erf.irp.f | 119 - plugins/Integrals_erf/qp_ao_erf_ints.irp.f | 32 - plugins/Integrals_erf/read_write.irp.f | 47 - .../NEEDED_CHILDREN_MODULES | 1 - plugins/Integrals_restart_DFT/README.rst | 12 - .../short_range_coulomb.irp.f | 79 - .../write_integrals_restart_dft.irp.f | 18 - plugins/Kohn_Sham/EZFIO.cfg | 54 - plugins/Kohn_Sham/Fock_matrix.irp.f | 468 -- plugins/Kohn_Sham/HF_density_matrix_ao.irp.f | 41 - plugins/Kohn_Sham/KS_SCF.irp.f | 54 - plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES | 1 - plugins/Kohn_Sham/damping_SCF.irp.f | 132 - plugins/Kohn_Sham/diagonalize_fock.irp.f | 119 - plugins/Kohn_Sham/potential_functional.irp.f | 31 - plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES | 2 +- plugins/MRCC_Utils/amplitudes.irp.f | 7 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 55 +- plugins/MRPT/MRPT_Utils.main.irp.f | 46 +- plugins/MRPT/NEEDED_CHILDREN_MODULES | 2 +- plugins/MRPT/print_1h2p.irp.f | 75 +- plugins/MRPT_Utils/EZFIO.cfg | 7 - plugins/MRPT_Utils/H_apply.irp.f | 8 - plugins/MRPT_Utils/MRMP2_density.irp.f | 46 - plugins/MRPT_Utils/density_matrix_based.irp.f | 193 - plugins/MRPT_Utils/energies_cas.irp.f | 780 +- plugins/MRPT_Utils/excitations_cas.irp.f | 297 +- plugins/MRPT_Utils/fock_like_operators.irp.f | 2 +- plugins/MRPT_Utils/mrpt_dress.irp.f | 119 +- plugins/MRPT_Utils/mrpt_utils.irp.f | 213 +- plugins/MRPT_Utils/new_way.irp.f | 315 +- .../new_way_second_order_coef.irp.f | 8 +- plugins/MRPT_Utils/psi_active_prov.irp.f | 11 +- plugins/MRPT_Utils/second_order_new.irp.f | 8 +- plugins/MRPT_Utils/second_order_new_2p.irp.f | 4 +- plugins/Perturbation/NEEDED_CHILDREN_MODULES | 2 +- plugins/Perturbation/pt2_equations.irp.f | 30 + .../pt2_new.irp.f | 0 plugins/Psiref_CAS/psi_ref.irp.f | 21 - plugins/SCF_density/.gitignore | 25 - plugins/SCF_density/EZFIO.cfg | 35 - plugins/SCF_density/Fock_matrix.irp.f | 437 -- .../SCF_density/HF_density_matrix_ao.irp.f | 66 - plugins/SCF_density/NEEDED_CHILDREN_MODULES | 1 - plugins/SCF_density/README.rst | 175 - plugins/SCF_density/damping_SCF.irp.f | 132 - plugins/SCF_density/diagonalize_fock.irp.f | 124 - plugins/SCF_density/huckel.irp.f | 32 - .../Slater_rules_DFT/NEEDED_CHILDREN_MODULES | 1 - plugins/Slater_rules_DFT/README.rst | 12 - .../Slater_rules_DFT.main.irp.f | 38 - plugins/Slater_rules_DFT/energy.irp.f | 7 - .../Slater_rules_DFT/slater_rules_erf.irp.f | 445 -- plugins/core_integrals/.gitignore | 5 - .../core_integrals/NEEDED_CHILDREN_MODULES | 1 - plugins/core_integrals/README.rst | 12 - .../core_integrals/core_integrals.main.irp.f | 7 - plugins/core_integrals/core_quantities.irp.f | 32 - plugins/loc_cele/loc.f | 2 +- plugins/loc_cele/loc_cele.irp.f | 43 +- plugins/loc_cele/loc_exchange_int.irp.f | 27 +- plugins/loc_cele/loc_exchange_int_act.irp.f | 9 +- plugins/mrcepa0/.gitignore | 5 - plugins/mrcepa0/NEEDED_CHILDREN_MODULES | 2 +- plugins/mrcepa0/dressing.irp.f | 8 +- scripts/compilation/qp_create_ninja.py | 2 +- .../qp_convert_output_to_ezfio.py | 12 +- scripts/generate_h_apply.py | 6 +- scripts/module/module_handler.py | 4 - src/AO_Basis/ao_overlap.irp.f | 45 - src/AO_Basis/aos_value.irp.f | 1 - src/Bitmask/bitmask_cas_routines.irp.f | 21 - ...ze_restart_and_save_all_nstates_diag.irp.f | 16 - ...gonalize_restart_and_save_all_states.irp.f | 2 +- src/Determinants/EZFIO.cfg | 6 - src/Determinants/H_apply.irp.f | 76 - src/Determinants/H_apply_nozmq.template.f | 2 +- src/Determinants/H_apply_zmq.template.f | 2 +- src/Determinants/density_matrix.irp.f | 109 +- ...gonalize_restart_and_save_two_states.irp.f | 27 + src/Determinants/print_wf.irp.f | 41 +- src/Determinants/slater_rules.irp.f | 18 - src/Determinants/truncate_wf.irp.f | 46 +- src/Determinants/two_body_dm_map.irp.f | 199 +- src/Integrals_Bielec/EZFIO.cfg | 1 - src/Integrals_Monoelec/EZFIO.cfg | 8 - src/Integrals_Monoelec/mo_mono_ints.irp.f | 26 +- src/Integrals_Monoelec/pot_ao_ints.irp.f | 2 +- .../pot_ao_pseudo_ints.irp.f | 3 +- src/Integrals_Monoelec/read_write.irp.f | 9 +- src/MO_Basis/cholesky_mo.irp.f | 96 +- src/MO_Basis/mos.irp.f | 122 - src/MO_Basis/rotate_mos.irp.f | 8 - src/MO_Basis/utils.irp.f | 10 +- src/Pseudo/EZFIO.cfg | 12 - src/Utils/LinearAlgebra.irp.f | 4 - src/Utils/angular_integration.irp.f | 18 +- src/Utils/constants.include.F | 5 - src/Utils/invert.irp.f | 19 - tests/input/h2o.xyz | 2 +- 144 files changed, 1406 insertions(+), 15872 deletions(-) delete mode 100644 plugins/All_singles/.gitignore create mode 100644 plugins/DFT_Utils/EZFIO.cfg delete mode 100644 plugins/DFT_Utils/angular.f delete mode 100644 plugins/DFT_Utils/functional.irp.f delete mode 100644 plugins/FOBOCI/density.irp.f delete mode 100644 plugins/FOBOCI/track_orb.irp.f delete mode 100644 plugins/Full_CI_ZMQ/.gitignore delete mode 100644 plugins/Generators_CAS/Generators_full/.gitignore delete mode 100644 plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Generators_CAS/Generators_full/README.rst delete mode 100644 plugins/Generators_CAS/Generators_full/generators.irp.f delete mode 100644 plugins/Generators_CAS/Generators_full/tree_dependency.png delete mode 100644 plugins/Integrals_erf/EZFIO.cfg delete mode 100644 plugins/Integrals_erf/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Integrals_erf/ao_bi_integrals_erf.irp.f delete mode 100644 plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f delete mode 100644 plugins/Integrals_erf/integrals_3_index_erf.irp.f delete mode 100644 plugins/Integrals_erf/map_integrals_erf.irp.f delete mode 100644 plugins/Integrals_erf/mo_bi_integrals_erf.irp.f delete mode 100644 plugins/Integrals_erf/providers_ao_erf.irp.f delete mode 100644 plugins/Integrals_erf/qp_ao_erf_ints.irp.f delete mode 100644 plugins/Integrals_erf/read_write.irp.f delete mode 100644 plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Integrals_restart_DFT/README.rst delete mode 100644 plugins/Integrals_restart_DFT/short_range_coulomb.irp.f delete mode 100644 plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f delete mode 100644 plugins/Kohn_Sham/EZFIO.cfg delete mode 100644 plugins/Kohn_Sham/Fock_matrix.irp.f delete mode 100644 plugins/Kohn_Sham/HF_density_matrix_ao.irp.f delete mode 100644 plugins/Kohn_Sham/KS_SCF.irp.f delete mode 100644 plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Kohn_Sham/damping_SCF.irp.f delete mode 100644 plugins/Kohn_Sham/diagonalize_fock.irp.f delete mode 100644 plugins/Kohn_Sham/potential_functional.irp.f delete mode 100644 plugins/MRPT_Utils/MRMP2_density.irp.f delete mode 100644 plugins/MRPT_Utils/density_matrix_based.irp.f rename plugins/{MRPT_Utils => Perturbation}/pt2_new.irp.f (100%) delete mode 100644 plugins/SCF_density/.gitignore delete mode 100644 plugins/SCF_density/EZFIO.cfg delete mode 100644 plugins/SCF_density/Fock_matrix.irp.f delete mode 100644 plugins/SCF_density/HF_density_matrix_ao.irp.f delete mode 100644 plugins/SCF_density/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/SCF_density/README.rst delete mode 100644 plugins/SCF_density/damping_SCF.irp.f delete mode 100644 plugins/SCF_density/diagonalize_fock.irp.f delete mode 100644 plugins/SCF_density/huckel.irp.f delete mode 100644 plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Slater_rules_DFT/README.rst delete mode 100644 plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f delete mode 100644 plugins/Slater_rules_DFT/energy.irp.f delete mode 100644 plugins/Slater_rules_DFT/slater_rules_erf.irp.f delete mode 100644 plugins/core_integrals/.gitignore delete mode 100644 plugins/core_integrals/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/core_integrals/README.rst delete mode 100644 plugins/core_integrals/core_integrals.main.irp.f delete mode 100644 plugins/core_integrals/core_quantities.irp.f delete mode 100644 plugins/mrcepa0/.gitignore delete mode 100644 src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f create mode 100644 src/Determinants/diagonalize_restart_and_save_two_states.irp.f delete mode 100644 src/MO_Basis/rotate_mos.irp.f delete mode 100644 src/Utils/invert.irp.f diff --git a/config/gfortran.cfg b/config/gfortran.cfg index 60e32235..c0aa875f 100644 --- a/config/gfortran.cfg +++ b/config/gfortran.cfg @@ -35,14 +35,14 @@ OPENMP : 1 ; Append OpenMP flags # -ffast-math and the Fortran-specific # -fno-protect-parens and -fstack-arrays. [OPT] -FCFLAGS : +FCFLAGS : -Ofast # Profiling flags ################# # [PROFILE] FC : -p -g -FCFLAGS : +FCFLAGS : -Ofast # Debugging flags ################# diff --git a/config/ifort.cfg b/config/ifort.cfg index ed3108c5..843e887b 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -58,6 +58,6 @@ FCFLAGS : -xSSE2 -C -fpe0 ################# # [OPENMP] -FC : -openmp +FC : -qopenmp IRPF90_FLAGS : --openmp diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/All_singles/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index f18ba774..3692710d 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1332,4 +1332,3 @@ subroutine selection_collector(b, pt2) call sort_selection_buffer(b) end subroutine - diff --git a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES index d212e150..0b7ce8a9 100644 --- a/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES +++ b/plugins/DDCI_selected/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_CAS Davidson Psiref_CAS +Perturbation Selectors_full Generators_CAS Davidson diff --git a/plugins/DDCI_selected/ddci.irp.f b/plugins/DDCI_selected/ddci.irp.f index a1824857..0bfb324f 100644 --- a/plugins/DDCI_selected/ddci.irp.f +++ b/plugins/DDCI_selected/ddci.irp.f @@ -5,7 +5,7 @@ program ddci double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:) integer :: N_st, degree - N_st = N_states + N_st = N_states_diag allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) character*(64) :: perturbation diff --git a/plugins/DFT_Utils/EZFIO.cfg b/plugins/DFT_Utils/EZFIO.cfg new file mode 100644 index 00000000..21cc5b98 --- /dev/null +++ b/plugins/DFT_Utils/EZFIO.cfg @@ -0,0 +1,4 @@ +[energy] +type: double precision +doc: Calculated energy +interface: ezfio diff --git a/plugins/DFT_Utils/angular.f b/plugins/DFT_Utils/angular.f deleted file mode 100644 index a5052a32..00000000 --- a/plugins/DFT_Utils/angular.f +++ /dev/null @@ -1,6951 +0,0 @@ - subroutine gen_oh(code, num, x, y, z, w, a, b, v) - implicit logical(a-z) - double precision x(*),y(*),z(*),w(*) - double precision a,b,v - integer code - integer num - double precision c -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated from C to fortran77 by hand. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd -cvw -cvw Given a point on a sphere (specified by a and b), generate all -cvw the equivalent points under Oh symmetry, making grid points with -cvw weight v. -cvw The variable num is increased by the number of different points -cvw generated. -cvw -cvw Depending on code, there are 6...48 different but equivalent -cvw points. -cvw -cvw code=1: (0,0,1) etc ( 6 points) -cvw code=2: (0,a,a) etc, a=1/sqrt(2) ( 12 points) -cvw code=3: (a,a,a) etc, a=1/sqrt(3) ( 8 points) -cvw code=4: (a,a,b) etc, b=sqrt(1-2 a^2) ( 24 points) -cvw code=5: (a,b,0) etc, b=sqrt(1-a^2), a input ( 24 points) -cvw code=6: (a,b,c) etc, c=sqrt(1-a^2-b^2), a/b input ( 48 points) -cvw - goto (1,2,3,4,5,6) code - write (6,*) 'Gen_Oh: Invalid Code' - stop - 1 continue - a=1.0d0 - x(1) = a - y(1) = 0.0d0 - z(1) = 0.0d0 - w(1) = v - x(2) = -a - y(2) = 0.0d0 - z(2) = 0.0d0 - w(2) = v - x(3) = 0.0d0 - y(3) = a - z(3) = 0.0d0 - w(3) = v - x(4) = 0.0d0 - y(4) = -a - z(4) = 0.0d0 - w(4) = v - x(5) = 0.0d0 - y(5) = 0.0d0 - z(5) = a - w(5) = v - x(6) = 0.0d0 - y(6) = 0.0d0 - z(6) = -a - w(6) = v - num=num+6 - return -cvw - 2 continue - a=sqrt(0.5d0) - x( 1) = 0d0 - y( 1) = a - z( 1) = a - w( 1) = v - x( 2) = 0d0 - y( 2) = -a - z( 2) = a - w( 2) = v - x( 3) = 0d0 - y( 3) = a - z( 3) = -a - w( 3) = v - x( 4) = 0d0 - y( 4) = -a - z( 4) = -a - w( 4) = v - x( 5) = a - y( 5) = 0d0 - z( 5) = a - w( 5) = v - x( 6) = -a - y( 6) = 0d0 - z( 6) = a - w( 6) = v - x( 7) = a - y( 7) = 0d0 - z( 7) = -a - w( 7) = v - x( 8) = -a - y( 8) = 0d0 - z( 8) = -a - w( 8) = v - x( 9) = a - y( 9) = a - z( 9) = 0d0 - w( 9) = v - x(10) = -a - y(10) = a - z(10) = 0d0 - w(10) = v - x(11) = a - y(11) = -a - z(11) = 0d0 - w(11) = v - x(12) = -a - y(12) = -a - z(12) = 0d0 - w(12) = v - num=num+12 - return -cvw - 3 continue - a = sqrt(1d0/3d0) - x(1) = a - y(1) = a - z(1) = a - w(1) = v - x(2) = -a - y(2) = a - z(2) = a - w(2) = v - x(3) = a - y(3) = -a - z(3) = a - w(3) = v - x(4) = -a - y(4) = -a - z(4) = a - w(4) = v - x(5) = a - y(5) = a - z(5) = -a - w(5) = v - x(6) = -a - y(6) = a - z(6) = -a - w(6) = v - x(7) = a - y(7) = -a - z(7) = -a - w(7) = v - x(8) = -a - y(8) = -a - z(8) = -a - w(8) = v - num=num+8 - return -cvw - 4 continue - b = sqrt(1d0 - 2d0*a*a) - x( 1) = a - y( 1) = a - z( 1) = b - w( 1) = v - x( 2) = -a - y( 2) = a - z( 2) = b - w( 2) = v - x( 3) = a - y( 3) = -a - z( 3) = b - w( 3) = v - x( 4) = -a - y( 4) = -a - z( 4) = b - w( 4) = v - x( 5) = a - y( 5) = a - z( 5) = -b - w( 5) = v - x( 6) = -a - y( 6) = a - z( 6) = -b - w( 6) = v - x( 7) = a - y( 7) = -a - z( 7) = -b - w( 7) = v - x( 8) = -a - y( 8) = -a - z( 8) = -b - w( 8) = v - x( 9) = a - y( 9) = b - z( 9) = a - w( 9) = v - x(10) = -a - y(10) = b - z(10) = a - w(10) = v - x(11) = a - y(11) = -b - z(11) = a - w(11) = v - x(12) = -a - y(12) = -b - z(12) = a - w(12) = v - x(13) = a - y(13) = b - z(13) = -a - w(13) = v - x(14) = -a - y(14) = b - z(14) = -a - w(14) = v - x(15) = a - y(15) = -b - z(15) = -a - w(15) = v - x(16) = -a - y(16) = -b - z(16) = -a - w(16) = v - x(17) = b - y(17) = a - z(17) = a - w(17) = v - x(18) = -b - y(18) = a - z(18) = a - w(18) = v - x(19) = b - y(19) = -a - z(19) = a - w(19) = v - x(20) = -b - y(20) = -a - z(20) = a - w(20) = v - x(21) = b - y(21) = a - z(21) = -a - w(21) = v - x(22) = -b - y(22) = a - z(22) = -a - w(22) = v - x(23) = b - y(23) = -a - z(23) = -a - w(23) = v - x(24) = -b - y(24) = -a - z(24) = -a - w(24) = v - num=num+24 - return -cvw - 5 continue - b=sqrt(1d0-a*a) - x( 1) = a - y( 1) = b - z( 1) = 0d0 - w( 1) = v - x( 2) = -a - y( 2) = b - z( 2) = 0d0 - w( 2) = v - x( 3) = a - y( 3) = -b - z( 3) = 0d0 - w( 3) = v - x( 4) = -a - y( 4) = -b - z( 4) = 0d0 - w( 4) = v - x( 5) = b - y( 5) = a - z( 5) = 0d0 - w( 5) = v - x( 6) = -b - y( 6) = a - z( 6) = 0d0 - w( 6) = v - x( 7) = b - y( 7) = -a - z( 7) = 0d0 - w( 7) = v - x( 8) = -b - y( 8) = -a - z( 8) = 0d0 - w( 8) = v - x( 9) = a - y( 9) = 0d0 - z( 9) = b - w( 9) = v - x(10) = -a - y(10) = 0d0 - z(10) = b - w(10) = v - x(11) = a - y(11) = 0d0 - z(11) = -b - w(11) = v - x(12) = -a - y(12) = 0d0 - z(12) = -b - w(12) = v - x(13) = b - y(13) = 0d0 - z(13) = a - w(13) = v - x(14) = -b - y(14) = 0d0 - z(14) = a - w(14) = v - x(15) = b - y(15) = 0d0 - z(15) = -a - w(15) = v - x(16) = -b - y(16) = 0d0 - z(16) = -a - w(16) = v - x(17) = 0d0 - y(17) = a - z(17) = b - w(17) = v - x(18) = 0d0 - y(18) = -a - z(18) = b - w(18) = v - x(19) = 0d0 - y(19) = a - z(19) = -b - w(19) = v - x(20) = 0d0 - y(20) = -a - z(20) = -b - w(20) = v - x(21) = 0d0 - y(21) = b - z(21) = a - w(21) = v - x(22) = 0d0 - y(22) = -b - z(22) = a - w(22) = v - x(23) = 0d0 - y(23) = b - z(23) = -a - w(23) = v - x(24) = 0d0 - y(24) = -b - z(24) = -a - w(24) = v - num=num+24 - return -cvw - 6 continue - c=sqrt(1d0 - a*a - b*b) - x( 1) = a - y( 1) = b - z( 1) = c - w( 1) = v - x( 2) = -a - y( 2) = b - z( 2) = c - w( 2) = v - x( 3) = a - y( 3) = -b - z( 3) = c - w( 3) = v - x( 4) = -a - y( 4) = -b - z( 4) = c - w( 4) = v - x( 5) = a - y( 5) = b - z( 5) = -c - w( 5) = v - x( 6) = -a - y( 6) = b - z( 6) = -c - w( 6) = v - x( 7) = a - y( 7) = -b - z( 7) = -c - w( 7) = v - x( 8) = -a - y( 8) = -b - z( 8) = -c - w( 8) = v - x( 9) = a - y( 9) = c - z( 9) = b - w( 9) = v - x(10) = -a - y(10) = c - z(10) = b - w(10) = v - x(11) = a - y(11) = -c - z(11) = b - w(11) = v - x(12) = -a - y(12) = -c - z(12) = b - w(12) = v - x(13) = a - y(13) = c - z(13) = -b - w(13) = v - x(14) = -a - y(14) = c - z(14) = -b - w(14) = v - x(15) = a - y(15) = -c - z(15) = -b - w(15) = v - x(16) = -a - y(16) = -c - z(16) = -b - w(16) = v - x(17) = b - y(17) = a - z(17) = c - w(17) = v - x(18) = -b - y(18) = a - z(18) = c - w(18) = v - x(19) = b - y(19) = -a - z(19) = c - w(19) = v - x(20) = -b - y(20) = -a - z(20) = c - w(20) = v - x(21) = b - y(21) = a - z(21) = -c - w(21) = v - x(22) = -b - y(22) = a - z(22) = -c - w(22) = v - x(23) = b - y(23) = -a - z(23) = -c - w(23) = v - x(24) = -b - y(24) = -a - z(24) = -c - w(24) = v - x(25) = b - y(25) = c - z(25) = a - w(25) = v - x(26) = -b - y(26) = c - z(26) = a - w(26) = v - x(27) = b - y(27) = -c - z(27) = a - w(27) = v - x(28) = -b - y(28) = -c - z(28) = a - w(28) = v - x(29) = b - y(29) = c - z(29) = -a - w(29) = v - x(30) = -b - y(30) = c - z(30) = -a - w(30) = v - x(31) = b - y(31) = -c - z(31) = -a - w(31) = v - x(32) = -b - y(32) = -c - z(32) = -a - w(32) = v - x(33) = c - y(33) = a - z(33) = b - w(33) = v - x(34) = -c - y(34) = a - z(34) = b - w(34) = v - x(35) = c - y(35) = -a - z(35) = b - w(35) = v - x(36) = -c - y(36) = -a - z(36) = b - w(36) = v - x(37) = c - y(37) = a - z(37) = -b - w(37) = v - x(38) = -c - y(38) = a - z(38) = -b - w(38) = v - x(39) = c - y(39) = -a - z(39) = -b - w(39) = v - x(40) = -c - y(40) = -a - z(40) = -b - w(40) = v - x(41) = c - y(41) = b - z(41) = a - w(41) = v - x(42) = -c - y(42) = b - z(42) = a - w(42) = v - x(43) = c - y(43) = -b - z(43) = a - w(43) = v - x(44) = -c - y(44) = -b - z(44) = a - w(44) = v - x(45) = c - y(45) = b - z(45) = -a - w(45) = v - x(46) = -c - y(46) = b - z(46) = -a - w(46) = v - x(47) = c - y(47) = -b - z(47) = -a - w(47) = v - x(48) = -c - y(48) = -b - z(48) = -a - w(48) = v - num=num+48 - return - end - SUBROUTINE LD0006(X,Y,Z,W,N) - DOUBLE PRECISION X( 6) - DOUBLE PRECISION Y( 6) - DOUBLE PRECISION Z( 6) - DOUBLE PRECISION W( 6) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 6-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1666666666666667D+0 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0014(X,Y,Z,W,N) - DOUBLE PRECISION X( 14) - DOUBLE PRECISION Y( 14) - DOUBLE PRECISION Z( 14) - DOUBLE PRECISION W( 14) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 14-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.6666666666666667D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7500000000000000D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0026(X,Y,Z,W,N) - DOUBLE PRECISION X( 26) - DOUBLE PRECISION Y( 26) - DOUBLE PRECISION Z( 26) - DOUBLE PRECISION W( 26) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 26-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.4761904761904762D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3809523809523810D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3214285714285714D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0038(X,Y,Z,W,N) - DOUBLE PRECISION X( 38) - DOUBLE PRECISION Y( 38) - DOUBLE PRECISION Z( 38) - DOUBLE PRECISION W( 38) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 38-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9523809523809524D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3214285714285714D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4597008433809831D+0 - V=0.2857142857142857D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0050(X,Y,Z,W,N) - DOUBLE PRECISION X( 50) - DOUBLE PRECISION Y( 50) - DOUBLE PRECISION Z( 50) - DOUBLE PRECISION W( 50) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 50-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1269841269841270D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2257495590828924D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2109375000000000D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3015113445777636D+0 - V=0.2017333553791887D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0074(X,Y,Z,W,N) - DOUBLE PRECISION X( 74) - DOUBLE PRECISION Y( 74) - DOUBLE PRECISION Z( 74) - DOUBLE PRECISION W( 74) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 74-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5130671797338464D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1660406956574204D-1 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=-0.2958603896103896D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4803844614152614D+0 - V=0.2657620708215946D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3207726489807764D+0 - V=0.1652217099371571D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0086(X,Y,Z,W,N) - DOUBLE PRECISION X( 86) - DOUBLE PRECISION Y( 86) - DOUBLE PRECISION Z( 86) - DOUBLE PRECISION W( 86) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 86-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1154401154401154D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1194390908585628D-1 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3696028464541502D+0 - V=0.1111055571060340D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6943540066026664D+0 - V=0.1187650129453714D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3742430390903412D+0 - V=0.1181230374690448D-1 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0110(X,Y,Z,W,N) - DOUBLE PRECISION X( 110) - DOUBLE PRECISION Y( 110) - DOUBLE PRECISION Z( 110) - DOUBLE PRECISION W( 110) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 110-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3828270494937162D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9793737512487512D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1851156353447362D+0 - V=0.8211737283191111D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6904210483822922D+0 - V=0.9942814891178103D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3956894730559419D+0 - V=0.9595471336070963D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4783690288121502D+0 - V=0.9694996361663028D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0146(X,Y,Z,W,N) - DOUBLE PRECISION X( 146) - DOUBLE PRECISION Y( 146) - DOUBLE PRECISION Z( 146) - DOUBLE PRECISION W( 146) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 146-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5996313688621381D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7372999718620756D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7210515360144488D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6764410400114264D+0 - V=0.7116355493117555D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4174961227965453D+0 - V=0.6753829486314477D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1574676672039082D+0 - V=0.7574394159054034D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1403553811713183D+0 - B=0.4493328323269557D+0 - V=0.6991087353303262D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0170(X,Y,Z,W,N) - DOUBLE PRECISION X( 170) - DOUBLE PRECISION Y( 170) - DOUBLE PRECISION Z( 170) - DOUBLE PRECISION W( 170) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 170-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5544842902037365D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6071332770670752D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6383674773515093D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2551252621114134D+0 - V=0.5183387587747790D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6743601460362766D+0 - V=0.6317929009813725D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318910696719410D+0 - V=0.6201670006589077D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2613931360335988D+0 - V=0.5477143385137348D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4990453161796037D+0 - B=0.1446630744325115D+0 - V=0.5968383987681156D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0194(X,Y,Z,W,N) - DOUBLE PRECISION X( 194) - DOUBLE PRECISION Y( 194) - DOUBLE PRECISION Z( 194) - DOUBLE PRECISION W( 194) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 194-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1782340447244611D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5716905949977102D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5573383178848738D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6712973442695226D+0 - V=0.5608704082587997D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2892465627575439D+0 - V=0.5158237711805383D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4446933178717437D+0 - V=0.5518771467273614D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1299335447650067D+0 - V=0.4106777028169394D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3457702197611283D+0 - V=0.5051846064614808D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1590417105383530D+0 - B=0.8360360154824589D+0 - V=0.5530248916233094D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0230(X,Y,Z,W,N) - DOUBLE PRECISION X( 230) - DOUBLE PRECISION Y( 230) - DOUBLE PRECISION Z( 230) - DOUBLE PRECISION W( 230) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 230-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=-0.5522639919727325D-1 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4450274607445226D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4492044687397611D+0 - V=0.4496841067921404D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2520419490210201D+0 - V=0.5049153450478750D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6981906658447242D+0 - V=0.3976408018051883D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6587405243460960D+0 - V=0.4401400650381014D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4038544050097660D-1 - V=0.1724544350544401D-1 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5823842309715585D+0 - V=0.4231083095357343D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3545877390518688D+0 - V=0.5198069864064399D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2272181808998187D+0 - B=0.4864661535886647D+0 - V=0.4695720972568883D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0266(X,Y,Z,W,N) - DOUBLE PRECISION X( 266) - DOUBLE PRECISION Y( 266) - DOUBLE PRECISION Z( 266) - DOUBLE PRECISION W( 266) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 266-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=-0.1313769127326952D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=-0.2522728704859336D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4186853881700583D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7039373391585475D+0 - V=0.5315167977810885D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1012526248572414D+0 - V=0.4047142377086219D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4647448726420539D+0 - V=0.4112482394406990D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3277420654971629D+0 - V=0.3595584899758782D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6620338663699974D+0 - V=0.4256131351428158D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8506508083520399D+0 - V=0.4229582700647240D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3233484542692899D+0 - B=0.1153112011009701D+0 - V=0.4080914225780505D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2314790158712601D+0 - B=0.5244939240922365D+0 - V=0.4071467593830964D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0302(X,Y,Z,W,N) - DOUBLE PRECISION X( 302) - DOUBLE PRECISION Y( 302) - DOUBLE PRECISION Z( 302) - DOUBLE PRECISION W( 302) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 302-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.8545911725128148D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3599119285025571D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3515640345570105D+0 - V=0.3449788424305883D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6566329410219612D+0 - V=0.3604822601419882D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4729054132581005D+0 - V=0.3576729661743367D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9618308522614784D-1 - V=0.2352101413689164D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2219645236294178D+0 - V=0.3108953122413675D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7011766416089545D+0 - V=0.3650045807677255D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2644152887060663D+0 - V=0.2982344963171804D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5718955891878961D+0 - V=0.3600820932216460D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2510034751770465D+0 - B=0.8000727494073952D+0 - V=0.3571540554273387D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1233548532583327D+0 - B=0.4127724083168531D+0 - V=0.3392312205006170D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0350(X,Y,Z,W,N) - DOUBLE PRECISION X( 350) - DOUBLE PRECISION Y( 350) - DOUBLE PRECISION Z( 350) - DOUBLE PRECISION W( 350) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 350-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3006796749453936D-2 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3050627745650771D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7068965463912316D+0 - V=0.1621104600288991D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4794682625712025D+0 - V=0.3005701484901752D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1927533154878019D+0 - V=0.2990992529653774D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6930357961327123D+0 - V=0.2982170644107595D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3608302115520091D+0 - V=0.2721564237310992D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6498486161496169D+0 - V=0.3033513795811141D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1932945013230339D+0 - V=0.3007949555218533D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3800494919899303D+0 - V=0.2881964603055307D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2899558825499574D+0 - B=0.7934537856582316D+0 - V=0.2958357626535696D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9684121455103957D-1 - B=0.8280801506686862D+0 - V=0.3036020026407088D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1833434647041659D+0 - B=0.9074658265305127D+0 - V=0.2832187403926303D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0434(X,Y,Z,W,N) - DOUBLE PRECISION X( 434) - DOUBLE PRECISION Y( 434) - DOUBLE PRECISION Z( 434) - DOUBLE PRECISION W( 434) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 434-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.5265897968224436D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2548219972002607D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2512317418927307D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6909346307509111D+0 - V=0.2530403801186355D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1774836054609158D+0 - V=0.2014279020918528D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4914342637784746D+0 - V=0.2501725168402936D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6456664707424256D+0 - V=0.2513267174597564D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2861289010307638D+0 - V=0.2302694782227416D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7568084367178018D-1 - V=0.1462495621594614D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3927259763368002D+0 - V=0.2445373437312980D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8818132877794288D+0 - V=0.2417442375638981D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9776428111182649D+0 - V=0.1910951282179532D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2054823696403044D+0 - B=0.8689460322872412D+0 - V=0.2416930044324775D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5905157048925271D+0 - B=0.7999278543857286D+0 - V=0.2512236854563495D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5550152361076807D+0 - B=0.7717462626915901D+0 - V=0.2496644054553086D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9371809858553722D+0 - B=0.3344363145343455D+0 - V=0.2236607760437849D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0590(X,Y,Z,W,N) - DOUBLE PRECISION X( 590) - DOUBLE PRECISION Y( 590) - DOUBLE PRECISION Z( 590) - DOUBLE PRECISION W( 590) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 590-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3095121295306187D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1852379698597489D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7040954938227469D+0 - V=0.1871790639277744D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6807744066455243D+0 - V=0.1858812585438317D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6372546939258752D+0 - V=0.1852028828296213D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5044419707800358D+0 - V=0.1846715956151242D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4215761784010967D+0 - V=0.1818471778162769D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3317920736472123D+0 - V=0.1749564657281154D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2384736701421887D+0 - V=0.1617210647254411D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1459036449157763D+0 - V=0.1384737234851692D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6095034115507196D-1 - V=0.9764331165051050D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6116843442009876D+0 - V=0.1857161196774078D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3964755348199858D+0 - V=0.1705153996395864D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1724782009907724D+0 - V=0.1300321685886048D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5610263808622060D+0 - B=0.3518280927733519D+0 - V=0.1842866472905286D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4742392842551980D+0 - B=0.2634716655937950D+0 - V=0.1802658934377451D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5984126497885380D+0 - B=0.1816640840360209D+0 - V=0.1849830560443660D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3791035407695563D+0 - B=0.1720795225656878D+0 - V=0.1713904507106709D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2778673190586244D+0 - B=0.8213021581932511D-1 - V=0.1555213603396808D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5033564271075117D+0 - B=0.8999205842074875D-1 - V=0.1802239128008525D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0770(X,Y,Z,W,N) - DOUBLE PRECISION X( 770) - DOUBLE PRECISION Y( 770) - DOUBLE PRECISION Z( 770) - DOUBLE PRECISION W( 770) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 770-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2192942088181184D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1436433617319080D-2 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1421940344335877D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5087204410502360D-1 - V=0.6798123511050502D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1228198790178831D+0 - V=0.9913184235294912D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2026890814408786D+0 - V=0.1180207833238949D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2847745156464294D+0 - V=0.1296599602080921D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3656719078978026D+0 - V=0.1365871427428316D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4428264886713469D+0 - V=0.1402988604775325D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5140619627249735D+0 - V=0.1418645563595609D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6306401219166803D+0 - V=0.1421376741851662D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6716883332022612D+0 - V=0.1423996475490962D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6979792685336881D+0 - V=0.1431554042178567D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1446865674195309D+0 - V=0.9254401499865368D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3390263475411216D+0 - V=0.1250239995053509D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5335804651263506D+0 - V=0.1394365843329230D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6944024393349413D-1 - B=0.2355187894242326D+0 - V=0.1127089094671749D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2269004109529460D+0 - B=0.4102182474045730D+0 - V=0.1345753760910670D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8025574607775339D-1 - B=0.6214302417481605D+0 - V=0.1424957283316783D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1467999527896572D+0 - B=0.3245284345717394D+0 - V=0.1261523341237750D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1571507769824727D+0 - B=0.5224482189696630D+0 - V=0.1392547106052696D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2365702993157246D+0 - B=0.6017546634089558D+0 - V=0.1418761677877656D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7714815866765732D-1 - B=0.4346575516141163D+0 - V=0.1338366684479554D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3062936666210730D+0 - B=0.4908826589037616D+0 - V=0.1393700862676131D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3822477379524787D+0 - B=0.5648768149099500D+0 - V=0.1415914757466932D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD0974(X,Y,Z,W,N) - DOUBLE PRECISION X( 974) - DOUBLE PRECISION Y( 974) - DOUBLE PRECISION Z( 974) - DOUBLE PRECISION W( 974) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 974-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1438294190527431D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1125772288287004D-2 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4292963545341347D-1 - V=0.4948029341949241D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1051426854086404D+0 - V=0.7357990109125470D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1750024867623087D+0 - V=0.8889132771304384D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2477653379650257D+0 - V=0.9888347838921435D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3206567123955957D+0 - V=0.1053299681709471D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3916520749849983D+0 - V=0.1092778807014578D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4590825874187624D+0 - V=0.1114389394063227D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5214563888415861D+0 - V=0.1123724788051555D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6253170244654199D+0 - V=0.1125239325243814D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6637926744523170D+0 - V=0.1126153271815905D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6910410398498301D+0 - V=0.1130286931123841D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7052907007457760D+0 - V=0.1134986534363955D-2 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1236686762657990D+0 - V=0.6823367927109931D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2940777114468387D+0 - V=0.9454158160447096D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4697753849207649D+0 - V=0.1074429975385679D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6334563241139567D+0 - V=0.1129300086569132D-2 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5974048614181342D-1 - B=0.2029128752777523D+0 - V=0.8436884500901954D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1375760408473636D+0 - B=0.4602621942484054D+0 - V=0.1075255720448885D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3391016526336286D+0 - B=0.5030673999662036D+0 - V=0.1108577236864462D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1271675191439820D+0 - B=0.2817606422442134D+0 - V=0.9566475323783357D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2693120740413512D+0 - B=0.4331561291720157D+0 - V=0.1080663250717391D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1419786452601918D+0 - B=0.6256167358580814D+0 - V=0.1126797131196295D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6709284600738255D-1 - B=0.3798395216859157D+0 - V=0.1022568715358061D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7057738183256172D-1 - B=0.5517505421423520D+0 - V=0.1108960267713108D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2783888477882155D+0 - B=0.6029619156159187D+0 - V=0.1122790653435766D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1979578938917407D+0 - B=0.3589606329589096D+0 - V=0.1032401847117460D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2087307061103274D+0 - B=0.5348666438135476D+0 - V=0.1107249382283854D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4055122137872836D+0 - B=0.5674997546074373D+0 - V=0.1121780048519972D-2 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1202(X,Y,Z,W,N) - DOUBLE PRECISION X(1202) - DOUBLE PRECISION Y(1202) - DOUBLE PRECISION Z(1202) - DOUBLE PRECISION W(1202) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1202-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1105189233267572D-3 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9205232738090741D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.9133159786443561D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3712636449657089D-1 - V=0.3690421898017899D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9140060412262223D-1 - V=0.5603990928680660D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1531077852469906D+0 - V=0.6865297629282609D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2180928891660612D+0 - V=0.7720338551145630D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2839874532200175D+0 - V=0.8301545958894795D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3491177600963764D+0 - V=0.8686692550179628D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4121431461444309D+0 - V=0.8927076285846890D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4718993627149127D+0 - V=0.9060820238568219D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5273145452842337D+0 - V=0.9119777254940867D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6209475332444019D+0 - V=0.9128720138604181D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6569722711857291D+0 - V=0.9130714935691735D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6841788309070143D+0 - V=0.9152873784554116D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012604330123631D+0 - V=0.9187436274321654D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1072382215478166D+0 - V=0.5176977312965694D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2582068959496968D+0 - V=0.7331143682101417D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4172752955306717D+0 - V=0.8463232836379928D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5700366911792503D+0 - V=0.9031122694253992D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9827986018263947D+0 - B=0.1771774022615325D+0 - V=0.6485778453163257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9624249230326228D+0 - B=0.2475716463426288D+0 - V=0.7435030910982369D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9402007994128811D+0 - B=0.3354616289066489D+0 - V=0.7998527891839054D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9320822040143202D+0 - B=0.3173615246611977D+0 - V=0.8101731497468018D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9043674199393299D+0 - B=0.4090268427085357D+0 - V=0.8483389574594331D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8912407560074747D+0 - B=0.3854291150669224D+0 - V=0.8556299257311812D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8676435628462708D+0 - B=0.4932221184851285D+0 - V=0.8803208679738260D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8581979986041619D+0 - B=0.4785320675922435D+0 - V=0.8811048182425720D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8396753624049856D+0 - B=0.4507422593157064D+0 - V=0.8850282341265444D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8165288564022188D+0 - B=0.5632123020762100D+0 - V=0.9021342299040653D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8015469370783529D+0 - B=0.5434303569693900D+0 - V=0.9010091677105086D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7773563069070351D+0 - B=0.5123518486419871D+0 - V=0.9022692938426915D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7661621213900394D+0 - B=0.6394279634749102D+0 - V=0.9158016174693465D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7553584143533510D+0 - B=0.6269805509024392D+0 - V=0.9131578003189435D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7344305757559503D+0 - B=0.6031161693096310D+0 - V=0.9107813579482705D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7043837184021765D+0 - B=0.5693702498468441D+0 - V=0.9105760258970126D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1454(X,Y,Z,W,N) - DOUBLE PRECISION X(1454) - DOUBLE PRECISION Y(1454) - DOUBLE PRECISION Z(1454) - DOUBLE PRECISION W(1454) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1454-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.7777160743261247D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.7557646413004701D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3229290663413854D-1 - V=0.2841633806090617D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8036733271462222D-1 - V=0.4374419127053555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1354289960531653D+0 - V=0.5417174740872172D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1938963861114426D+0 - V=0.6148000891358593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2537343715011275D+0 - V=0.6664394485800705D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3135251434752570D+0 - V=0.7025039356923220D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3721558339375338D+0 - V=0.7268511789249627D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4286809575195696D+0 - V=0.7422637534208629D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4822510128282994D+0 - V=0.7509545035841214D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5320679333566263D+0 - V=0.7548535057718401D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6172998195394274D+0 - V=0.7554088969774001D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6510679849127481D+0 - V=0.7553147174442808D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6777315251687360D+0 - V=0.7564767653292297D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6963109410648741D+0 - V=0.7587991808518730D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7058935009831749D+0 - V=0.7608261832033027D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9955546194091857D+0 - V=0.4021680447874916D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9734115901794209D+0 - V=0.5804871793945964D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9275693732388626D+0 - V=0.6792151955945159D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8568022422795103D+0 - V=0.7336741211286294D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7623495553719372D+0 - V=0.7581866300989608D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5707522908892223D+0 - B=0.4387028039889501D+0 - V=0.7538257859800743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5196463388403083D+0 - B=0.3858908414762617D+0 - V=0.7483517247053123D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4646337531215351D+0 - B=0.3301937372343854D+0 - V=0.7371763661112059D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4063901697557691D+0 - B=0.2725423573563777D+0 - V=0.7183448895756934D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3456329466643087D+0 - B=0.2139510237495250D+0 - V=0.6895815529822191D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2831395121050332D+0 - B=0.1555922309786647D+0 - V=0.6480105801792886D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2197682022925330D+0 - B=0.9892878979686097D-1 - V=0.5897558896594636D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1564696098650355D+0 - B=0.4598642910675510D-1 - V=0.5095708849247346D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6027356673721295D+0 - B=0.3376625140173426D+0 - V=0.7536906428909755D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5496032320255096D+0 - B=0.2822301309727988D+0 - V=0.7472505965575118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4921707755234567D+0 - B=0.2248632342592540D+0 - V=0.7343017132279698D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4309422998598483D+0 - B=0.1666224723456479D+0 - V=0.7130871582177445D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3664108182313672D+0 - B=0.1086964901822169D+0 - V=0.6817022032112776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2990189057758436D+0 - B=0.5251989784120085D-1 - V=0.6380941145604121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6268724013144998D+0 - B=0.2297523657550023D+0 - V=0.7550381377920310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5707324144834607D+0 - B=0.1723080607093800D+0 - V=0.7478646640144802D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5096360901960365D+0 - B=0.1140238465390513D+0 - V=0.7335918720601220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4438729938312456D+0 - B=0.5611522095882537D-1 - V=0.7110120527658118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6419978471082389D+0 - B=0.1164174423140873D+0 - V=0.7571363978689501D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5817218061802611D+0 - B=0.5797589531445219D-1 - V=0.7489908329079234D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD1730(X,Y,Z,W,N) - DOUBLE PRECISION X(1730) - DOUBLE PRECISION Y(1730) - DOUBLE PRECISION Z(1730) - DOUBLE PRECISION W(1730) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 1730-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.6309049437420976D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6398287705571748D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.6357185073530720D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2860923126194662D-1 - V=0.2221207162188168D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7142556767711522D-1 - V=0.3475784022286848D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1209199540995559D+0 - V=0.4350742443589804D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1738673106594379D+0 - V=0.4978569136522127D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2284645438467734D+0 - V=0.5435036221998053D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2834807671701512D+0 - V=0.5765913388219542D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3379680145467339D+0 - V=0.6001200359226003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3911355454819537D+0 - V=0.6162178172717512D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4422860353001403D+0 - V=0.6265218152438485D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4907781568726057D+0 - V=0.6323987160974212D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5360006153211468D+0 - V=0.6350767851540569D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6142105973596603D+0 - V=0.6354362775297107D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6459300387977504D+0 - V=0.6352302462706235D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718056125089225D+0 - V=0.6358117881417972D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6910888533186254D+0 - V=0.6373101590310117D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7030467416823252D+0 - V=0.6390428961368665D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8354951166354646D-1 - V=0.3186913449946576D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2050143009099486D+0 - V=0.4678028558591711D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3370208290706637D+0 - V=0.5538829697598626D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4689051484233963D+0 - V=0.6044475907190476D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5939400424557334D+0 - V=0.6313575103509012D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1394983311832261D+0 - B=0.4097581162050343D-1 - V=0.4078626431855630D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1967999180485014D+0 - B=0.8851987391293348D-1 - V=0.4759933057812725D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2546183732548967D+0 - B=0.1397680182969819D+0 - V=0.5268151186413440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3121281074713875D+0 - B=0.1929452542226526D+0 - V=0.5643048560507316D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3685981078502492D+0 - B=0.2467898337061562D+0 - V=0.5914501076613073D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4233760321547856D+0 - B=0.3003104124785409D+0 - V=0.6104561257874195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4758671236059246D+0 - B=0.3526684328175033D+0 - V=0.6230252860707806D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5255178579796463D+0 - B=0.4031134861145713D+0 - V=0.6305618761760796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5718025633734589D+0 - B=0.4509426448342351D+0 - V=0.6343092767597889D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2686927772723415D+0 - B=0.4711322502423248D-1 - V=0.5176268945737826D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3306006819904809D+0 - B=0.9784487303942695D-1 - V=0.5564840313313692D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3904906850594983D+0 - B=0.1505395810025273D+0 - V=0.5856426671038980D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4479957951904390D+0 - B=0.2039728156296050D+0 - V=0.6066386925777091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5027076848919780D+0 - B=0.2571529941121107D+0 - V=0.6208824962234458D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5542087392260217D+0 - B=0.3092191375815670D+0 - V=0.6296314297822907D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6020850887375187D+0 - B=0.3593807506130276D+0 - V=0.6340423756791859D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4019851409179594D+0 - B=0.5063389934378671D-1 - V=0.5829627677107342D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4635614567449800D+0 - B=0.1032422269160612D+0 - V=0.6048693376081110D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5215860931591575D+0 - B=0.1566322094006254D+0 - V=0.6202362317732461D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5758202499099271D+0 - B=0.2098082827491099D+0 - V=0.6299005328403779D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6259893683876795D+0 - B=0.2618824114553391D+0 - V=0.6347722390609353D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5313795124811891D+0 - B=0.5263245019338556D-1 - V=0.6203778981238834D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5893317955931995D+0 - B=0.1061059730982005D+0 - V=0.6308414671239979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6426246321215801D+0 - B=0.1594171564034221D+0 - V=0.6362706466959498D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6511904367376113D+0 - B=0.5354789536565540D-1 - V=0.6375414170333233D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2030(X,Y,Z,W,N) - DOUBLE PRECISION X(2030) - DOUBLE PRECISION Y(2030) - DOUBLE PRECISION Z(2030) - DOUBLE PRECISION W(2030) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2030-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.4656031899197431D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.5421549195295507D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2540835336814348D-1 - V=0.1778522133346553D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6399322800504915D-1 - V=0.2811325405682796D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1088269469804125D+0 - V=0.3548896312631459D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1570670798818287D+0 - V=0.4090310897173364D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2071163932282514D+0 - V=0.4493286134169965D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2578914044450844D+0 - V=0.4793728447962723D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3085687558169623D+0 - V=0.5015415319164265D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3584719706267024D+0 - V=0.5175127372677937D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4070135594428709D+0 - V=0.5285522262081019D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4536618626222638D+0 - V=0.5356832703713962D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4979195686463577D+0 - V=0.5397914736175170D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5393075111126999D+0 - V=0.5416899441599930D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6115617676843916D+0 - V=0.5419308476889938D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6414308435160159D+0 - V=0.5416936902030596D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6664099412721607D+0 - V=0.5419544338703164D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6859161771214913D+0 - V=0.5428983656630975D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6993625593503890D+0 - V=0.5442286500098193D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7062393387719380D+0 - V=0.5452250345057301D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7479028168349763D-1 - V=0.2568002497728530D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1848951153969366D+0 - V=0.3827211700292145D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3059529066581305D+0 - V=0.4579491561917824D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4285556101021362D+0 - V=0.5042003969083574D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5468758653496526D+0 - V=0.5312708889976025D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6565821978343439D+0 - V=0.5438401790747117D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1253901572367117D+0 - B=0.3681917226439641D-1 - V=0.3316041873197344D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1775721510383941D+0 - B=0.7982487607213301D-1 - V=0.3899113567153771D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2305693358216114D+0 - B=0.1264640966592335D+0 - V=0.4343343327201309D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2836502845992063D+0 - B=0.1751585683418957D+0 - V=0.4679415262318919D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3361794746232590D+0 - B=0.2247995907632670D+0 - V=0.4930847981631031D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3875979172264824D+0 - B=0.2745299257422246D+0 - V=0.5115031867540091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4374019316999074D+0 - B=0.3236373482441118D+0 - V=0.5245217148457367D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4851275843340022D+0 - B=0.3714967859436741D+0 - V=0.5332041499895321D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5303391803806868D+0 - B=0.4175353646321745D+0 - V=0.5384583126021542D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726197380596287D+0 - B=0.4612084406355461D+0 - V=0.5411067210798852D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2431520732564863D+0 - B=0.4258040133043952D-1 - V=0.4259797391468714D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3002096800895869D+0 - B=0.8869424306722721D-1 - V=0.4604931368460021D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3558554457457432D+0 - B=0.1368811706510655D+0 - V=0.4871814878255202D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4097782537048887D+0 - B=0.1860739985015033D+0 - V=0.5072242910074885D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4616337666067458D+0 - B=0.2354235077395853D+0 - V=0.5217069845235350D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5110707008417874D+0 - B=0.2842074921347011D+0 - V=0.5315785966280310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5577415286163795D+0 - B=0.3317784414984102D+0 - V=0.5376833708758905D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6013060431366950D+0 - B=0.3775299002040700D+0 - V=0.5408032092069521D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3661596767261781D+0 - B=0.4599367887164592D-1 - V=0.4842744917904866D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4237633153506581D+0 - B=0.9404893773654421D-1 - V=0.5048926076188130D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4786328454658452D+0 - B=0.1431377109091971D+0 - V=0.5202607980478373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5305702076789774D+0 - B=0.1924186388843570D+0 - V=0.5309932388325743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5793436224231788D+0 - B=0.2411590944775190D+0 - V=0.5377419770895208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6247069017094747D+0 - B=0.2886871491583605D+0 - V=0.5411696331677717D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4874315552535204D+0 - B=0.4804978774953206D-1 - V=0.5197996293282420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5427337322059053D+0 - B=0.9716857199366665D-1 - V=0.5311120836622945D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5943493747246700D+0 - B=0.1465205839795055D+0 - V=0.5384309319956951D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6421314033564943D+0 - B=0.1953579449803574D+0 - V=0.5421859504051886D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6020628374713980D+0 - B=0.4916375015738108D-1 - V=0.5390948355046314D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6529222529856881D+0 - B=0.9861621540127005D-1 - V=0.5433312705027845D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2354(X,Y,Z,W,N) - DOUBLE PRECISION X(2354) - DOUBLE PRECISION Y(2354) - DOUBLE PRECISION Z(2354) - DOUBLE PRECISION W(2354) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2354-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.3922616270665292D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4703831750854424D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4678202801282136D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2290024646530589D-1 - V=0.1437832228979900D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5779086652271284D-1 - V=0.2303572493577644D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9863103576375984D-1 - V=0.2933110752447454D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1428155792982185D+0 - V=0.3402905998359838D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1888978116601463D+0 - V=0.3759138466870372D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2359091682970210D+0 - V=0.4030638447899798D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2831228833706171D+0 - V=0.4236591432242211D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3299495857966693D+0 - V=0.4390522656946746D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3758840802660796D+0 - V=0.4502523466626247D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4204751831009480D+0 - V=0.4580577727783541D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4633068518751051D+0 - V=0.4631391616615899D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5039849474507313D+0 - V=0.4660928953698676D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5421265793440747D+0 - V=0.4674751807936953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6092660230557310D+0 - V=0.4676414903932920D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6374654204984869D+0 - V=0.4674086492347870D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6615136472609892D+0 - V=0.4674928539483207D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6809487285958127D+0 - V=0.4680748979686447D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6952980021665196D+0 - V=0.4690449806389040D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7041245497695400D+0 - V=0.4699877075860818D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6744033088306065D-1 - V=0.2099942281069176D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1678684485334166D+0 - V=0.3172269150712804D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2793559049539613D+0 - V=0.3832051358546523D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3935264218057639D+0 - V=0.4252193818146985D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5052629268232558D+0 - V=0.4513807963755000D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6107905315437531D+0 - V=0.4657797469114178D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1135081039843524D+0 - B=0.3331954884662588D-1 - V=0.2733362800522836D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1612866626099378D+0 - B=0.7247167465436538D-1 - V=0.3235485368463559D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2100786550168205D+0 - B=0.1151539110849745D+0 - V=0.3624908726013453D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2592282009459942D+0 - B=0.1599491097143677D+0 - V=0.3925540070712828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3081740561320203D+0 - B=0.2058699956028027D+0 - V=0.4156129781116235D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3564289781578164D+0 - B=0.2521624953502911D+0 - V=0.4330644984623263D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4035587288240703D+0 - B=0.2982090785797674D+0 - V=0.4459677725921312D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4491671196373903D+0 - B=0.3434762087235733D+0 - V=0.4551593004456795D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4928854782917489D+0 - B=0.3874831357203437D+0 - V=0.4613341462749918D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5343646791958988D+0 - B=0.4297814821746926D+0 - V=0.4651019618269806D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5732683216530990D+0 - B=0.4699402260943537D+0 - V=0.4670249536100625D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2214131583218986D+0 - B=0.3873602040643895D-1 - V=0.3549555576441708D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2741796504750071D+0 - B=0.8089496256902013D-1 - V=0.3856108245249010D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3259797439149485D+0 - B=0.1251732177620872D+0 - V=0.4098622845756882D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3765441148826891D+0 - B=0.1706260286403185D+0 - V=0.4286328604268950D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4255773574530558D+0 - B=0.2165115147300408D+0 - V=0.4427802198993945D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4727795117058430D+0 - B=0.2622089812225259D+0 - V=0.4530473511488561D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5178546895819012D+0 - B=0.3071721431296201D+0 - V=0.4600805475703138D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5605141192097460D+0 - B=0.3508998998801138D+0 - V=0.4644599059958017D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6004763319352512D+0 - B=0.3929160876166931D+0 - V=0.4667274455712508D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3352842634946949D+0 - B=0.4202563457288019D-1 - V=0.4069360518020356D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3891971629814670D+0 - B=0.8614309758870850D-1 - V=0.4260442819919195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4409875565542281D+0 - B=0.1314500879380001D+0 - V=0.4408678508029063D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4904893058592484D+0 - B=0.1772189657383859D+0 - V=0.4518748115548597D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5375056138769549D+0 - B=0.2228277110050294D+0 - V=0.4595564875375116D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5818255708669969D+0 - B=0.2677179935014386D+0 - V=0.4643988774315846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6232334858144959D+0 - B=0.3113675035544165D+0 - V=0.4668827491646946D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4489485354492058D+0 - B=0.4409162378368174D-1 - V=0.4400541823741973D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5015136875933150D+0 - B=0.8939009917748489D-1 - V=0.4514512890193797D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5511300550512623D+0 - B=0.1351806029383365D+0 - V=0.4596198627347549D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5976720409858000D+0 - B=0.1808370355053196D+0 - V=0.4648659016801781D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6409956378989354D+0 - B=0.2257852192301602D+0 - V=0.4675502017157673D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5581222330827514D+0 - B=0.4532173421637160D-1 - V=0.4598494476455523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6074705984161695D+0 - B=0.9117488031840314D-1 - V=0.4654916955152048D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6532272537379033D+0 - B=0.1369294213140155D+0 - V=0.4684709779505137D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6594761494500487D+0 - B=0.4589901487275583D-1 - V=0.4691445539106986D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD2702(X,Y,Z,W,N) - DOUBLE PRECISION X(2702) - DOUBLE PRECISION Y(2702) - DOUBLE PRECISION Z(2702) - DOUBLE PRECISION W(2702) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 2702-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2998675149888161D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.4077860529495355D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2065562538818703D-1 - V=0.1185349192520667D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5250918173022379D-1 - V=0.1913408643425751D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8993480082038376D-1 - V=0.2452886577209897D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1306023924436019D+0 - V=0.2862408183288702D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1732060388531418D+0 - V=0.3178032258257357D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2168727084820249D+0 - V=0.3422945667633690D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2609528309173586D+0 - V=0.3612790520235922D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3049252927938952D+0 - V=0.3758638229818521D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3483484138084404D+0 - V=0.3868711798859953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3908321549106406D+0 - V=0.3949429933189938D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4320210071894814D+0 - V=0.4006068107541156D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4715824795890053D+0 - V=0.4043192149672723D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5091984794078453D+0 - V=0.4064947495808078D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5445580145650803D+0 - V=0.4075245619813152D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6072575796841768D+0 - V=0.4076423540893566D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6339484505755803D+0 - V=0.4074280862251555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6570718257486958D+0 - V=0.4074163756012244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6762557330090709D+0 - V=0.4077647795071246D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911161696923790D+0 - V=0.4084517552782530D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012841911659961D+0 - V=0.4092468459224052D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7064559272410020D+0 - V=0.4097872687240906D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6123554989894765D-1 - V=0.1738986811745028D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1533070348312393D+0 - V=0.2659616045280191D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2563902605244206D+0 - V=0.3240596008171533D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3629346991663361D+0 - V=0.3621195964432943D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4683949968987538D+0 - V=0.3868838330760539D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5694479240657952D+0 - V=0.4018911532693111D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6634465430993955D+0 - V=0.4089929432983252D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1033958573552305D+0 - B=0.3034544009063584D-1 - V=0.2279907527706409D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1473521412414395D+0 - B=0.6618803044247135D-1 - V=0.2715205490578897D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1924552158705967D+0 - B=0.1054431128987715D+0 - V=0.3057917896703976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2381094362890328D+0 - B=0.1468263551238858D+0 - V=0.3326913052452555D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838121707936760D+0 - B=0.1894486108187886D+0 - V=0.3537334711890037D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3291323133373415D+0 - B=0.2326374238761579D+0 - V=0.3700567500783129D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3736896978741460D+0 - B=0.2758485808485768D+0 - V=0.3825245372589122D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4171406040760013D+0 - B=0.3186179331996921D+0 - V=0.3918125171518296D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4591677985256915D+0 - B=0.3605329796303794D+0 - V=0.3984720419937579D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4994733831718418D+0 - B=0.4012147253586509D+0 - V=0.4029746003338211D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5377731830445096D+0 - B=0.4403050025570692D+0 - V=0.4057428632156627D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5737917830001331D+0 - B=0.4774565904277483D+0 - V=0.4071719274114857D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2027323586271389D+0 - B=0.3544122504976147D-1 - V=0.2990236950664119D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2516942375187273D+0 - B=0.7418304388646328D-1 - V=0.3262951734212878D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3000227995257181D+0 - B=0.1150502745727186D+0 - V=0.3482634608242413D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3474806691046342D+0 - B=0.1571963371209364D+0 - V=0.3656596681700892D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3938103180359209D+0 - B=0.1999631877247100D+0 - V=0.3791740467794218D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4387519590455703D+0 - B=0.2428073457846535D+0 - V=0.3894034450156905D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4820503960077787D+0 - B=0.2852575132906155D+0 - V=0.3968600245508371D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5234573778475101D+0 - B=0.3268884208674639D+0 - V=0.4019931351420050D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5627318647235282D+0 - B=0.3673033321675939D+0 - V=0.4052108801278599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5996390607156954D+0 - B=0.4061211551830290D+0 - V=0.4068978613940934D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3084780753791947D+0 - B=0.3860125523100059D-1 - V=0.3454275351319704D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3589988275920223D+0 - B=0.7928938987104867D-1 - V=0.3629963537007920D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4078628415881973D+0 - B=0.1212614643030087D+0 - V=0.3770187233889873D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4549287258889735D+0 - B=0.1638770827382693D+0 - V=0.3878608613694378D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5000278512957279D+0 - B=0.2065965798260176D+0 - V=0.3959065270221274D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5429785044928199D+0 - B=0.2489436378852235D+0 - V=0.4015286975463570D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5835939850491711D+0 - B=0.2904811368946891D+0 - V=0.4050866785614717D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6216870353444856D+0 - B=0.3307941957666609D+0 - V=0.4069320185051913D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4151104662709091D+0 - B=0.4064829146052554D-1 - V=0.3760120964062763D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4649804275009218D+0 - B=0.8258424547294755D-1 - V=0.3870969564418064D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5124695757009662D+0 - B=0.1251841962027289D+0 - V=0.3955287790534055D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5574711100606224D+0 - B=0.1679107505976331D+0 - V=0.4015361911302668D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5998597333287227D+0 - B=0.2102805057358715D+0 - V=0.4053836986719548D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6395007148516600D+0 - B=0.2518418087774107D+0 - V=0.4073578673299117D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5188456224746252D+0 - B=0.4194321676077518D-1 - V=0.3954628379231406D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5664190707942778D+0 - B=0.8457661551921499D-1 - V=0.4017645508847530D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6110464353283153D+0 - B=0.1273652932519396D+0 - V=0.4059030348651293D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6526430302051563D+0 - B=0.1698173239076354D+0 - V=0.4080565809484880D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6167551880377548D+0 - B=0.4266398851548864D-1 - V=0.4063018753664651D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6607195418355383D+0 - B=0.8551925814238349D-1 - V=0.4087191292799671D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3074(X,Y,Z,W,N) - DOUBLE PRECISION X(3074) - DOUBLE PRECISION Y(3074) - DOUBLE PRECISION Z(3074) - DOUBLE PRECISION W(3074) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3074-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2599095953754734D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3603134089687541D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3586067974412447D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1886108518723392D-1 - V=0.9831528474385880D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4800217244625303D-1 - V=0.1605023107954450D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8244922058397242D-1 - V=0.2072200131464099D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1200408362484023D+0 - V=0.2431297618814187D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1595773530809965D+0 - V=0.2711819064496707D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2002635973434064D+0 - V=0.2932762038321116D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2415127590139982D+0 - V=0.3107032514197368D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2828584158458477D+0 - V=0.3243808058921213D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3239091015338138D+0 - V=0.3349899091374030D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3643225097962194D+0 - V=0.3430580688505218D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4037897083691802D+0 - V=0.3490124109290343D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4420247515194127D+0 - V=0.3532148948561955D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4787572538464938D+0 - V=0.3559862669062833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5137265251275234D+0 - V=0.3576224317551411D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5466764056654611D+0 - V=0.3584050533086076D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6054859420813535D+0 - V=0.3584903581373224D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6308106701764562D+0 - V=0.3582991879040586D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6530369230179584D+0 - V=0.3582371187963125D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718609524611158D+0 - V=0.3584353631122350D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6869676499894013D+0 - V=0.3589120166517785D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6980467077240748D+0 - V=0.3595445704531601D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7048241721250522D+0 - V=0.3600943557111074D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5591105222058232D-1 - V=0.1456447096742039D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1407384078513916D+0 - V=0.2252370188283782D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2364035438976309D+0 - V=0.2766135443474897D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3360602737818170D+0 - V=0.3110729491500851D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4356292630054665D+0 - V=0.3342506712303391D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321569415256174D+0 - V=0.3491981834026860D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6232956305040554D+0 - V=0.3576003604348932D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9469870086838469D-1 - B=0.2778748387309470D-1 - V=0.1921921305788564D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1353170300568141D+0 - B=0.6076569878628364D-1 - V=0.2301458216495632D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1771679481726077D+0 - B=0.9703072762711040D-1 - V=0.2604248549522893D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2197066664231751D+0 - B=0.1354112458524762D+0 - V=0.2845275425870697D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2624783557374927D+0 - B=0.1750996479744100D+0 - V=0.3036870897974840D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3050969521214442D+0 - B=0.2154896907449802D+0 - V=0.3188414832298066D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3472252637196021D+0 - B=0.2560954625740152D+0 - V=0.3307046414722089D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3885610219026360D+0 - B=0.2965070050624096D+0 - V=0.3398330969031360D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4288273776062765D+0 - B=0.3363641488734497D+0 - V=0.3466757899705373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4677662471302948D+0 - B=0.3753400029836788D+0 - V=0.3516095923230054D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5051333589553359D+0 - B=0.4131297522144286D+0 - V=0.3549645184048486D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5406942145810492D+0 - B=0.4494423776081795D+0 - V=0.3570415969441392D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5742204122576457D+0 - B=0.4839938958841502D+0 - V=0.3581251798496118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1865407027225188D+0 - B=0.3259144851070796D-1 - V=0.2543491329913348D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2321186453689432D+0 - B=0.6835679505297343D-1 - V=0.2786711051330776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2773159142523882D+0 - B=0.1062284864451989D+0 - V=0.2985552361083679D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3219200192237254D+0 - B=0.1454404409323047D+0 - V=0.3145867929154039D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3657032593944029D+0 - B=0.1854018282582510D+0 - V=0.3273290662067609D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4084376778363622D+0 - B=0.2256297412014750D+0 - V=0.3372705511943501D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4499004945751427D+0 - B=0.2657104425000896D+0 - V=0.3448274437851510D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4898758141326335D+0 - B=0.3052755487631557D+0 - V=0.3503592783048583D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5281547442266309D+0 - B=0.3439863920645423D+0 - V=0.3541854792663162D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5645346989813992D+0 - B=0.3815229456121914D+0 - V=0.3565995517909428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5988181252159848D+0 - B=0.4175752420966734D+0 - V=0.3578802078302898D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2850425424471603D+0 - B=0.3562149509862536D-1 - V=0.2958644592860982D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3324619433027876D+0 - B=0.7330318886871096D-1 - V=0.3119548129116835D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3785848333076282D+0 - B=0.1123226296008472D+0 - V=0.3250745225005984D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4232891028562115D+0 - B=0.1521084193337708D+0 - V=0.3355153415935208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4664287050829722D+0 - B=0.1921844459223610D+0 - V=0.3435847568549328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5078458493735726D+0 - B=0.2321360989678303D+0 - V=0.3495786831622488D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5473779816204180D+0 - B=0.2715886486360520D+0 - V=0.3537767805534621D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5848617133811376D+0 - B=0.3101924707571355D+0 - V=0.3564459815421428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6201348281584888D+0 - B=0.3476121052890973D+0 - V=0.3578464061225468D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3852191185387871D+0 - B=0.3763224880035108D-1 - V=0.3239748762836212D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4325025061073423D+0 - B=0.7659581935637135D-1 - V=0.3345491784174287D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4778486229734490D+0 - B=0.1163381306083900D+0 - V=0.3429126177301782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5211663693009000D+0 - B=0.1563890598752899D+0 - V=0.3492420343097421D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5623469504853703D+0 - B=0.1963320810149200D+0 - V=0.3537399050235257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6012718188659246D+0 - B=0.2357847407258738D+0 - V=0.3566209152659172D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6378179206390117D+0 - B=0.2743846121244060D+0 - V=0.3581084321919782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4836936460214534D+0 - B=0.3895902610739024D-1 - V=0.3426522117591512D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5293792562683797D+0 - B=0.7871246819312640D-1 - V=0.3491848770121379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726281253100033D+0 - B=0.1187963808202981D+0 - V=0.3539318235231476D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6133658776169068D+0 - B=0.1587914708061787D+0 - V=0.3570231438458694D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6515085491865307D+0 - B=0.1983058575227646D+0 - V=0.3586207335051714D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5778692716064976D+0 - B=0.3977209689791542D-1 - V=0.3541196205164025D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6207904288086192D+0 - B=0.7990157592981152D-1 - V=0.3574296911573953D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6608688171046802D+0 - B=0.1199671308754309D+0 - V=0.3591993279818963D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6656263089489130D+0 - B=0.4015955957805969D-1 - V=0.3595855034661997D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3470(X,Y,Z,W,N) - DOUBLE PRECISION X(3470) - DOUBLE PRECISION Y(3470) - DOUBLE PRECISION Z(3470) - DOUBLE PRECISION W(3470) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3470-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.2040382730826330D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.3178149703889544D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1721420832906233D-1 - V=0.8288115128076110D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4408875374981770D-1 - V=0.1360883192522954D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7594680813878681D-1 - V=0.1766854454542662D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1108335359204799D+0 - V=0.2083153161230153D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1476517054388567D+0 - V=0.2333279544657158D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1856731870860615D+0 - V=0.2532809539930247D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2243634099428821D+0 - V=0.2692472184211158D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2633006881662727D+0 - V=0.2819949946811885D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3021340904916283D+0 - V=0.2920953593973030D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3405594048030089D+0 - V=0.2999889782948352D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3783044434007372D+0 - V=0.3060292120496902D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4151194767407910D+0 - V=0.3105109167522192D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4507705766443257D+0 - V=0.3136902387550312D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4850346056573187D+0 - V=0.3157984652454632D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5176950817792470D+0 - V=0.3170516518425422D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5485384240820989D+0 - V=0.3176568425633755D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6039117238943308D+0 - V=0.3177198411207062D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6279956655573113D+0 - V=0.3175519492394733D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6493636169568952D+0 - V=0.3174654952634756D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6677644117704504D+0 - V=0.3175676415467654D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6829368572115624D+0 - V=0.3178923417835410D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6946195818184121D+0 - V=0.3183788287531909D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7025711542057026D+0 - V=0.3188755151918807D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7066004767140119D+0 - V=0.3191916889313849D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5132537689946062D-1 - V=0.1231779611744508D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1297994661331225D+0 - V=0.1924661373839880D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2188852049401307D+0 - V=0.2380881867403424D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3123174824903457D+0 - V=0.2693100663037885D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4064037620738195D+0 - V=0.2908673382834366D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4984958396944782D+0 - V=0.3053914619381535D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5864975046021365D+0 - V=0.3143916684147777D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6686711634580175D+0 - V=0.3187042244055363D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8715738780835950D-1 - B=0.2557175233367578D-1 - V=0.1635219535869790D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1248383123134007D+0 - B=0.5604823383376681D-1 - V=0.1968109917696070D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1638062693383378D+0 - B=0.8968568601900765D-1 - V=0.2236754342249974D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2035586203373176D+0 - B=0.1254086651976279D+0 - V=0.2453186687017181D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2436798975293774D+0 - B=0.1624780150162012D+0 - V=0.2627551791580541D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838207507773806D+0 - B=0.2003422342683208D+0 - V=0.2767654860152220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3236787502217692D+0 - B=0.2385628026255263D+0 - V=0.2879467027765895D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3629849554840691D+0 - B=0.2767731148783578D+0 - V=0.2967639918918702D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4014948081992087D+0 - B=0.3146542308245309D+0 - V=0.3035900684660351D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4389818379260225D+0 - B=0.3519196415895088D+0 - V=0.3087338237298308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4752331143674377D+0 - B=0.3883050984023654D+0 - V=0.3124608838860167D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5100457318374018D+0 - B=0.4235613423908649D+0 - V=0.3150084294226743D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5432238388954868D+0 - B=0.4574484717196220D+0 - V=0.3165958398598402D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5745758685072442D+0 - B=0.4897311639255524D+0 - V=0.3174320440957372D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1723981437592809D+0 - B=0.3010630597881105D-1 - V=0.2182188909812599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2149553257844597D+0 - B=0.6326031554204694D-1 - V=0.2399727933921445D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2573256081247422D+0 - B=0.9848566980258631D-1 - V=0.2579796133514652D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2993163751238106D+0 - B=0.1350835952384266D+0 - V=0.2727114052623535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3407238005148000D+0 - B=0.1725184055442181D+0 - V=0.2846327656281355D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3813454978483264D+0 - B=0.2103559279730725D+0 - V=0.2941491102051334D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4209848104423343D+0 - B=0.2482278774554860D+0 - V=0.3016049492136107D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4594519699996300D+0 - B=0.2858099509982883D+0 - V=0.3072949726175648D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4965640166185930D+0 - B=0.3228075659915428D+0 - V=0.3114768142886460D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321441655571562D+0 - B=0.3589459907204151D+0 - V=0.3143823673666223D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5660208438582166D+0 - B=0.3939630088864310D+0 - V=0.3162269764661535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5980264315964364D+0 - B=0.4276029922949089D+0 - V=0.3172164663759821D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2644215852350733D+0 - B=0.3300939429072552D-1 - V=0.2554575398967435D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3090113743443063D+0 - B=0.6803887650078501D-1 - V=0.2701704069135677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3525871079197808D+0 - B=0.1044326136206709D+0 - V=0.2823693413468940D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3950418005354029D+0 - B=0.1416751597517679D+0 - V=0.2922898463214289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4362475663430163D+0 - B=0.1793408610504821D+0 - V=0.3001829062162428D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4760661812145854D+0 - B=0.2170630750175722D+0 - V=0.3062890864542953D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5143551042512103D+0 - B=0.2545145157815807D+0 - V=0.3108328279264746D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5509709026935597D+0 - B=0.2913940101706601D+0 - V=0.3140243146201245D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5857711030329428D+0 - B=0.3274169910910705D+0 - V=0.3160638030977130D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6186149917404392D+0 - B=0.3623081329317265D+0 - V=0.3171462882206275D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3586894569557064D+0 - B=0.3497354386450040D-1 - V=0.2812388416031796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4035266610019441D+0 - B=0.7129736739757095D-1 - V=0.2912137500288045D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4467775312332510D+0 - B=0.1084758620193165D+0 - V=0.2993241256502206D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4883638346608543D+0 - B=0.1460915689241772D+0 - V=0.3057101738983822D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5281908348434601D+0 - B=0.1837790832369980D+0 - V=0.3105319326251432D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5661542687149311D+0 - B=0.2212075390874021D+0 - V=0.3139565514428167D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6021450102031452D+0 - B=0.2580682841160985D+0 - V=0.3161543006806366D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6360520783610050D+0 - B=0.2940656362094121D+0 - V=0.3172985960613294D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4521611065087196D+0 - B=0.3631055365867002D-1 - V=0.2989400336901431D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4959365651560963D+0 - B=0.7348318468484350D-1 - V=0.3054555883947677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5376815804038283D+0 - B=0.1111087643812648D+0 - V=0.3104764960807702D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5773314480243768D+0 - B=0.1488226085145408D+0 - V=0.3141015825977616D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6148113245575056D+0 - B=0.1862892274135151D+0 - V=0.3164520621159896D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6500407462842380D+0 - B=0.2231909701714456D+0 - V=0.3176652305912204D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5425151448707213D+0 - B=0.3718201306118944D-1 - V=0.3105097161023939D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5841860556907931D+0 - B=0.7483616335067346D-1 - V=0.3143014117890550D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6234632186851500D+0 - B=0.1125990834266120D+0 - V=0.3168172866287200D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6602934551848843D+0 - B=0.1501303813157619D+0 - V=0.3181401865570968D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6278573968375105D+0 - B=0.3767559930245720D-1 - V=0.3170663659156037D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6665611711264577D+0 - B=0.7548443301360158D-1 - V=0.3185447944625510D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD3890(X,Y,Z,W,N) - DOUBLE PRECISION X(3890) - DOUBLE PRECISION Y(3890) - DOUBLE PRECISION Z(3890) - DOUBLE PRECISION W(3890) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 3890-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1807395252196920D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2848008782238827D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2836065837530581D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1587876419858352D-1 - V=0.7013149266673816D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4069193593751206D-1 - V=0.1162798021956766D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7025888115257997D-1 - V=0.1518728583972105D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1027495450028704D+0 - V=0.1798796108216934D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1371457730893426D+0 - V=0.2022593385972785D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1727758532671953D+0 - V=0.2203093105575464D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2091492038929037D+0 - V=0.2349294234299855D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2458813281751915D+0 - V=0.2467682058747003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2826545859450066D+0 - V=0.2563092683572224D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3191957291799622D+0 - V=0.2639253896763318D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3552621469299578D+0 - V=0.2699137479265108D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3906329503406230D+0 - V=0.2745196420166739D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4251028614093031D+0 - V=0.2779529197397593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4584777520111870D+0 - V=0.2803996086684265D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4905711358710193D+0 - V=0.2820302356715842D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5212011669847385D+0 - V=0.2830056747491068D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5501878488737995D+0 - V=0.2834808950776839D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6025037877479342D+0 - V=0.2835282339078929D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6254572689549016D+0 - V=0.2833819267065800D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6460107179528248D+0 - V=0.2832858336906784D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6639541138154251D+0 - V=0.2833268235451244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6790688515667495D+0 - V=0.2835432677029253D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911338580371512D+0 - V=0.2839091722743049D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6999385956126490D+0 - V=0.2843308178875841D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7053037748656896D+0 - V=0.2846703550533846D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4732224387180115D-1 - V=0.1051193406971900D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1202100529326803D+0 - V=0.1657871838796974D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2034304820664855D+0 - V=0.2064648113714232D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2912285643573002D+0 - V=0.2347942745819741D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3802361792726768D+0 - V=0.2547775326597726D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4680598511056146D+0 - V=0.2686876684847025D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5528151052155599D+0 - V=0.2778665755515867D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6329386307803041D+0 - V=0.2830996616782929D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8056516651369069D-1 - B=0.2363454684003124D-1 - V=0.1403063340168372D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1156476077139389D+0 - B=0.5191291632545936D-1 - V=0.1696504125939477D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1520473382760421D+0 - B=0.8322715736994519D-1 - V=0.1935787242745390D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1892986699745931D+0 - B=0.1165855667993712D+0 - V=0.2130614510521968D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2270194446777792D+0 - B=0.1513077167409504D+0 - V=0.2289381265931048D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2648908185093273D+0 - B=0.1868882025807859D+0 - V=0.2418630292816186D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3026389259574136D+0 - B=0.2229277629776224D+0 - V=0.2523400495631193D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3400220296151384D+0 - B=0.2590951840746235D+0 - V=0.2607623973449605D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3768217953335510D+0 - B=0.2951047291750847D+0 - V=0.2674441032689209D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4128372900921884D+0 - B=0.3307019714169930D+0 - V=0.2726432360343356D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4478807131815630D+0 - B=0.3656544101087634D+0 - V=0.2765787685924545D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4817742034089257D+0 - B=0.3997448951939695D+0 - V=0.2794428690642224D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5143472814653344D+0 - B=0.4327667110812024D+0 - V=0.2814099002062895D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5454346213905650D+0 - B=0.4645196123532293D+0 - V=0.2826429531578994D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5748739313170252D+0 - B=0.4948063555703345D+0 - V=0.2832983542550884D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1599598738286342D+0 - B=0.2792357590048985D-1 - V=0.1886695565284976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1998097412500951D+0 - B=0.5877141038139065D-1 - V=0.2081867882748234D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2396228952566202D+0 - B=0.9164573914691377D-1 - V=0.2245148680600796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2792228341097746D+0 - B=0.1259049641962687D+0 - V=0.2380370491511872D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3184251107546741D+0 - B=0.1610594823400863D+0 - V=0.2491398041852455D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3570481164426244D+0 - B=0.1967151653460898D+0 - V=0.2581632405881230D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3949164710492144D+0 - B=0.2325404606175168D+0 - V=0.2653965506227417D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318617293970503D+0 - B=0.2682461141151439D+0 - V=0.2710857216747087D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4677221009931678D+0 - B=0.3035720116011973D+0 - V=0.2754434093903659D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5023417939270955D+0 - B=0.3382781859197439D+0 - V=0.2786579932519380D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5355701836636128D+0 - B=0.3721383065625942D+0 - V=0.2809011080679474D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5672608451328771D+0 - B=0.4049346360466055D+0 - V=0.2823336184560987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5972704202540162D+0 - B=0.4364538098633802D+0 - V=0.2831101175806309D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2461687022333596D+0 - B=0.3070423166833368D-1 - V=0.2221679970354546D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2881774566286831D+0 - B=0.6338034669281885D-1 - V=0.2356185734270703D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3293963604116978D+0 - B=0.9742862487067941D-1 - V=0.2469228344805590D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3697303822241377D+0 - B=0.1323799532282290D+0 - V=0.2562726348642046D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4090663023135127D+0 - B=0.1678497018129336D+0 - V=0.2638756726753028D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4472819355411712D+0 - B=0.2035095105326114D+0 - V=0.2699311157390862D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4842513377231437D+0 - B=0.2390692566672091D+0 - V=0.2746233268403837D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5198477629962928D+0 - B=0.2742649818076149D+0 - V=0.2781225674454771D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5539453011883145D+0 - B=0.3088503806580094D+0 - V=0.2805881254045684D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5864196762401251D+0 - B=0.3425904245906614D+0 - V=0.2821719877004913D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6171484466668390D+0 - B=0.3752562294789468D+0 - V=0.2830222502333124D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3350337830565727D+0 - B=0.3261589934634747D-1 - V=0.2457995956744870D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3775773224758284D+0 - B=0.6658438928081572D-1 - V=0.2551474407503706D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4188155229848973D+0 - B=0.1014565797157954D+0 - V=0.2629065335195311D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4586805892009344D+0 - B=0.1368573320843822D+0 - V=0.2691900449925075D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4970895714224235D+0 - B=0.1724614851951608D+0 - V=0.2741275485754276D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5339505133960747D+0 - B=0.2079779381416412D+0 - V=0.2778530970122595D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5691665792531440D+0 - B=0.2431385788322288D+0 - V=0.2805010567646741D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6026387682680377D+0 - B=0.2776901883049853D+0 - V=0.2822055834031040D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6342676150163307D+0 - B=0.3113881356386632D+0 - V=0.2831016901243473D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4237951119537067D+0 - B=0.3394877848664351D-1 - V=0.2624474901131803D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4656918683234929D+0 - B=0.6880219556291447D-1 - V=0.2688034163039377D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5058857069185980D+0 - B=0.1041946859721635D+0 - V=0.2738932751287636D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5443204666713996D+0 - B=0.1398039738736393D+0 - V=0.2777944791242523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5809298813759742D+0 - B=0.1753373381196155D+0 - V=0.2806011661660987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6156416039447128D+0 - B=0.2105215793514010D+0 - V=0.2824181456597460D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6483801351066604D+0 - B=0.2450953312157051D+0 - V=0.2833585216577828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5103616577251688D+0 - B=0.3485560643800719D-1 - V=0.2738165236962878D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5506738792580681D+0 - B=0.7026308631512033D-1 - V=0.2778365208203180D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5889573040995292D+0 - B=0.1059035061296403D+0 - V=0.2807852940418966D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6251641589516930D+0 - B=0.1414823925236026D+0 - V=0.2827245949674705D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6592414921570178D+0 - B=0.1767207908214530D+0 - V=0.2837342344829828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5930314017533384D+0 - B=0.3542189339561672D-1 - V=0.2809233907610981D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6309812253390175D+0 - B=0.7109574040369549D-1 - V=0.2829930809742694D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6666296011353230D+0 - B=0.1067259792282730D+0 - V=0.2841097874111479D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6703715271049922D+0 - B=0.3569455268820809D-1 - V=0.2843455206008783D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD4334(X,Y,Z,W,N) - DOUBLE PRECISION X(4334) - DOUBLE PRECISION Y(4334) - DOUBLE PRECISION Z(4334) - DOUBLE PRECISION W(4334) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 4334-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.1449063022537883D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2546377329828424D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1462896151831013D-1 - V=0.6018432961087496D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3769840812493139D-1 - V=0.1002286583263673D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6524701904096891D-1 - V=0.1315222931028093D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9560543416134648D-1 - V=0.1564213746876724D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1278335898929198D+0 - V=0.1765118841507736D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1613096104466031D+0 - V=0.1928737099311080D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1955806225745371D+0 - V=0.2062658534263270D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2302935218498028D+0 - V=0.2172395445953787D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2651584344113027D+0 - V=0.2262076188876047D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2999276825183209D+0 - V=0.2334885699462397D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3343828669718798D+0 - V=0.2393355273179203D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3683265013750518D+0 - V=0.2439559200468863D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4015763206518108D+0 - V=0.2475251866060002D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4339612026399770D+0 - V=0.2501965558158773D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4653180651114582D+0 - V=0.2521081407925925D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4954893331080803D+0 - V=0.2533881002388081D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5243207068924930D+0 - V=0.2541582900848261D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5516590479041704D+0 - V=0.2545365737525860D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6012371927804176D+0 - V=0.2545726993066799D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6231574466449819D+0 - V=0.2544456197465555D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6429416514181271D+0 - V=0.2543481596881064D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6604124272943595D+0 - V=0.2543506451429194D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6753851470408250D+0 - V=0.2544905675493763D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6876717970626160D+0 - V=0.2547611407344429D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6970895061319234D+0 - V=0.2551060375448869D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7034746912553310D+0 - V=0.2554291933816039D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7067017217542295D+0 - V=0.2556255710686343D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4382223501131123D-1 - V=0.9041339695118195D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1117474077400006D+0 - V=0.1438426330079022D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1897153252911440D+0 - V=0.1802523089820518D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2724023009910331D+0 - V=0.2060052290565496D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3567163308709902D+0 - V=0.2245002248967466D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4404784483028087D+0 - V=0.2377059847731150D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5219833154161411D+0 - V=0.2468118955882525D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5998179868977553D+0 - V=0.2525410872966528D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6727803154548222D+0 - V=0.2553101409933397D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7476563943166086D-1 - B=0.2193168509461185D-1 - V=0.1212879733668632D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1075341482001416D+0 - B=0.4826419281533887D-1 - V=0.1472872881270931D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1416344885203259D+0 - B=0.7751191883575742D-1 - V=0.1686846601010828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1766325315388586D+0 - B=0.1087558139247680D+0 - V=0.1862698414660208D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2121744174481514D+0 - B=0.1413661374253096D+0 - V=0.2007430956991861D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2479669443408145D+0 - B=0.1748768214258880D+0 - V=0.2126568125394796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2837600452294113D+0 - B=0.2089216406612073D+0 - V=0.2224394603372113D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3193344933193984D+0 - B=0.2431987685545972D+0 - V=0.2304264522673135D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3544935442438745D+0 - B=0.2774497054377770D+0 - V=0.2368854288424087D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3890571932288154D+0 - B=0.3114460356156915D+0 - V=0.2420352089461772D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4228581214259090D+0 - B=0.3449806851913012D+0 - V=0.2460597113081295D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4557387211304052D+0 - B=0.3778618641248256D+0 - V=0.2491181912257687D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4875487950541643D+0 - B=0.4099086391698978D+0 - V=0.2513528194205857D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5181436529962997D+0 - B=0.4409474925853973D+0 - V=0.2528943096693220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5473824095600661D+0 - B=0.4708094517711291D+0 - V=0.2538660368488136D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5751263398976174D+0 - B=0.4993275140354637D+0 - V=0.2543868648299022D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1489515746840028D+0 - B=0.2599381993267017D-1 - V=0.1642595537825183D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1863656444351767D+0 - B=0.5479286532462190D-1 - V=0.1818246659849308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2238602880356348D+0 - B=0.8556763251425254D-1 - V=0.1966565649492420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2612723375728160D+0 - B=0.1177257802267011D+0 - V=0.2090677905657991D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2984332990206190D+0 - B=0.1508168456192700D+0 - V=0.2193820409510504D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3351786584663333D+0 - B=0.1844801892177727D+0 - V=0.2278870827661928D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3713505522209120D+0 - B=0.2184145236087598D+0 - V=0.2348283192282090D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4067981098954663D+0 - B=0.2523590641486229D+0 - V=0.2404139755581477D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4413769993687534D+0 - B=0.2860812976901373D+0 - V=0.2448227407760734D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4749487182516394D+0 - B=0.3193686757808996D+0 - V=0.2482110455592573D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5073798105075426D+0 - B=0.3520226949547602D+0 - V=0.2507192397774103D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5385410448878654D+0 - B=0.3838544395667890D+0 - V=0.2524765968534880D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5683065353670530D+0 - B=0.4146810037640963D+0 - V=0.2536052388539425D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5965527620663510D+0 - B=0.4443224094681121D+0 - V=0.2542230588033068D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2299227700856157D+0 - B=0.2865757664057584D-1 - V=0.1944817013047896D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2695752998553267D+0 - B=0.5923421684485993D-1 - V=0.2067862362746635D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3086178716611389D+0 - B=0.9117817776057715D-1 - V=0.2172440734649114D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3469649871659077D+0 - B=0.1240593814082605D+0 - V=0.2260125991723423D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3845153566319655D+0 - B=0.1575272058259175D+0 - V=0.2332655008689523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4211600033403215D+0 - B=0.1912845163525413D+0 - V=0.2391699681532458D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4567867834329882D+0 - B=0.2250710177858171D+0 - V=0.2438801528273928D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4912829319232061D+0 - B=0.2586521303440910D+0 - V=0.2475370504260665D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5245364793303812D+0 - B=0.2918112242865407D+0 - V=0.2502707235640574D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5564369788915756D+0 - B=0.3243439239067890D+0 - V=0.2522031701054241D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5868757697775287D+0 - B=0.3560536787835351D+0 - V=0.2534511269978784D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6157458853519617D+0 - B=0.3867480821242581D+0 - V=0.2541284914955151D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3138461110672113D+0 - B=0.3051374637507278D-1 - V=0.2161509250688394D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3542495872050569D+0 - B=0.6237111233730755D-1 - V=0.2248778513437852D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3935751553120181D+0 - B=0.9516223952401907D-1 - V=0.2322388803404617D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4317634668111147D+0 - B=0.1285467341508517D+0 - V=0.2383265471001355D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4687413842250821D+0 - B=0.1622318931656033D+0 - V=0.2432476675019525D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5044274237060283D+0 - B=0.1959581153836453D+0 - V=0.2471122223750674D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5387354077925727D+0 - B=0.2294888081183837D+0 - V=0.2500291752486870D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5715768898356105D+0 - B=0.2626031152713945D+0 - V=0.2521055942764682D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6028627200136111D+0 - B=0.2950904075286713D+0 - V=0.2534472785575503D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6325039812653463D+0 - B=0.3267458451113286D+0 - V=0.2541599713080121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3981986708423407D+0 - B=0.3183291458749821D-1 - V=0.2317380975862936D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4382791182133300D+0 - B=0.6459548193880908D-1 - V=0.2378550733719775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4769233057218166D+0 - B=0.9795757037087952D-1 - V=0.2428884456739118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5140823911194238D+0 - B=0.1316307235126655D+0 - V=0.2469002655757292D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5496977833862983D+0 - B=0.1653556486358704D+0 - V=0.2499657574265851D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5837047306512727D+0 - B=0.1988931724126510D+0 - V=0.2521676168486082D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6160349566926879D+0 - B=0.2320174581438950D+0 - V=0.2535935662645334D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6466185353209440D+0 - B=0.2645106562168662D+0 - V=0.2543356743363214D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4810835158795404D+0 - B=0.3275917807743992D-1 - V=0.2427353285201535D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5199925041324341D+0 - B=0.6612546183967181D-1 - V=0.2468258039744386D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5571717692207494D+0 - B=0.9981498331474143D-1 - V=0.2500060956440310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5925789250836378D+0 - B=0.1335687001410374D+0 - V=0.2523238365420979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6261658523859670D+0 - B=0.1671444402896463D+0 - V=0.2538399260252846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6578811126669331D+0 - B=0.2003106382156076D+0 - V=0.2546255927268069D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5609624612998100D+0 - B=0.3337500940231335D-1 - V=0.2500583360048449D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5979959659984670D+0 - B=0.6708750335901803D-1 - V=0.2524777638260203D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6330523711054002D+0 - B=0.1008792126424850D+0 - V=0.2540951193860656D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6660960998103972D+0 - B=0.1345050343171794D+0 - V=0.2549524085027472D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6365384364585819D+0 - B=0.3372799460737052D-1 - V=0.2542569507009158D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6710994302899275D+0 - B=0.6755249309678028D-1 - V=0.2552114127580376D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD4802(X,Y,Z,W,N) - DOUBLE PRECISION X(4802) - DOUBLE PRECISION Y(4802) - DOUBLE PRECISION Z(4802) - DOUBLE PRECISION W(4802) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 4802-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9687521879420705D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2307897895367918D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2297310852498558D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2335728608887064D-1 - V=0.7386265944001919D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4352987836550653D-1 - V=0.8257977698542210D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6439200521088801D-1 - V=0.9706044762057630D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9003943631993181D-1 - V=0.1302393847117003D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1196706615548473D+0 - V=0.1541957004600968D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1511715412838134D+0 - V=0.1704459770092199D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1835982828503801D+0 - V=0.1827374890942906D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2165081259155405D+0 - V=0.1926360817436107D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2496208720417563D+0 - V=0.2008010239494833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2827200673567900D+0 - V=0.2075635983209175D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3156190823994346D+0 - V=0.2131306638690909D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3481476793749115D+0 - V=0.2176562329937335D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3801466086947226D+0 - V=0.2212682262991018D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4114652119634011D+0 - V=0.2240799515668565D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4419598786519751D+0 - V=0.2261959816187525D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4714925949329543D+0 - V=0.2277156368808855D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4999293972879466D+0 - V=0.2287351772128336D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5271387221431248D+0 - V=0.2293490814084085D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5529896780837761D+0 - V=0.2296505312376273D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6000856099481712D+0 - V=0.2296793832318756D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6210562192785175D+0 - V=0.2295785443842974D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6401165879934240D+0 - V=0.2295017931529102D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6571144029244334D+0 - V=0.2295059638184868D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6718910821718863D+0 - V=0.2296232343237362D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6842845591099010D+0 - V=0.2298530178740771D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6941353476269816D+0 - V=0.2301579790280501D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7012965242212991D+0 - V=0.2304690404996513D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7056471428242644D+0 - V=0.2307027995907102D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4595557643585895D-1 - V=0.9312274696671092D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1049316742435023D+0 - V=0.1199919385876926D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1773548879549274D+0 - V=0.1598039138877690D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2559071411236127D+0 - V=0.1822253763574900D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3358156837985898D+0 - V=0.1988579593655040D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4155835743763893D+0 - V=0.2112620102533307D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4937894296167472D+0 - V=0.2201594887699007D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5691569694793316D+0 - V=0.2261622590895036D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6405840854894251D+0 - V=0.2296458453435705D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7345133894143348D-1 - B=0.2177844081486067D-1 - V=0.1006006990267000D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1009859834044931D+0 - B=0.4590362185775188D-1 - V=0.1227676689635876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1324289619748758D+0 - B=0.7255063095690877D-1 - V=0.1467864280270117D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1654272109607127D+0 - B=0.1017825451960684D+0 - V=0.1644178912101232D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1990767186776461D+0 - B=0.1325652320980364D+0 - V=0.1777664890718961D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2330125945523278D+0 - B=0.1642765374496765D+0 - V=0.1884825664516690D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2670080611108287D+0 - B=0.1965360374337889D+0 - V=0.1973269246453848D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3008753376294316D+0 - B=0.2290726770542238D+0 - V=0.2046767775855328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3344475596167860D+0 - B=0.2616645495370823D+0 - V=0.2107600125918040D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3675709724070786D+0 - B=0.2941150728843141D+0 - V=0.2157416362266829D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4001000887587812D+0 - B=0.3262440400919066D+0 - V=0.2197557816920721D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318956350436028D+0 - B=0.3578835350611916D+0 - V=0.2229192611835437D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4628239056795531D+0 - B=0.3888751854043678D+0 - V=0.2253385110212775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4927563229773636D+0 - B=0.4190678003222840D+0 - V=0.2271137107548774D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5215687136707969D+0 - B=0.4483151836883852D+0 - V=0.2283414092917525D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5491402346984905D+0 - B=0.4764740676087880D+0 - V=0.2291161673130077D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5753520160126075D+0 - B=0.5034021310998277D+0 - V=0.2295313908576598D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1388326356417754D+0 - B=0.2435436510372806D-1 - V=0.1438204721359031D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1743686900537244D+0 - B=0.5118897057342652D-1 - V=0.1607738025495257D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2099737037950268D+0 - B=0.8014695048539634D-1 - V=0.1741483853528379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2454492590908548D+0 - B=0.1105117874155699D+0 - V=0.1851918467519151D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2807219257864278D+0 - B=0.1417950531570966D+0 - V=0.1944628638070613D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3156842271975842D+0 - B=0.1736604945719597D+0 - V=0.2022495446275152D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3502090945177752D+0 - B=0.2058466324693981D+0 - V=0.2087462382438514D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3841684849519686D+0 - B=0.2381284261195919D+0 - V=0.2141074754818308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4174372367906016D+0 - B=0.2703031270422569D+0 - V=0.2184640913748162D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4498926465011892D+0 - B=0.3021845683091309D+0 - V=0.2219309165220329D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4814146229807701D+0 - B=0.3335993355165720D+0 - V=0.2246123118340624D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5118863625734701D+0 - B=0.3643833735518232D+0 - V=0.2266062766915125D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5411947455119144D+0 - B=0.3943789541958179D+0 - V=0.2280072952230796D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5692301500357246D+0 - B=0.4234320144403542D+0 - V=0.2289082025202583D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5958857204139576D+0 - B=0.4513897947419260D+0 - V=0.2294012695120025D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2156270284785766D+0 - B=0.2681225755444491D-1 - V=0.1722434488736947D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2532385054909710D+0 - B=0.5557495747805614D-1 - V=0.1830237421455091D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2902564617771537D+0 - B=0.8569368062950249D-1 - V=0.1923855349997633D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3266979823143256D+0 - B=0.1167367450324135D+0 - V=0.2004067861936271D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3625039627493614D+0 - B=0.1483861994003304D+0 - V=0.2071817297354263D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3975838937548699D+0 - B=0.1803821503011405D+0 - V=0.2128250834102103D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4318396099009774D+0 - B=0.2124962965666424D+0 - V=0.2174513719440102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4651706555732742D+0 - B=0.2445221837805913D+0 - V=0.2211661839150214D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4974752649620969D+0 - B=0.2762701224322987D+0 - V=0.2240665257813102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5286517579627517D+0 - B=0.3075627775211328D+0 - V=0.2262439516632620D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5586001195731895D+0 - B=0.3382311089826877D+0 - V=0.2277874557231869D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5872229902021319D+0 - B=0.3681108834741399D+0 - V=0.2287854314454994D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6144258616235123D+0 - B=0.3970397446872839D+0 - V=0.2293268499615575D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2951676508064861D+0 - B=0.2867499538750441D-1 - V=0.1912628201529828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3335085485472725D+0 - B=0.5867879341903510D-1 - V=0.1992499672238701D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3709561760636381D+0 - B=0.8961099205022284D-1 - V=0.2061275533454027D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4074722861667498D+0 - B=0.1211627927626297D+0 - V=0.2119318215968572D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4429923648839117D+0 - B=0.1530748903554898D+0 - V=0.2167416581882652D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4774428052721736D+0 - B=0.1851176436721877D+0 - V=0.2206430730516600D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5107446539535904D+0 - B=0.2170829107658179D+0 - V=0.2237186938699523D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5428151370542935D+0 - B=0.2487786689026271D+0 - V=0.2260480075032884D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5735699292556964D+0 - B=0.2800239952795016D+0 - V=0.2277098884558542D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6029253794562866D+0 - B=0.3106445702878119D+0 - V=0.2287845715109671D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6307998987073145D+0 - B=0.3404689500841194D+0 - V=0.2293547268236294D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3752652273692719D+0 - B=0.2997145098184479D-1 - V=0.2056073839852528D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4135383879344028D+0 - B=0.6086725898678011D-1 - V=0.2114235865831876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4506113885153907D+0 - B=0.9238849548435643D-1 - V=0.2163175629770551D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4864401554606072D+0 - B=0.1242786603851851D+0 - V=0.2203392158111650D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5209708076611709D+0 - B=0.1563086731483386D+0 - V=0.2235473176847839D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5541422135830122D+0 - B=0.1882696509388506D+0 - V=0.2260024141501235D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5858880915113817D+0 - B=0.2199672979126059D+0 - V=0.2277675929329182D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6161399390603444D+0 - B=0.2512165482924867D+0 - V=0.2289102112284834D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6448296482255090D+0 - B=0.2818368701871888D+0 - V=0.2295027954625118D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4544796274917948D+0 - B=0.3088970405060312D-1 - V=0.2161281589879992D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4919389072146628D+0 - B=0.6240947677636835D-1 - V=0.2201980477395102D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5279313026985183D+0 - B=0.9430706144280313D-1 - V=0.2234952066593166D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5624169925571135D+0 - B=0.1263547818770374D+0 - V=0.2260540098520838D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5953484627093287D+0 - B=0.1583430788822594D+0 - V=0.2279157981899988D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6266730715339185D+0 - B=0.1900748462555988D+0 - V=0.2291296918565571D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6563363204278871D+0 - B=0.2213599519592567D+0 - V=0.2297533752536649D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5314574716585696D+0 - B=0.3152508811515374D-1 - V=0.2234927356465995D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5674614932298185D+0 - B=0.6343865291465561D-1 - V=0.2261288012985219D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6017706004970264D+0 - B=0.9551503504223951D-1 - V=0.2280818160923688D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6343471270264178D+0 - B=0.1275440099801196D+0 - V=0.2293773295180159D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6651494599127802D+0 - B=0.1593252037671960D+0 - V=0.2300528767338634D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6050184986005704D+0 - B=0.3192538338496105D-1 - V=0.2281893855065666D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6390163550880400D+0 - B=0.6402824353962306D-1 - V=0.2295720444840727D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6711199107088448D+0 - B=0.9609805077002909D-1 - V=0.2303227649026753D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6741354429572275D+0 - B=0.3211853196273233D-1 - V=0.2304831913227114D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD5294(X,Y,Z,W,N) - DOUBLE PRECISION X(5294) - DOUBLE PRECISION Y(5294) - DOUBLE PRECISION Z(5294) - DOUBLE PRECISION W(5294) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 5294-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9080510764308163D-4 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.2084824361987793D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2303261686261450D-1 - V=0.5011105657239616D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3757208620162394D-1 - V=0.5942520409683854D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5821912033821852D-1 - V=0.9564394826109721D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8403127529194872D-1 - V=0.1185530657126338D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1122927798060578D+0 - V=0.1364510114230331D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1420125319192987D+0 - V=0.1505828825605415D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1726396437341978D+0 - V=0.1619298749867023D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2038170058115696D+0 - V=0.1712450504267789D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2352849892876508D+0 - V=0.1789891098164999D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2668363354312461D+0 - V=0.1854474955629795D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2982941279900452D+0 - V=0.1908148636673661D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3295002922087076D+0 - V=0.1952377405281833D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3603094918363593D+0 - V=0.1988349254282232D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3905857895173920D+0 - V=0.2017079807160050D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4202005758160837D+0 - V=0.2039473082709094D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4490310061597227D+0 - V=0.2056360279288953D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4769586160311491D+0 - V=0.2068525823066865D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5038679887049750D+0 - V=0.2076724877534488D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5296454286519961D+0 - V=0.2081694278237885D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5541776207164850D+0 - V=0.2084157631219326D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5990467321921213D+0 - V=0.2084381531128593D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6191467096294587D+0 - V=0.2083476277129307D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6375251212901849D+0 - V=0.2082686194459732D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6540514381131168D+0 - V=0.2082475686112415D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6685899064391510D+0 - V=0.2083139860289915D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6810013009681648D+0 - V=0.2084745561831237D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6911469578730340D+0 - V=0.2087091313375890D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6988956915141736D+0 - V=0.2089718413297697D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7041335794868720D+0 - V=0.2092003303479793D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7067754398018567D+0 - V=0.2093336148263241D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3840368707853623D-1 - V=0.7591708117365267D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9835485954117399D-1 - V=0.1083383968169186D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1665774947612998D+0 - V=0.1403019395292510D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2405702335362910D+0 - V=0.1615970179286436D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3165270770189046D+0 - V=0.1771144187504911D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3927386145645443D+0 - V=0.1887760022988168D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4678825918374656D+0 - V=0.1973474670768214D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5408022024266935D+0 - V=0.2033787661234659D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6104967445752438D+0 - V=0.2072343626517331D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6760910702685738D+0 - V=0.2091177834226918D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6655644120217392D-1 - B=0.1936508874588424D-1 - V=0.9316684484675566D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9446246161270182D-1 - B=0.4252442002115869D-1 - V=0.1116193688682976D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1242651925452509D+0 - B=0.6806529315354374D-1 - V=0.1298623551559414D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1553438064846751D+0 - B=0.9560957491205369D-1 - V=0.1450236832456426D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1871137110542670D+0 - B=0.1245931657452888D+0 - V=0.1572719958149914D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2192612628836257D+0 - B=0.1545385828778978D+0 - V=0.1673234785867195D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2515682807206955D+0 - B=0.1851004249723368D+0 - V=0.1756860118725188D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2838535866287290D+0 - B=0.2160182608272384D+0 - V=0.1826776290439367D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3159578817528521D+0 - B=0.2470799012277111D+0 - V=0.1885116347992865D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3477370882791392D+0 - B=0.2781014208986402D+0 - V=0.1933457860170574D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3790576960890540D+0 - B=0.3089172523515731D+0 - V=0.1973060671902064D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4097938317810200D+0 - B=0.3393750055472244D+0 - V=0.2004987099616311D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4398256572859637D+0 - B=0.3693322470987730D+0 - V=0.2030170909281499D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4690384114718480D+0 - B=0.3986541005609877D+0 - V=0.2049461460119080D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4973216048301053D+0 - B=0.4272112491408562D+0 - V=0.2063653565200186D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5245681526132446D+0 - B=0.4548781735309936D+0 - V=0.2073507927381027D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5506733911803888D+0 - B=0.4815315355023251D+0 - V=0.2079764593256122D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5755339829522475D+0 - B=0.5070486445801855D+0 - V=0.2083150534968778D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1305472386056362D+0 - B=0.2284970375722366D-1 - V=0.1262715121590664D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1637327908216477D+0 - B=0.4812254338288384D-1 - V=0.1414386128545972D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1972734634149637D+0 - B=0.7531734457511935D-1 - V=0.1538740401313898D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2308694653110130D+0 - B=0.1039043639882017D+0 - V=0.1642434942331432D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2643899218338160D+0 - B=0.1334526587117626D+0 - V=0.1729790609237496D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2977171599622171D+0 - B=0.1636414868936382D+0 - V=0.1803505190260828D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3307293903032310D+0 - B=0.1942195406166568D+0 - V=0.1865475350079657D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3633069198219073D+0 - B=0.2249752879943753D+0 - V=0.1917182669679069D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3953346955922727D+0 - B=0.2557218821820032D+0 - V=0.1959851709034382D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4267018394184914D+0 - B=0.2862897925213193D+0 - V=0.1994529548117882D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4573009622571704D+0 - B=0.3165224536636518D+0 - V=0.2022138911146548D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4870279559856109D+0 - B=0.3462730221636496D+0 - V=0.2043518024208592D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5157819581450322D+0 - B=0.3754016870282835D+0 - V=0.2059450313018110D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5434651666465393D+0 - B=0.4037733784993613D+0 - V=0.2070685715318472D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5699823887764627D+0 - B=0.4312557784139123D+0 - V=0.2077955310694373D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5952403350947741D+0 - B=0.4577175367122110D+0 - V=0.2081980387824712D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2025152599210369D+0 - B=0.2520253617719557D-1 - V=0.1521318610377956D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2381066653274425D+0 - B=0.5223254506119000D-1 - V=0.1622772720185755D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2732823383651612D+0 - B=0.8060669688588620D-1 - V=0.1710498139420709D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3080137692611118D+0 - B=0.1099335754081255D+0 - V=0.1785911149448736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3422405614587601D+0 - B=0.1399120955959857D+0 - V=0.1850125313687736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3758808773890420D+0 - B=0.1702977801651705D+0 - V=0.1904229703933298D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4088458383438932D+0 - B=0.2008799256601680D+0 - V=0.1949259956121987D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4410450550841152D+0 - B=0.2314703052180836D+0 - V=0.1986161545363960D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4723879420561312D+0 - B=0.2618972111375892D+0 - V=0.2015790585641370D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5027843561874343D+0 - B=0.2920013195600270D+0 - V=0.2038934198707418D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5321453674452458D+0 - B=0.3216322555190551D+0 - V=0.2056334060538251D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5603839113834030D+0 - B=0.3506456615934198D+0 - V=0.2068705959462289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5874150706875146D+0 - B=0.3789007181306267D+0 - V=0.2076753906106002D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6131559381660038D+0 - B=0.4062580170572782D+0 - V=0.2081179391734803D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2778497016394506D+0 - B=0.2696271276876226D-1 - V=0.1700345216228943D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3143733562261912D+0 - B=0.5523469316960465D-1 - V=0.1774906779990410D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3501485810261827D+0 - B=0.8445193201626464D-1 - V=0.1839659377002642D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3851430322303653D+0 - B=0.1143263119336083D+0 - V=0.1894987462975169D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4193013979470415D+0 - B=0.1446177898344475D+0 - V=0.1941548809452595D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4525585960458567D+0 - B=0.1751165438438091D+0 - V=0.1980078427252384D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4848447779622947D+0 - B=0.2056338306745660D+0 - V=0.2011296284744488D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5160871208276894D+0 - B=0.2359965487229226D+0 - V=0.2035888456966776D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5462112185696926D+0 - B=0.2660430223139146D+0 - V=0.2054516325352142D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5751425068101757D+0 - B=0.2956193664498032D+0 - V=0.2067831033092635D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6028073872853596D+0 - B=0.3245763905312779D+0 - V=0.2076485320284876D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6291338275278409D+0 - B=0.3527670026206972D+0 - V=0.2081141439525255D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3541797528439391D+0 - B=0.2823853479435550D-1 - V=0.1834383015469222D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3908234972074657D+0 - B=0.5741296374713106D-1 - V=0.1889540591777677D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4264408450107590D+0 - B=0.8724646633650199D-1 - V=0.1936677023597375D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4609949666553286D+0 - B=0.1175034422915616D+0 - V=0.1976176495066504D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4944389496536006D+0 - B=0.1479755652628428D+0 - V=0.2008536004560983D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5267194884346086D+0 - B=0.1784740659484352D+0 - V=0.2034280351712291D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5577787810220990D+0 - B=0.2088245700431244D+0 - V=0.2053944466027758D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5875563763536670D+0 - B=0.2388628136570763D+0 - V=0.2068077642882360D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6159910016391269D+0 - B=0.2684308928769185D+0 - V=0.2077250949661599D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6430219602956268D+0 - B=0.2973740761960252D+0 - V=0.2082062440705320D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4300647036213646D+0 - B=0.2916399920493977D-1 - V=0.1934374486546626D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4661486308935531D+0 - B=0.5898803024755659D-1 - V=0.1974107010484300D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5009658555287261D+0 - B=0.8924162698525409D-1 - V=0.2007129290388658D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5344824270447704D+0 - B=0.1197185199637321D+0 - V=0.2033736947471293D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5666575997416371D+0 - B=0.1502300756161382D+0 - V=0.2054287125902493D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5974457471404752D+0 - B=0.1806004191913564D+0 - V=0.2069184936818894D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6267984444116886D+0 - B=0.2106621764786252D+0 - V=0.2078883689808782D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6546664713575417D+0 - B=0.2402526932671914D+0 - V=0.2083886366116359D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5042711004437253D+0 - B=0.2982529203607657D-1 - V=0.2006593275470817D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5392127456774380D+0 - B=0.6008728062339922D-1 - V=0.2033728426135397D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5726819437668618D+0 - B=0.9058227674571398D-1 - V=0.2055008781377608D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6046469254207278D+0 - B=0.1211219235803400D+0 - V=0.2070651783518502D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6350716157434952D+0 - B=0.1515286404791580D+0 - V=0.2080953335094320D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6639177679185454D+0 - B=0.1816314681255552D+0 - V=0.2086284998988521D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5757276040972253D+0 - B=0.3026991752575440D-1 - V=0.2055549387644668D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6090265823139755D+0 - B=0.6078402297870770D-1 - V=0.2071871850267654D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6406735344387661D+0 - B=0.9135459984176636D-1 - V=0.2082856600431965D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6706397927793709D+0 - B=0.1218024155966590D+0 - V=0.2088705858819358D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6435019674426665D+0 - B=0.3052608357660639D-1 - V=0.2083995867536322D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6747218676375681D+0 - B=0.6112185773983089D-1 - V=0.2090509712889637D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - SUBROUTINE LD5810(X,Y,Z,W,N) - DOUBLE PRECISION X(5810) - DOUBLE PRECISION Y(5810) - DOUBLE PRECISION Z(5810) - DOUBLE PRECISION W(5810) - INTEGER N - DOUBLE PRECISION A,B,V -CVW -CVW LEBEDEV 5810-POINT ANGULAR GRID -CVW -chvd -chvd This subroutine is part of a set of subroutines that generate -chvd Lebedev grids [1-6] for integration on a sphere. The original -chvd C-code [1] was kindly provided by Dr. Dmitri N. Laikov and -chvd translated into fortran by Dr. Christoph van Wuellen. -chvd This subroutine was translated using a C to fortran77 conversion -chvd tool written by Dr. Christoph van Wuellen. -chvd -chvd Users of this code are asked to include reference [1] in their -chvd publications, and in the user- and programmers-manuals -chvd describing their codes. -chvd -chvd This code was distributed through CCL (http://www.ccl.net/). -chvd -chvd [1] V.I. Lebedev, and D.N. Laikov -chvd "A quadrature formula for the sphere of the 131st -chvd algebraic order of accuracy" -chvd Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. -chvd -chvd [2] V.I. Lebedev -chvd "A quadrature formula for the sphere of 59th algebraic -chvd order of accuracy" -chvd Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. -chvd -chvd [3] V.I. Lebedev, and A.L. Skorokhodov -chvd "Quadrature formulas of orders 41, 47, and 53 for the sphere" -chvd Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. -chvd -chvd [4] V.I. Lebedev -chvd "Spherical quadrature formulas exact to orders 25-29" -chvd Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. -chvd -chvd [5] V.I. Lebedev -chvd "Quadratures on a sphere" -chvd Computational Mathematics and Mathematical Physics, Vol. 16, -chvd 1976, pp. 10-24. -chvd -chvd [6] V.I. Lebedev -chvd "Values of the nodes and weights of ninth to seventeenth -chvd order Gauss-Markov quadrature formulae invariant under the -chvd octahedron group with inversion" -chvd Computational Mathematics and Mathematical Physics, Vol. 15, -chvd 1975, pp. 44-51. -chvd - N=1 - V=0.9735347946175486D-5 - Call GEN_OH( 1, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1907581241803167D-3 - Call GEN_OH( 2, N, X(N), Y(N), Z(N), W(N), A, B, V) - V=0.1901059546737578D-3 - Call GEN_OH( 3, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1182361662400277D-1 - V=0.3926424538919212D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3062145009138958D-1 - V=0.6667905467294382D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5329794036834243D-1 - V=0.8868891315019135D-4 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7848165532862220D-1 - V=0.1066306000958872D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1054038157636201D+0 - V=0.1214506743336128D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1335577797766211D+0 - V=0.1338054681640871D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1625769955502252D+0 - V=0.1441677023628504D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1921787193412792D+0 - V=0.1528880200826557D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2221340534690548D+0 - V=0.1602330623773609D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2522504912791132D+0 - V=0.1664102653445244D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2823610860679697D+0 - V=0.1715845854011323D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3123173966267560D+0 - V=0.1758901000133069D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3419847036953789D+0 - V=0.1794382485256736D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3712386456999758D+0 - V=0.1823238106757407D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3999627649876828D+0 - V=0.1846293252959976D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4280466458648093D+0 - V=0.1864284079323098D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4553844360185711D+0 - V=0.1877882694626914D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4818736094437834D+0 - V=0.1887716321852025D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5074138709260629D+0 - V=0.1894381638175673D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5319061304570707D+0 - V=0.1898454899533629D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5552514978677286D+0 - V=0.1900497929577815D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5981009025246183D+0 - V=0.1900671501924092D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6173990192228116D+0 - V=0.1899837555533510D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6351365239411131D+0 - V=0.1899014113156229D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6512010228227200D+0 - V=0.1898581257705106D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6654758363948120D+0 - V=0.1898804756095753D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6778410414853370D+0 - V=0.1899793610426402D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6881760887484110D+0 - V=0.1901464554844117D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6963645267094598D+0 - V=0.1903533246259542D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7023010617153579D+0 - V=0.1905556158463228D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.7059004636628753D+0 - V=0.1907037155663528D-3 - Call GEN_OH( 4, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3552470312472575D-1 - V=0.5992997844249967D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.9151176620841283D-1 - V=0.9749059382456978D-4 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1566197930068980D+0 - V=0.1241680804599158D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2265467599271907D+0 - V=0.1437626154299360D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2988242318581361D+0 - V=0.1584200054793902D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3717482419703886D+0 - V=0.1694436550982744D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4440094491758889D+0 - V=0.1776617014018108D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5145337096756642D+0 - V=0.1836132434440077D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5824053672860230D+0 - V=0.1876494727075983D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6468283961043370D+0 - V=0.1899906535336482D-3 - Call GEN_OH( 5, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6095964259104373D-1 - B=0.1787828275342931D-1 - V=0.8143252820767350D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.8811962270959388D-1 - B=0.3953888740792096D-1 - V=0.9998859890887728D-4 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1165936722428831D+0 - B=0.6378121797722990D-1 - V=0.1156199403068359D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1460232857031785D+0 - B=0.8985890813745037D-1 - V=0.1287632092635513D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1761197110181755D+0 - B=0.1172606510576162D+0 - V=0.1398378643365139D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2066471190463718D+0 - B=0.1456102876970995D+0 - V=0.1491876468417391D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2374076026328152D+0 - B=0.1746153823011775D+0 - V=0.1570855679175456D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2682305474337051D+0 - B=0.2040383070295584D+0 - V=0.1637483948103775D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2989653312142369D+0 - B=0.2336788634003698D+0 - V=0.1693500566632843D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3294762752772209D+0 - B=0.2633632752654219D+0 - V=0.1740322769393633D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3596390887276086D+0 - B=0.2929369098051601D+0 - V=0.1779126637278296D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3893383046398812D+0 - B=0.3222592785275512D+0 - V=0.1810908108835412D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4184653789358347D+0 - B=0.3512004791195743D+0 - V=0.1836529132600190D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4469172319076166D+0 - B=0.3796385677684537D+0 - V=0.1856752841777379D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4745950813276976D+0 - B=0.4074575378263879D+0 - V=0.1872270566606832D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5014034601410262D+0 - B=0.4345456906027828D+0 - V=0.1883722645591307D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5272493404551239D+0 - B=0.4607942515205134D+0 - V=0.1891714324525297D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5520413051846366D+0 - B=0.4860961284181720D+0 - V=0.1896827480450146D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5756887237503077D+0 - B=0.5103447395342790D+0 - V=0.1899628417059528D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1225039430588352D+0 - B=0.2136455922655793D-1 - V=0.1123301829001669D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1539113217321372D+0 - B=0.4520926166137188D-1 - V=0.1253698826711277D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1856213098637712D+0 - B=0.7086468177864818D-1 - V=0.1366266117678531D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2174998728035131D+0 - B=0.9785239488772918D-1 - V=0.1462736856106918D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2494128336938330D+0 - B=0.1258106396267210D+0 - V=0.1545076466685412D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2812321562143480D+0 - B=0.1544529125047001D+0 - V=0.1615096280814007D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3128372276456111D+0 - B=0.1835433512202753D+0 - V=0.1674366639741759D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3441145160177973D+0 - B=0.2128813258619585D+0 - V=0.1724225002437900D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3749567714853510D+0 - B=0.2422913734880829D+0 - V=0.1765810822987288D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4052621732015610D+0 - B=0.2716163748391453D+0 - V=0.1800104126010751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4349335453522385D+0 - B=0.3007127671240280D+0 - V=0.1827960437331284D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4638776641524965D+0 - B=0.3294470677216479D+0 - V=0.1850140300716308D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4920046410462687D+0 - B=0.3576932543699155D+0 - V=0.1867333507394938D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5192273554861704D+0 - B=0.3853307059757764D+0 - V=0.1880178688638289D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5454609081136522D+0 - B=0.4122425044452694D+0 - V=0.1889278925654758D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5706220661424140D+0 - B=0.4383139587781027D+0 - V=0.1895213832507346D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5946286755181518D+0 - B=0.4634312536300553D+0 - V=0.1898548277397420D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.1905370790924295D+0 - B=0.2371311537781979D-1 - V=0.1349105935937341D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2242518717748009D+0 - B=0.4917878059254806D-1 - V=0.1444060068369326D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2577190808025936D+0 - B=0.7595498960495142D-1 - V=0.1526797390930008D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2908724534927187D+0 - B=0.1036991083191100D+0 - V=0.1598208771406474D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3236354020056219D+0 - B=0.1321348584450234D+0 - V=0.1659354368615331D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3559267359304543D+0 - B=0.1610316571314789D+0 - V=0.1711279910946440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3876637123676956D+0 - B=0.1901912080395707D+0 - V=0.1754952725601440D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4187636705218842D+0 - B=0.2194384950137950D+0 - V=0.1791247850802529D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4491449019883107D+0 - B=0.2486155334763858D+0 - V=0.1820954300877716D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4787270932425445D+0 - B=0.2775768931812335D+0 - V=0.1844788524548449D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5074315153055574D+0 - B=0.3061863786591120D+0 - V=0.1863409481706220D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5351810507738336D+0 - B=0.3343144718152556D+0 - V=0.1877433008795068D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5619001025975381D+0 - B=0.3618362729028427D+0 - V=0.1887444543705232D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5875144035268046D+0 - B=0.3886297583620408D+0 - V=0.1894009829375006D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6119507308734495D+0 - B=0.4145742277792031D+0 - V=0.1897683345035198D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2619733870119463D+0 - B=0.2540047186389353D-1 - V=0.1517327037467653D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.2968149743237949D+0 - B=0.5208107018543989D-1 - V=0.1587740557483543D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3310451504860488D+0 - B=0.7971828470885599D-1 - V=0.1649093382274097D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3646215567376676D+0 - B=0.1080465999177927D+0 - V=0.1701915216193265D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3974916785279360D+0 - B=0.1368413849366629D+0 - V=0.1746847753144065D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4295967403772029D+0 - B=0.1659073184763559D+0 - V=0.1784555512007570D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4608742854473447D+0 - B=0.1950703730454614D+0 - V=0.1815687562112174D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4912598858949903D+0 - B=0.2241721144376724D+0 - V=0.1840864370663302D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5206882758945558D+0 - B=0.2530655255406489D+0 - V=0.1860676785390006D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5490940914019819D+0 - B=0.2816118409731066D+0 - V=0.1875690583743703D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5764123302025542D+0 - B=0.3096780504593238D+0 - V=0.1886453236347225D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6025786004213506D+0 - B=0.3371348366394987D+0 - V=0.1893501123329645D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6275291964794956D+0 - B=0.3638547827694396D+0 - V=0.1897366184519868D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3348189479861771D+0 - B=0.2664841935537443D-1 - V=0.1643908815152736D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.3699515545855295D+0 - B=0.5424000066843495D-1 - V=0.1696300350907768D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4042003071474669D+0 - B=0.8251992715430854D-1 - V=0.1741553103844483D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4375320100182624D+0 - B=0.1112695182483710D+0 - V=0.1780015282386092D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4699054490335947D+0 - B=0.1402964116467816D+0 - V=0.1812116787077125D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5012739879431952D+0 - B=0.1694275117584291D+0 - V=0.1838323158085421D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5315874883754966D+0 - B=0.1985038235312689D+0 - V=0.1859113119837737D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5607937109622117D+0 - B=0.2273765660020893D+0 - V=0.1874969220221698D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5888393223495521D+0 - B=0.2559041492849764D+0 - V=0.1886375612681076D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6156705979160163D+0 - B=0.2839497251976899D+0 - V=0.1893819575809276D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6412338809078123D+0 - B=0.3113791060500690D+0 - V=0.1897794748256767D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4076051259257167D+0 - B=0.2757792290858463D-1 - V=0.1738963926584846D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4423788125791520D+0 - B=0.5584136834984293D-1 - V=0.1777442359873466D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4760480917328258D+0 - B=0.8457772087727143D-1 - V=0.1810010815068719D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5085838725946297D+0 - B=0.1135975846359248D+0 - V=0.1836920318248129D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5399513637391218D+0 - B=0.1427286904765053D+0 - V=0.1858489473214328D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5701118433636380D+0 - B=0.1718112740057635D+0 - V=0.1875079342496592D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5990240530606021D+0 - B=0.2006944855985351D+0 - V=0.1887080239102310D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6266452685139695D+0 - B=0.2292335090598907D+0 - V=0.1894905752176822D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6529320971415942D+0 - B=0.2572871512353714D+0 - V=0.1898991061200695D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.4791583834610126D+0 - B=0.2826094197735932D-1 - V=0.1809065016458791D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5130373952796940D+0 - B=0.5699871359683649D-1 - V=0.1836297121596799D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5456252429628476D+0 - B=0.8602712528554394D-1 - V=0.1858426916241869D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5768956329682385D+0 - B=0.1151748137221281D+0 - V=0.1875654101134641D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6068186944699046D+0 - B=0.1442811654136362D+0 - V=0.1888240751833503D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6353622248024907D+0 - B=0.1731930321657680D+0 - V=0.1896497383866979D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6624927035731797D+0 - B=0.2017619958756061D+0 - V=0.1900775530219121D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5484933508028488D+0 - B=0.2874219755907391D-1 - V=0.1858525041478814D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.5810207682142106D+0 - B=0.5778312123713695D-1 - V=0.1876248690077947D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6120955197181352D+0 - B=0.8695262371439526D-1 - V=0.1889404439064607D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6416944284294319D+0 - B=0.1160893767057166D+0 - V=0.1898168539265290D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6697926391731260D+0 - B=0.1450378826743251D+0 - V=0.1902779940661772D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6147594390585488D+0 - B=0.2904957622341456D-1 - V=0.1890125641731815D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6455390026356783D+0 - B=0.5823809152617197D-1 - V=0.1899434637795751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6747258588365477D+0 - B=0.8740384899884715D-1 - V=0.1904520856831751D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - A=0.6772135750395347D+0 - B=0.2919946135808105D-1 - V=0.1905534498734563D-3 - Call GEN_OH( 6, N, X(N), Y(N), Z(N), W(N), A, B, V) - N=N-1 - RETURN - END - - diff --git a/plugins/DFT_Utils/functional.irp.f b/plugins/DFT_Utils/functional.irp.f deleted file mode 100644 index e034a244..00000000 --- a/plugins/DFT_Utils/functional.irp.f +++ /dev/null @@ -1,54 +0,0 @@ -subroutine ex_lda(rho_a,rho_b,ex,vx_a,vx_b) - include 'constants.include.F' - implicit none - double precision, intent(in) :: rho_a,rho_b - double precision, intent(out) :: ex,vx_a,vx_b - double precision :: tmp_a,tmp_b - tmp_a = rho_a**(c_1_3) - tmp_b = rho_b**(c_1_3) - ex = cst_lda * (tmp_a*tmp_a*tmp_a*tmp_a + tmp_b*tmp_b*tmp_b*tmp_b) - vx_a = cst_lda * c_4_3 * tmp_a - vx_b = cst_lda * c_4_3 * tmp_b - -end - - BEGIN_PROVIDER [double precision, lda_exchange, (N_states)] -&BEGIN_PROVIDER [double precision, lda_ex_potential_alpha_ao,(ao_num_align,ao_num,N_states)] -&BEGIN_PROVIDER [double precision, lda_ex_potential_beta_ao,(ao_num_align,ao_num,N_states)] - - implicit none - integer :: i,j,k,l - integer :: m,n - double precision :: aos_array(ao_num) - double precision :: r(3) - lda_ex_potential_alpha_ao = 0.d0 - lda_ex_potential_beta_ao = 0.d0 - do l = 1, N_states - lda_exchange(l) = 0.d0 - do j = 1, nucl_num - do i = 1, n_points_radial_grid - do k = 1, n_points_integration_angular - double precision :: rho_a,rho_b,ex - double precision :: vx_a,vx_b - rho_a = one_body_dm_mo_alpha_at_grid_points(k,i,j,l) - rho_b = one_body_dm_mo_beta_at_grid_points(k,i,j,l) - call ex_lda(rho_a,rho_b,ex,vx_a,vx_b) - lda_exchange(l) += final_weight_functions_at_grid_points(k,i,j) * ex - r(1) = grid_points_per_atom(1,k,i,j) - r(2) = grid_points_per_atom(2,k,i,j) - r(3) = grid_points_per_atom(3,k,i,j) - call give_all_aos_at_r(r,aos_array) - do m = 1, ao_num -! lda_ex_potential_ao(m,m,l) += (vx_a + vx_b) * aos_array(m)*aos_array(m) - do n = 1, ao_num - lda_ex_potential_alpha_ao(m,n,l) += (vx_a ) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) - lda_ex_potential_beta_ao(m,n,l) += (vx_b) * aos_array(m)*aos_array(n) * final_weight_functions_at_grid_points(k,i,j) - enddo - enddo - enddo - enddo - enddo - enddo - -END_PROVIDER - diff --git a/plugins/DFT_Utils/grid_density.irp.f b/plugins/DFT_Utils/grid_density.irp.f index 7c9d2c05..6071a18b 100644 --- a/plugins/DFT_Utils/grid_density.irp.f +++ b/plugins/DFT_Utils/grid_density.irp.f @@ -1,60 +1,42 @@ - BEGIN_PROVIDER [integer, n_points_integration_angular] +BEGIN_PROVIDER [integer, n_points_angular_grid] implicit none - n_points_integration_angular = 110 - END_PROVIDER + n_points_angular_grid = 50 +END_PROVIDER BEGIN_PROVIDER [integer, n_points_radial_grid] implicit none - n_points_radial_grid = 100 + n_points_radial_grid = 10000 END_PROVIDER - BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_integration_angular,3) ] -&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_integration_angular)] + BEGIN_PROVIDER [double precision, angular_quadrature_points, (n_points_angular_grid,3) ] +&BEGIN_PROVIDER [double precision, weights_angular_points, (n_points_angular_grid)] implicit none BEGIN_DOC ! weights and grid points for the integration on the angular variables on ! the unit sphere centered on (0,0,0) ! According to the LEBEDEV scheme END_DOC - angular_quadrature_points = 0.d0 - weights_angular_points = 0.d0 -!call cal_quad(n_points_integration_angular, angular_quadrature_points,weights_angular_points) + call cal_quad(n_points_angular_grid, angular_quadrature_points,weights_angular_points) include 'constants.include.F' - integer :: i,n + integer :: i double precision :: accu double precision :: degre_rad - degre_rad = pi/180.d0 - accu = 0.d0 - double precision :: x(n_points_integration_angular),y(n_points_integration_angular),z(n_points_integration_angular),w(n_points_integration_angular) - call LD0110(X,Y,Z,W,N) - do i = 1, n_points_integration_angular - angular_quadrature_points(i,1) = x(i) - angular_quadrature_points(i,2) = y(i) - angular_quadrature_points(i,3) = z(i) - weights_angular_points(i) = w(i) * 4.d0 * pi - accu += w(i) - enddo -!do i = 1, n_points_integration_angular +!degre_rad = 180.d0/pi +!accu = 0.d0 +!do i = 1, n_points_integration_angular_lebedev ! accu += weights_angular_integration_lebedev(i) -! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 4.d0 * pi +! weights_angular_points(i) = weights_angular_integration_lebedev(i) * 2.d0 * pi ! angular_quadrature_points(i,1) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,2) = dsin ( degre_rad * theta_angular_integration_lebedev(i)) & ! * dsin ( degre_rad * phi_angular_integration_lebedev(i)) ! angular_quadrature_points(i,3) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) - -!!weights_angular_points(i) = weights_angular_integration_lebedev(i) -!!angular_quadrature_points(i,1) = dcos ( degre_rad * phi_angular_integration_lebedev(i)) & -!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) -!!angular_quadrature_points(i,2) = dsin ( degre_rad * phi_angular_integration_lebedev(i)) & -!! * dsin ( degre_rad * theta_angular_integration_lebedev(i)) -!!angular_quadrature_points(i,3) = dcos ( degre_rad * theta_angular_integration_lebedev(i)) !enddo - print*,'ANGULAR' - print*,'' - print*,'accu = ',accu - ASSERT( dabs(accu - 1.D0) < 1.d-10) +!print*,'ANGULAR' +!print*,'' +!print*,'accu = ',accu +!ASSERT( dabs(accu - 1.D0) < 1.d-10) END_PROVIDER @@ -81,7 +63,7 @@ END_PROVIDER END_PROVIDER -BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_angular,n_points_radial_grid,nucl_num)] +BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_angular_grid,n_points_radial_grid,nucl_num)] BEGIN_DOC ! points for integration over space END_DOC @@ -97,7 +79,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ double precision :: x,r x = grid_points_radial(j) ! x value for the mapping of the [0, +\infty] to [0,1] r = knowles_function(alpha_knowles(int(nucl_charge(i))),m_knowles,x) ! value of the radial coordinate for the integration - do k = 1, n_points_integration_angular ! explicit values of the grid points centered around each atom + do k = 1, n_points_angular_grid ! explicit values of the grid points centered around each atom grid_points_per_atom(1,k,j,i) = x_ref + angular_quadrature_points(k,1) * r grid_points_per_atom(2,k,j,i) = y_ref + angular_quadrature_points(k,2) * r grid_points_per_atom(3,k,j,i) = z_ref + angular_quadrature_points(k,3) * r @@ -106,7 +88,7 @@ BEGIN_PROVIDER [double precision, grid_points_per_atom, (3,n_points_integration_ enddo END_PROVIDER -BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] +BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] BEGIN_DOC ! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) ! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension @@ -120,7 +102,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int ! run over all points in space do j = 1, nucl_num ! that are referred to each atom do k = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do l = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom + do l = 1, n_points_angular_grid ! for each angular point attached to the "jth" atom r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) @@ -133,6 +115,7 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int enddo accu = 1.d0/accu weight_functions_at_grid_points(l,k,j) = tmp_array(j) * accu +! print*,weight_functions_at_grid_points(l,k,j) enddo enddo enddo @@ -140,65 +123,43 @@ BEGIN_PROVIDER [double precision, weight_functions_at_grid_points, (n_points_int END_PROVIDER -BEGIN_PROVIDER [double precision, final_weight_functions_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num) ] - BEGIN_DOC -! Weight function at grid points : w_n(r) according to the equation (22) of Becke original paper (JCP, 88, 1988) -! the "n" discrete variable represents the nucleis which in this array is represented by the last dimension -! and the points are labelled by the other dimensions - END_DOC + BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] +&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_angular_grid,n_points_radial_grid,nucl_num) ] implicit none integer :: i,j,k,l,m - double precision :: r(3) - double precision :: accu,cell_function_becke - double precision :: tmp_array(nucl_num) - double precision :: contrib_integration,x - double precision :: derivative_knowles_function,knowles_function - ! run over all points in space - do j = 1, nucl_num ! that are referred to each atom - do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] - do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom - contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & - *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 - final_weight_functions_at_grid_points(k,i,j) = weights_angular_points(k) * weight_functions_at_grid_points(k,i,j) * contrib_integration * dr_radial_integral - enddo - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [double precision, one_body_dm_mo_alpha_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] -&BEGIN_PROVIDER [double precision, one_body_dm_mo_beta_at_grid_points, (n_points_integration_angular,n_points_radial_grid,nucl_num,N_states) ] - implicit none - integer :: i,j,k,l,m,i_state double precision :: contrib double precision :: r(3) double precision :: aos_array(ao_num),mos_array(mo_tot_num) - do i_state = 1, N_states do j = 1, nucl_num - do k = 1, n_points_radial_grid - do l = 1, n_points_integration_angular - one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) = 0.d0 - one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) = 0.d0 + do k = 1, n_points_radial_grid -1 + do l = 1, n_points_angular_grid + one_body_dm_mo_alpha_at_grid_points(l,k,j) = 0.d0 + one_body_dm_mo_beta_at_grid_points(l,k,j) = 0.d0 r(1) = grid_points_per_atom(1,l,k,j) r(2) = grid_points_per_atom(2,l,k,j) r(3) = grid_points_per_atom(3,l,k,j) +! call give_all_aos_at_r(r,aos_array) +! do i = 1, ao_num +! do m = 1, ao_num +! contrib = aos_array(i) * aos_array(m) +! one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_ao_alpha(i,m) * contrib +! one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_ao_beta(i,m) * contrib +! enddo +! enddo + call give_all_mos_at_r(r,mos_array) - do m = 1, mo_tot_num - do i = 1, mo_tot_num - if(dabs(one_body_dm_mo_alpha(i,m,i_state)).lt.1.d-10)cycle + do i = 1, mo_tot_num + do m = 1, mo_tot_num contrib = mos_array(i) * mos_array(m) - one_body_dm_mo_alpha_at_grid_points(l,k,j,i_state) += one_body_dm_mo_alpha(i,m,i_state) * contrib - one_body_dm_mo_beta_at_grid_points(l,k,j,i_state) += one_body_dm_mo_beta(i,m,i_state) * contrib + one_body_dm_mo_alpha_at_grid_points(l,k,j) += one_body_dm_mo_alpha(i,m) * contrib + one_body_dm_mo_beta_at_grid_points(l,k,j) += one_body_dm_mo_beta(i,m) * contrib enddo enddo enddo enddo enddo - enddo END_PROVIDER diff --git a/plugins/DFT_Utils/integration_3d.irp.f b/plugins/DFT_Utils/integration_3d.irp.f index a665349a..43eb1ab8 100644 --- a/plugins/DFT_Utils/integration_3d.irp.f +++ b/plugins/DFT_Utils/integration_3d.irp.f @@ -4,11 +4,18 @@ double precision function step_function_becke(x) double precision :: f_function_becke integer :: i,n_max_becke +!if(x.lt.-1.d0)then +! step_function_becke = 0.d0 +!else if (x .gt.1)then +! step_function_becke = 0.d0 +!else step_function_becke = f_function_becke(x) - do i = 1,5 +!!n_max_becke = 1 + do i = 1, 4 step_function_becke = f_function_becke(step_function_becke) enddo step_function_becke = 0.5d0*(1.d0 - step_function_becke) +!endif end double precision function f_function_becke(x) diff --git a/plugins/DFT_Utils/integration_radial.irp.f b/plugins/DFT_Utils/integration_radial.irp.f index 0708658f..4943783b 100644 --- a/plugins/DFT_Utils/integration_radial.irp.f +++ b/plugins/DFT_Utils/integration_radial.irp.f @@ -4,7 +4,7 @@ double precision :: accu integer :: i,j,k,l double precision :: x - double precision :: integrand(n_points_integration_angular), weights(n_points_integration_angular) + double precision :: integrand(n_points_angular_grid), weights(n_points_angular_grid) double precision :: f_average_angular_alpha,f_average_angular_beta double precision :: derivative_knowles_function,knowles_function @@ -12,7 +12,7 @@ ! according ot equation (6) of the paper of Becke (JCP, (88), 1988) ! Here the m index is referred to the w_m(r) weight functions of equation (22) ! Run over all points of integrations : there are - ! n_points_radial_grid (i) * n_points_integration_angular (k) + ! n_points_radial_grid (i) * n_points_angular_grid (k) do j = 1, nucl_num integral_density_alpha_knowles_becke_per_atom(j) = 0.d0 integral_density_beta_knowles_becke_per_atom(j) = 0.d0 @@ -20,13 +20,14 @@ ! Angular integration over the solid angle Omega for a FIXED angular coordinate "r" f_average_angular_alpha = 0.d0 f_average_angular_beta = 0.d0 - do k = 1, n_points_integration_angular - f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) - f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j,1) * weight_functions_at_grid_points(k,i,j) + do k = 1, n_points_angular_grid + f_average_angular_alpha += weights_angular_points(k) * one_body_dm_mo_alpha_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) + f_average_angular_beta += weights_angular_points(k) * one_body_dm_mo_beta_at_grid_points(k,i,j) * weight_functions_at_grid_points(k,i,j) enddo ! x = grid_points_radial(i) ! x value for the mapping of the [0, +\infty] to [0,1] double precision :: contrib_integration +! print*,m_knowles contrib_integration = derivative_knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x) & *knowles_function(alpha_knowles(int(nucl_charge(j))),m_knowles,x)**2 integral_density_alpha_knowles_becke_per_atom(j) += contrib_integration *f_average_angular_alpha diff --git a/plugins/DFT_Utils/test_integration_3d_density.irp.f b/plugins/DFT_Utils/test_integration_3d_density.irp.f index dba02805..93ce58f4 100644 --- a/plugins/DFT_Utils/test_integration_3d_density.irp.f +++ b/plugins/DFT_Utils/test_integration_3d_density.irp.f @@ -4,55 +4,13 @@ program pouet touch read_wf print*,'m_knowles = ',m_knowles call routine - call routine3 end - - - -subroutine routine3 - implicit none - integer :: i,j,k,l - double precision :: accu - accu = 0.d0 - do j = 1, nucl_num ! that are referred to each atom - do i = 1, n_points_radial_grid -1 !for each radial grid attached to the "jth" atom - do k = 1, n_points_integration_angular ! for each angular point attached to the "jth" atom - accu += final_weight_functions_at_grid_points(k,i,j) * one_body_dm_mo_alpha_at_grid_points(k,i,j,1) - enddo - enddo - enddo - print*, accu - print*, 'lda_exchange',lda_exchange - -end -subroutine routine2 - implicit none - integer :: i,j,k,l - double precision :: x,y,z - double precision :: r - double precision :: accu - accu = 0.d0 - r = 1.d0 - do k = 1, n_points_integration_angular - x = angular_quadrature_points(k,1) * r - y = angular_quadrature_points(k,2) * r - z = angular_quadrature_points(k,3) * r - accu += weights_angular_points(k) * (x**2 + y**2 + z**2) - enddo - print*, accu - -end - - subroutine routine implicit none integer :: i double precision :: accu(2) accu = 0.d0 - do i = 1, N_det - call debug_det(psi_det(1,1,i),N_int) - enddo do i = 1, nucl_num accu(1) += integral_density_alpha_knowles_becke_per_atom(i) accu(2) += integral_density_beta_knowles_becke_per_atom(i) @@ -61,18 +19,6 @@ subroutine routine print*,'Nalpha = ',elec_alpha_num print*,'accu(2) = ',accu(2) print*,'Nalpha = ',elec_beta_num - - accu = 0.d0 - do i = 1, mo_tot_num - accu(1) += one_body_dm_mo_alpha_average(i,i) - accu(2) += one_body_dm_mo_beta_average(i,i) - enddo - - - print*,' ' - print*,' ' - print*,'accu(1) = ',accu(1) - print*,'accu(2) = ',accu(2) end diff --git a/plugins/FCIdump/NEEDED_CHILDREN_MODULES b/plugins/FCIdump/NEEDED_CHILDREN_MODULES index 8d60d3c7..34de8ddb 100644 --- a/plugins/FCIdump/NEEDED_CHILDREN_MODULES +++ b/plugins/FCIdump/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Davidson core_integrals +Determinants Davidson diff --git a/plugins/FCIdump/fcidump.irp.f b/plugins/FCIdump/fcidump.irp.f index 8d334fc5..f93c1128 100644 --- a/plugins/FCIdump/fcidump.irp.f +++ b/plugins/FCIdump/fcidump.irp.f @@ -1,25 +1,21 @@ program fcidump implicit none - character*(128) :: output - integer :: i_unit_output,getUnitAndOpen - output=trim(ezfio_filename)//'.FCIDUMP' - i_unit_output = getUnitAndOpen(output,'w') integer :: i,j,k,l - integer :: i1,j1,k1,l1 - integer :: i2,j2,k2,l2 + integer :: ii(8), jj(8), kk(8),ll(8) integer*8 :: m character*(2), allocatable :: A(:) - write(i_unit_output,*) '&FCI NORB=', n_act_orb, ', NELEC=', elec_num-n_core_orb*2, & + print *, '&FCI NORB=', mo_tot_num, ', NELEC=', elec_num, & ', MS2=', (elec_alpha_num-elec_beta_num), ',' - allocate (A(n_act_orb)) + allocate (A(mo_tot_num)) A = '1,' - write(i_unit_output,*) 'ORBSYM=', (A(i), i=1,n_act_orb) - write(i_unit_output,*) 'ISYM=0,' - write(i_unit_output,*) '/' + print *, 'ORBSYM=', (A(i), i=1,mo_tot_num) + print *,'ISYM=0,' + print *,'/' deallocate(A) + integer*8 :: i8, k1 integer(key_kind), allocatable :: keys(:) double precision, allocatable :: values(:) integer(cache_map_size_kind) :: n_elements, n_elements_max @@ -27,18 +23,14 @@ program fcidump double precision :: get_mo_bielec_integral, integral - do l=1,n_act_orb - l1 = list_act(l) - do k=1,n_act_orb - k1 = list_act(k) - do j=l,n_act_orb - j1 = list_act(j) - do i=k,n_act_orb - i1 = list_act(i) - if (i1>=j1) then - integral = get_mo_bielec_integral(i1,j1,k1,l1,mo_integrals_map) + do l=1,mo_tot_num + do k=1,mo_tot_num + do j=l,mo_tot_num + do i=k,mo_tot_num + if (i>=j) then + integral = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) if (dabs(integral) > mo_integrals_threshold) then - write(i_unit_output,*) integral, i,k,j,l + print *, integral, i,k,j,l endif end if enddo @@ -46,15 +38,13 @@ program fcidump enddo enddo - do j=1,n_act_orb - j1 = list_act(j) - do i=j,n_act_orb - i1 = list_act(i) - integral = mo_mono_elec_integral(i1,j1) + core_fock_operator(i1,j1) + do j=1,mo_tot_num + do i=j,mo_tot_num + integral = mo_mono_elec_integral(i,j) if (dabs(integral) > mo_integrals_threshold) then - write(i_unit_output,*) integral, i,j,0,0 + print *, integral, i,j,0,0 endif enddo enddo - write(i_unit_output,*) core_energy, 0, 0, 0, 0 + print *, 0.d0, 0, 0, 0, 0 end diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index 25d61c69..16fce081 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_no_sorted SCF_density Davidson CISD +Perturbation Selectors_no_sorted Hartree_Fock Davidson CISD diff --git a/plugins/FOBOCI/SC2_1h1p.irp.f b/plugins/FOBOCI/SC2_1h1p.irp.f index a6e7e506..7733831c 100644 --- a/plugins/FOBOCI/SC2_1h1p.irp.f +++ b/plugins/FOBOCI/SC2_1h1p.irp.f @@ -356,7 +356,7 @@ subroutine dressing_1h1p_by_2h2p(dets_in,u_in,diag_H_elements,dim_in,sze,N_st,Ni c_ref = 1.d0/u_in(index_hf,1) do k = 1, n_singles l = index_singles(k) - diag_H_elements(1) -= diag_H_elements(l) + diag_H_elements(0) -= diag_H_elements(l) enddo ! do k = 1, n_doubles ! l = index_doubles(k) diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index 7c321b72..65d81e07 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -48,7 +48,6 @@ subroutine all_single(e_pt2) print*,'-----------------------' print*,'i = ',i call H_apply_just_mono(pt2, norm_pert, H_pert_diag, N_st) - call make_s2_eigenfunction_first_order call diagonalize_CI print*,'N_det = ',N_det print*,'E = ',CI_energy(1) diff --git a/plugins/FOBOCI/create_1h_or_1p.irp.f b/plugins/FOBOCI/create_1h_or_1p.irp.f index c5205903..41ec7b6c 100644 --- a/plugins/FOBOCI/create_1h_or_1p.irp.f +++ b/plugins/FOBOCI/create_1h_or_1p.irp.f @@ -29,13 +29,21 @@ subroutine create_restart_and_1h(i_hole) enddo enddo enddo - integer :: N_det_old N_det_old = N_det - - logical, allocatable :: duplicate(:) - allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo n_new_det = 0 do j = 1, n_act_orb @@ -50,56 +58,19 @@ subroutine create_restart_and_1h(i_hole) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - new_det(k,1,n_new_det) = key_tmp(k,1) - new_det(k,2,n_new_det) = key_tmp(k,2) + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - integer :: i_test - duplicate = .False. - do i = 1, n_new_det - if(duplicate(i))cycle - do j = i+1, n_new_det - i_test = 0 - do ispin =1 ,2 - do k = 1, N_int - i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) - enddo - enddo - if(i_test.eq.0)then - duplicate(j) = .True. - endif - enddo - enddo - - integer :: n_new_det_unique - n_new_det_unique = 0 - print*, 'uniq det' - do i = 1, n_new_det - if(.not.duplicate(i))then - n_new_det_unique += 1 - endif - enddo - print*, n_new_det_unique - N_det += n_new_det_unique - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, n_new_det_unique - do ispin = 1, 2 - do k = 1, N_int - psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) - enddo - enddo - psi_coef(N_det_old+i,:) = 0.d0 - enddo - - SOFT_TOUCH N_det psi_det psi_coef - deallocate (new_det,duplicate) + logical :: found_duplicates + if(n_act_orb.gt.1)then + call remove_duplicates_in_psi_det(found_duplicates) + endif end subroutine create_restart_and_1p(i_particle) @@ -136,8 +107,18 @@ subroutine create_restart_and_1p(i_particle) integer :: N_det_old N_det_old = N_det - logical, allocatable :: duplicate(:) - allocate (new_det(N_int,2,n_new_det),duplicate(n_new_det)) + N_det += n_new_det + allocate (new_det(N_int,2,n_new_det)) + if (psi_det_size < N_det) then + psi_det_size = N_det + TOUCH psi_det_size + endif + do i = 1, N_det_old + do k = 1, N_int + psi_det(k,1,i) = old_psi_det(k,1,i) + psi_det(k,2,i) = old_psi_det(k,2,i) + enddo + enddo n_new_det = 0 do j = 1, n_act_orb @@ -152,59 +133,17 @@ subroutine create_restart_and_1p(i_particle) if(i_ok .ne. 1)cycle n_new_det +=1 do k = 1, N_int - new_det(k,1,n_new_det) = key_tmp(k,1) - new_Det(k,2,n_new_det) = key_tmp(k,2) + psi_det(k,1,n_det_old+n_new_det) = key_tmp(k,1) + psi_det(k,2,n_det_old+n_new_det) = key_tmp(k,2) enddo + psi_coef(n_det_old+n_new_det,:) = 0.d0 enddo enddo enddo - integer :: i_test - duplicate = .False. - do i = 1, n_new_det - if(duplicate(i))cycle - call debug_det(new_det(1,1,i),N_int) - do j = i+1, n_new_det - i_test = 0 - call debug_det(new_det(1,1,j),N_int) - do ispin =1 ,2 - do k = 1, N_int - i_test += popcnt(xor(new_det(k,ispin,i),new_det(k,ispin,j))) - enddo - enddo - if(i_test.eq.0)then - duplicate(j) = .True. - endif - enddo - enddo - - integer :: n_new_det_unique - n_new_det_unique = 0 - print*, 'uniq det' - do i = 1, n_new_det - if(.not.duplicate(i))then - n_new_det_unique += 1 - endif - enddo - print*, n_new_det_unique - - N_det += n_new_det_unique - if (psi_det_size < N_det) then - psi_det_size = N_det - TOUCH psi_det_size - endif - do i = 1, n_new_det_unique - do ispin = 1, 2 - do k = 1, N_int - psi_det(k,ispin,N_det_old+i) = new_det(k,ispin,i) - enddo - enddo - psi_coef(N_det_old+i,:) = 0.d0 - enddo - SOFT_TOUCH N_det psi_det psi_coef - deallocate (new_det,duplicate) - + logical :: found_duplicates + call remove_duplicates_in_psi_det(found_duplicates) end subroutine create_restart_1h_1p(i_hole,i_part) diff --git a/plugins/FOBOCI/density.irp.f b/plugins/FOBOCI/density.irp.f deleted file mode 100644 index 4a988134..00000000 --- a/plugins/FOBOCI/density.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -BEGIN_PROVIDER [double precision, mo_general_density_alpha, (mo_tot_num_align,mo_tot_num)] - implicit none - integer :: i,j,k,l - mo_general_density_alpha = one_body_dm_mo_alpha_generators_restart - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, mo_general_density_beta, (mo_tot_num_align,mo_tot_num)] - implicit none - integer :: i,j,k,l - mo_general_density_beta = one_body_dm_mo_beta_generators_restart - -END_PROVIDER - - diff --git a/plugins/FOBOCI/density_matrix.irp.f b/plugins/FOBOCI/density_matrix.irp.f index 14a2fefa..aaf80c4f 100644 --- a/plugins/FOBOCI/density_matrix.irp.f +++ b/plugins/FOBOCI/density_matrix.irp.f @@ -1,12 +1,12 @@ BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_generators_restart, (mo_tot_num_align,mo_tot_num) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_generators_restart, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, norm_generators_restart, (N_states)] +&BEGIN_PROVIDER [ double precision, norm_generators_restart] implicit none BEGIN_DOC ! Alpha and beta one-body density matrix for the generators restart END_DOC - integer :: j,k,l,m,istate + integer :: j,k,l,m integer :: occ(N_int*bit_kind_size,2) double precision :: ck, cl, ckl double precision :: phase @@ -14,37 +14,23 @@ integer :: exc(0:2,2,2),n_occ_alpha double precision, allocatable :: tmp_a(:,:), tmp_b(:,:) integer :: degree_respect_to_HF_k - integer :: degree_respect_to_HF_l,index_ref_generators_restart(N_states) - double precision :: inv_coef_ref_generators_restart(N_states) + integer :: degree_respect_to_HF_l,index_ref_generators_restart + double precision :: inv_coef_ref_generators_restart integer :: i - print*, 'providing the one_body_dm_mo_alpha_generators_restart' - do istate = 1, N_states - do i = 1, N_det_generators_restart - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_restart(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef_generators_restart(i,istate) - exit - endif - enddo + do i = 1, N_det_generators_restart + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det_generators_restart(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + inv_coef_ref_generators_restart = 1.d0/psi_coef_generators_restart(i,1) + exit + endif enddo norm_generators_restart = 0.d0 - do istate = 1, N_states - do i = 1, N_det_generators_restart - psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_coef_ref_generators_restart(istate) - norm_generators_restart(istate) += psi_coef_generators_restart(i,istate)**2 - enddo - enddo - double precision :: inv_norm(N_States) - do istate = 1, N_states - inv_norm(istate) = 1.d0/dsqrt(norm_generators_restart(istate)) - enddo - do istate = 1, N_states - do i = 1, N_det_generators_restart - psi_coef_generators_restart(i,istate) = psi_coef_generators_restart(i,istate) * inv_norm(istate) - enddo + do i = 1, N_det_generators_restart + psi_coef_generators_restart(i,1) = psi_coef_generators_restart(i,1) * inv_coef_ref_generators_restart + norm_generators_restart += psi_coef_generators_restart(i,1)**2 enddo diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index c74d08e7..dd1ed221 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -107,6 +107,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per !enddo !soft_touch psi_selectors psi_selectors_coef !if(do_it_perturbative)then + print*, 'is_ok_perturbative',is_ok_perturbative if(is_ok.or.is_ok_perturbative)then N_det = N_det_generators do m = 1, N_states @@ -116,6 +117,7 @@ subroutine is_a_good_candidate(threshold,is_ok,e_pt2,verbose,exit_loop,is_ok_per psi_det(l,2,k) = psi_det_generators_input(l,2,k) enddo psi_coef(k,m) = psi_coef_diagonalized_tmp(k,m) + print*, 'psi_coef(k,m)',psi_coef(k,m) enddo enddo soft_touch psi_det psi_coef N_det @@ -148,7 +150,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener double precision, intent(inout) :: dressed_H_matrix(Ndet_generators, Ndet_generators) - integer :: i,j,degree,index_ref_generators_restart(N_states),i_count,k,i_det_no_ref + integer :: i,j,degree,index_ref_generators_restart,i_count,k,i_det_no_ref double precision :: eigvalues(Ndet_generators), eigvectors(Ndet_generators,Ndet_generators),hij double precision :: psi_coef_ref(Ndet_generators,N_states),diag_h_mat_average,diag_h_mat_no_ref_average logical :: is_a_ref_det(Ndet_generators) @@ -166,17 +168,11 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener enddo - integer :: istate - do istate = 1, N_states - do i = 1, Ndet_generators - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det_generators_input(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - exit - endif - enddo - enddo do i = 1, Ndet_generators + call get_excitation_degree(ref_generators_restart,psi_det_generators_input(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + endif do j = 1, Ndet_generators call i_h_j(psi_det_generators_input(1,1,j),psi_det_generators_input(1,1,i),N_int,hij) ! Fill the zeroth order H matrix dressed_H_matrix(i,j) = hij @@ -189,21 +185,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener i_det_no_ref +=1 diag_h_mat_average+=dressed_H_matrix(i,i) enddo - double precision :: average_ref_h_mat - average_ref_h_mat = 0.d0 - do istate = 1, N_states - average_ref_h_mat += dressed_H_matrix(index_ref_generators_restart(istate),index_ref_generators_restart(istate)) - enddo - average_ref_h_mat = 1.d0/dble(N_states) diag_h_mat_average = diag_h_mat_average/dble(i_det_no_ref) print*,'diag_h_mat_average = ',diag_h_mat_average - print*,'ref h_mat average = ',average_ref_h_mat + print*,'ref h_mat = ',dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) integer :: number_of_particles, number_of_holes ! Filter the the MLCT that are higher than 27.2 eV in energy with respect to the reference determinant do i = 1, Ndet_generators if(is_a_ref_det(i))cycle if(number_of_holes(psi_det_generators_input(1,1,i)).eq.0 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.1)then - if(diag_h_mat_average - average_ref_h_mat .gt.2.d0)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. exit_loop = .True. return @@ -212,7 +202,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener ! Filter the the LMCT that are higher than 54.4 eV in energy with respect to the reference determinant if(number_of_holes(psi_det_generators_input(1,1,i)).eq.1 .and. number_of_particles(psi_det_generators_input(1,1,i)).eq.0)then - if(diag_h_mat_average - average_ref_h_mat .gt.1.d0)then + if(diag_h_mat_average - dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart) .gt.2.d0)then is_ok = .False. return endif @@ -220,7 +210,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener exit enddo - call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the naked matrix + call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix double precision :: s2(N_det_generators),E_ref(N_states) integer :: i_state(N_states) @@ -246,10 +236,15 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener E_ref(i) = eigvalues(i) enddo endif + do i = 1,N_states + print*,'i_state = ',i_state(i) + enddo do k = 1, N_states + print*,'state ',k do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) psi_coef_ref(i,k) = eigvectors(i,i_state(k)) + print*,'psi_coef_ref(i) = ',psi_coef_ref(i,k) enddo enddo if(verbose)then @@ -262,7 +257,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) enddo enddo endif @@ -283,20 +278,18 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener call lapack_diagd(eigvalues,eigvectors,dressed_H_matrix,Ndet_generators,Ndet_generators) ! Diagonalize the Dressed_H_matrix integer :: i_good_state(0:N_states) i_good_state(0) = 0 - do k = 1, N_states -! print*,'state',k - do i = 1, Ndet_generators + do i = 1, Ndet_generators ! State following + do k = 1, N_states accu = 0.d0 do j =1, Ndet_generators + print*,'',eigvectors(j,i) , psi_coef_ref(j,k) accu += eigvectors(j,i) * psi_coef_ref(j,k) enddo -! print*,i,accu - if(dabs(accu).ge.0.60d0)then + print*,'accu = ',accu + if(dabs(accu).ge.0.72d0)then i_good_state(0) +=1 i_good_state(i_good_state(0)) = i - print*, 'state, ovrlap',k,i,accu - exit endif enddo if(i_good_state(0)==N_states)then @@ -311,14 +304,14 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener accu = 0.d0 do k = 1, N_states do i = 1, Ndet_generators - psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart(k),i_state(k)) + psi_coef_diagonalized_tmp(i,k) = eigvectors(i,i_state(k)) / eigvectors(index_ref_generators_restart,i_state(k)) enddo enddo if(verbose)then do k = 1, N_states print*,'state ',k do i = 1, Ndet_generators - print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart(k),index_ref_generators_restart(k)),is_a_ref_det(i) + print*,'coef, = ',psi_coef_diagonalized_tmp(i,k),dressed_H_matrix(i,i)-dressed_H_matrix(index_ref_generators_restart,index_ref_generators_restart),is_a_ref_det(i) enddo enddo endif @@ -340,7 +333,7 @@ subroutine dress_H_matrix_from_psi_det_input(psi_det_generators_input,Ndet_gener do i = 1, Ndet_generators if(is_a_ref_det(i))cycle do k = 1, N_states -! print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative + print*, psi_coef_diagonalized_tmp(i,k),threshold_perturbative if(dabs(psi_coef_diagonalized_tmp(i,k)) .gt.threshold_perturbative)then is_ok_perturbative = .False. exit diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f index 3860493c..8a709154 100644 --- a/plugins/FOBOCI/fobo_scf.irp.f +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -15,6 +15,8 @@ end subroutine run_prepare implicit none +! no_oa_or_av_opt = .False. +! touch no_oa_or_av_opt call damping_SCF call diag_inactive_virt_and_update_mos end @@ -26,8 +28,7 @@ subroutine routine_fobo_scf print*,'' character*(64) :: label label = "Natural" - do i = 1, 10 - call initialize_mo_coef_begin_iteration + do i = 1, 5 print*,'*******************************************************************************' print*,'*******************************************************************************' print*,'FOBO-SCF Iteration ',i @@ -55,8 +56,6 @@ subroutine routine_fobo_scf call save_osoci_natural_mos call damping_SCF call diag_inactive_virt_and_update_mos - call reorder_active_orb - call save_mos call clear_mo_map call provide_properties enddo diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 746704c2..46ca9662 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -40,13 +40,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) logical :: lmct double precision, allocatable :: psi_singles_coef(:,:) logical :: exit_loop - call update_generators_restart_coef allocate( zero_bitmask(N_int,2) ) do i = 1, n_inact_orb lmct = .True. integer :: i_hole_osoci i_hole_osoci = list_inact(i) -! if(i_hole_osoci.ne.26)cycle print*,'--------------------------' ! First set the current generators to the one of restart call check_symetry(i_hole_osoci,thr,test_sym) @@ -56,6 +54,7 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) print*,'i_hole_osoci = ',i_hole_osoci call create_restart_and_1h(i_hole_osoci) call set_generators_to_psi_det + print*,'Passed set generators' call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) double precision :: e_pt2 @@ -83,10 +82,10 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask) call all_single(e_pt2) -! call make_s2_eigenfunction_first_order -! threshold_davidson = 1.d-6 -! soft_touch threshold_davidson davidson_criterion -! call diagonalize_ci + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + call diagonalize_ci double precision :: hkl call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators) hkl = dressing_matrix(1,1) @@ -119,7 +118,6 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) do i = 1, n_virt_orb integer :: i_particl_osoci i_particl_osoci = list_virt(i) -! cycle print*,'--------------------------' ! First set the current generators to the one of restart @@ -154,11 +152,11 @@ subroutine FOBOCI_lmct_mlct_old_thr(iter) enddo enddo call all_single(e_pt2) -! call make_s2_eigenfunction_first_order -! threshold_davidson = 1.d-6 -! soft_touch threshold_davidson davidson_criterion -! -! call diagonalize_ci + call make_s2_eigenfunction_first_order + threshold_davidson = 1.d-6 + soft_touch threshold_davidson davidson_criterion + + call diagonalize_ci deallocate(dressing_matrix) else if(exit_loop)then @@ -543,6 +541,7 @@ subroutine FOBOCI_lmct_mlct_old_thr_restart(iter) call print_generators_bitmasks_holes ! Impose that only the active part can be reached call set_bitmask_hole_as_input(unpaired_bitmask) +!!! call all_single_h_core call create_restart_and_1p(i_particl_osoci) !!! ! Update the generators call set_generators_to_psi_det diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index 6ec528cf..eba9f0ad 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -21,19 +21,23 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ] -&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ] &BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ] implicit none BEGIN_DOC ! read wf ! END_DOC - integer :: i, k,j + integer :: i, k integer, save :: ifirst = 0 double precision, allocatable :: psi_coef_read(:,:) print*, ' Providing psi_det_generators_restart' if(ifirst == 0)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) + do k = 1, N_int + ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1) + ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1) + enddo allocate (psi_coef_read(N_det_generators_restart,N_states)) call ezfio_get_determinants_psi_coef(psi_coef_read) do k = 1, N_states @@ -41,18 +45,6 @@ END_PROVIDER psi_coef_generators_restart(i,k) = psi_coef_read(i,k) enddo enddo - do k = 1, N_states - do i = 1, N_det_generators_restart - if(dabs(psi_coef_generators_restart(i,k)).gt.0.5d0)then - do j = 1, N_int - ref_generators_restart(j,1,k) = psi_det_generators_restart(j,1,i) - ref_generators_restart(j,2,k) = psi_det_generators_restart(j,2,i) - enddo - exit - endif - enddo - call debug_det(ref_generators_restart(1,1,k),N_int) - enddo ifirst = 1 deallocate(psi_coef_read) else @@ -82,18 +74,3 @@ END_PROVIDER &BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ] END_PROVIDER - -subroutine update_generators_restart_coef - implicit none - call set_generators_to_generators_restart - call set_psi_det_to_generators - call diagonalize_CI - integer :: i,j,k,l - do i = 1, N_det_generators_restart - do j = 1, N_states - psi_coef_generators_restart(i,j) = psi_coef(i,j) - enddo - enddo - soft_touch psi_coef_generators_restart - provide one_body_dm_mo_alpha_generators_restart -end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index db683c96..7d194a54 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -2,7 +2,7 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) implicit none integer, intent(in) :: i_hole double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart(N_states),k + integer :: i,j,degree,index_ref_generators_restart,k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:) @@ -13,8 +13,6 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) integer :: n_good_hole logical,allocatable :: is_a_ref_det(:) allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) - double precision, allocatable :: local_norm(:) - allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -24,18 +22,17 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) n_good_hole = 0 ! Find the one holes and one hole one particle is_a_ref_det = .False. - integer :: istate - do istate = 1, N_States - do i = 1, N_det - ! Find the reference determinant for intermediate normalization - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) - endif - enddo - enddo do i = 1, N_det + ! Find the reference determinant for intermediate normalization + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -62,48 +59,40 @@ subroutine set_intermediate_normalization_lmct_old(norm,i_hole) enddo endif enddo - - +!do k = 1, N_det +! call debug_det(psi_det(1,1,k),N_int) +! print*,'k,coef = ',k,psi_coef(k,1)/psi_coef(index_ref_generators_restart,1) +!enddo print*,'' print*,'n_good_hole = ',n_good_hole do k = 1,N_states print*,'state ',k do i = 1, n_good_hole - print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart(k),k) + print*,'psi_coef(index_good_hole) = ',psi_coef(index_good_hole(i),k)/psi_coef(index_ref_generators_restart,k) enddo print*,'' enddo + norm = 0.d0 - ! Set the wave function to the intermediate normalization + ! Set the wave function to the intermediate normalization do k = 1, N_states do i = 1, N_det psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - - - norm = 0.d0 do k = 1,N_states print*,'state ',k do i = 1, N_det +!! print*,'psi_coef(i_ref) = ',psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo print*,'norm = ',norm(k) enddo - do k =1, N_states - local_norm(k) = 1.d0 / dsqrt(norm(k)) - enddo - do k = 1,N_states - do i = 1, N_det - psi_coef(i,k) = psi_coef(i,k) * local_norm(k) - enddo - enddo - deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) - deallocate(local_norm) soft_touch psi_coef end @@ -112,7 +101,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) implicit none integer, intent(in) :: i_particl double precision, intent(out) :: norm(N_states) - integer :: i,j,degree,index_ref_generators_restart(N_states),k + integer :: i,j,degree,index_ref_generators_restart,k integer:: number_of_holes,n_h, number_of_particles,n_p integer, allocatable :: index_one_hole(:),index_one_hole_one_p(:),index_two_hole_one_p(:),index_two_hole(:) integer, allocatable :: index_one_p(:),index_one_hole_two_p(:) @@ -128,8 +117,6 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) integer :: i_count allocate(index_one_hole(n_det),index_one_hole_one_p(n_det),index_two_hole_one_p(N_det),index_two_hole(N_det),index_one_p(N_det),is_a_ref_det(N_det)) allocate(index_one_hole_two_p(n_det)) - double precision, allocatable :: local_norm(:) - allocate(local_norm(N_states)) n_one_hole = 0 n_one_hole_one_p = 0 @@ -141,18 +128,16 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) ! Find the one holes and one hole one particle i_count = 0 is_a_ref_det = .False. - integer :: istate - do istate = 1, N_states - do i = 1, N_det - call get_excitation_degree(ref_generators_restart(1,1,istate),psi_det(1,1,i),degree,N_int) - if(degree == 0)then - index_ref_generators_restart(istate) = i - inv_coef_ref_generators_restart(istate) = 1.d0/psi_coef(i,istate) - endif - enddo - enddo - do i = 1, N_det + call get_excitation_degree(ref_generators_restart,psi_det(1,1,i),degree,N_int) + if(degree == 0)then + index_ref_generators_restart = i + do k = 1, N_states + inv_coef_ref_generators_restart(k) = 1.d0/psi_coef(i,k) + enddo +! cycle + endif + ! Find all the determinants present in the reference wave function do j = 1, N_det_generators_restart call get_excitation_degree(psi_det(1,1,i),psi_det_generators_restart(1,1,j),degree,N_int) @@ -188,7 +173,7 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) do k = 1, N_states print*,'state ',k do i = 1, n_good_particl - print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart(k),k) + print*,'psi_coef(index_good_particl,1) = ',psi_coef(index_good_particl(i),k)/psi_coef(index_ref_generators_restart,k) enddo print*,'' enddo @@ -200,29 +185,20 @@ subroutine set_intermediate_normalization_mlct_old(norm,i_particl) psi_coef(i,k) = psi_coef(i,k) * inv_coef_ref_generators_restart(k) enddo enddo - - norm = 0.d0 - do k = 1,N_states + do k = 1, N_states print*,'state ',k do i = 1, N_det +!! print*,'i = ',i, psi_coef(i,1) if (is_a_ref_det(i))then print*,'i,psi_coef_ref = ',psi_coef(i,k) + cycle endif norm(k) += psi_coef(i,k) * psi_coef(i,k) enddo - print*,'norm = ',norm(k) - enddo - do k =1, N_states - local_norm(k) = 1.d0 / dsqrt(norm(k)) - enddo - do k = 1,N_states - do i = 1, N_det - psi_coef(i,k) = psi_coef(i,k) * local_norm(k) - enddo + print*,'norm = ',norm enddo soft_touch psi_coef deallocate(index_one_hole,index_one_hole_one_p,index_two_hole_one_p,index_two_hole,index_one_p,is_a_ref_det) - deallocate(local_norm) end @@ -234,60 +210,12 @@ subroutine update_density_matrix_osoci END_DOC integer :: i,j integer :: iorb,jorb - ! active <--> inactive block do i = 1, mo_tot_num do j = 1, mo_tot_num - one_body_dm_mo_alpha_osoci(i,j) += one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j) - one_body_dm_mo_beta_osoci(i,j) += one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j) + one_body_dm_mo_alpha_osoci(i,j) = one_body_dm_mo_alpha_osoci(i,j) + (one_body_dm_mo_alpha_average(i,j) - one_body_dm_mo_alpha_generators_restart(i,j)) + one_body_dm_mo_beta_osoci(i,j) = one_body_dm_mo_beta_osoci(i,j) + (one_body_dm_mo_beta_average(i,j) - one_body_dm_mo_beta_generators_restart(i,j)) enddo enddo -!do i = 1, n_act_orb -! iorb = list_act(i) -! do j = 1, n_inact_orb -! jorb = list_inact(j) -! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) -! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) -! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) -! enddo -!enddo - -!! active <--> virt block -!do i = 1, n_act_orb -! iorb = list_act(i) -! do j = 1, n_virt_orb -! jorb = list_virt(j) -! one_body_dm_mo_alpha_osoci(iorb,jorb)+= one_body_dm_mo_alpha_average(iorb,jorb) -! one_body_dm_mo_alpha_osoci(jorb,iorb)+= one_body_dm_mo_alpha_average(jorb,iorb) -! one_body_dm_mo_beta_osoci(iorb,jorb) += one_body_dm_mo_beta_average(iorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,iorb) += one_body_dm_mo_beta_average(jorb,iorb) -! enddo -!enddo - -!! virt <--> virt block -!do j = 1, n_virt_orb -! jorb = list_virt(j) -! one_body_dm_mo_alpha_osoci(jorb,jorb)+= one_body_dm_mo_alpha_average(jorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,jorb) += one_body_dm_mo_beta_average(jorb,jorb) -!enddo - -!! inact <--> inact block -!do j = 1, n_inact_orb -! jorb = list_inact(j) -! one_body_dm_mo_alpha_osoci(jorb,jorb) -= one_body_dm_mo_alpha_average(jorb,jorb) -! one_body_dm_mo_beta_osoci(jorb,jorb) -= one_body_dm_mo_beta_average(jorb,jorb) -!enddo - double precision :: accu_alpha, accu_beta - accu_alpha = 0.d0 - accu_beta = 0.d0 - do i = 1, mo_tot_num - accu_alpha += one_body_dm_mo_alpha_osoci(i,i) - accu_beta += one_body_dm_mo_beta_osoci(i,i) -! write(*,'(I3,X,100(F16.10,X))') i,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_beta_osoci(i,i),one_body_dm_mo_alpha_osoci(i,i)+one_body_dm_mo_beta_osoci(i,i) - enddo - print*, 'accu_alpha/beta',accu_alpha,accu_beta - - end @@ -333,18 +261,8 @@ end subroutine initialize_density_matrix_osoci implicit none - call set_generators_to_generators_restart - call set_psi_det_to_generators - call diagonalize_CI - one_body_dm_mo_alpha_osoci = one_body_dm_mo_alpha_generators_restart one_body_dm_mo_beta_osoci = one_body_dm_mo_beta_generators_restart - integer :: i - print*, '8*********************' - print*, 'initialize_density_matrix_osoci' - do i = 1, mo_tot_num - print*,one_body_dm_mo_alpha_osoci(i,i),one_body_dm_mo_alpha_generators_restart(i,i) - enddo end subroutine rescale_density_matrix_osoci(norm) @@ -520,10 +438,6 @@ subroutine save_osoci_natural_mos endif enddo enddo - print*, 'test' - print*, 'test' - print*, 'test' - print*, 'test' do i = 1, mo_tot_num do j = i+1, mo_tot_num if(dabs(tmp(i,j)).le.threshold_fobo_dm)then @@ -531,9 +445,7 @@ subroutine save_osoci_natural_mos tmp(j,i) = 0.d0 endif enddo - print*, tmp(i,i) enddo - label = "Natural" diff --git a/plugins/FOBOCI/track_orb.irp.f b/plugins/FOBOCI/track_orb.irp.f deleted file mode 100644 index 7f01fe6a..00000000 --- a/plugins/FOBOCI/track_orb.irp.f +++ /dev/null @@ -1,57 +0,0 @@ - BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Alpha and beta one-body density matrix that will be used for the 1h1p approach - END_DOC -END_PROVIDER - -subroutine initialize_mo_coef_begin_iteration - implicit none - mo_coef_begin_iteration = mo_coef - -end - -subroutine reorder_active_orb - implicit none - integer :: i,j,iorb - integer :: k,l - double precision, allocatable :: accu(:) - integer, allocatable :: index_active_orb(:),iorder(:) - double precision, allocatable :: mo_coef_tmp(:,:) - allocate(accu(mo_tot_num),index_active_orb(n_act_orb),iorder(mo_tot_num)) - allocate(mo_coef_tmp(ao_num_align,mo_Tot_num)) - - - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, mo_tot_num - accu(j) = 0.d0 - iorder(j) = j - do k = 1, ao_num - do l = 1, ao_num - accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l) - enddo - enddo - accu(j) = -dabs(accu(j)) - enddo - call dsort(accu,iorder,mo_tot_num) - index_active_orb(i) = iorder(1) - enddo - - double precision :: x - integer :: i1,i2 - print*, 'swapping the active MOs' - do j = 1, n_act_orb - i1 = list_act(j) - i2 = index_active_orb(j) - print*, i1,i2 - do i=1,ao_num_align - x = mo_coef(i,i1) - mo_coef(i,i1) = mo_coef(i,i2) - mo_coef(i,i2) = x - enddo - enddo - - deallocate(accu,index_active_orb, iorder) -end - diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index 8977b7fd..79599065 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -12,6 +12,11 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s +s = H_apply("FCI_PT2_new") +s.set_perturbation("decontracted") +s.unset_openmp() +print s + s = H_apply("FCI_no_skip") s.set_selection_pt2("epstein_nesbet_2x2") diff --git a/plugins/Full_CI/NEEDED_CHILDREN_MODULES b/plugins/Full_CI/NEEDED_CHILDREN_MODULES index 2f1e40a1..ad5f053f 100644 --- a/plugins/Full_CI/NEEDED_CHILDREN_MODULES +++ b/plugins/Full_CI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Davidson +Perturbation Selectors_full Generators_full Davidson diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/Full_CI_ZMQ/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 6fd4fd5e..47c8fa26 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,1116 +1,3 @@ -use bitmasks - -BEGIN_PROVIDER [ integer, fragment_count ] - implicit none - BEGIN_DOC - ! Number of fragments for the deterministic part - END_DOC - fragment_count = (elec_alpha_num-n_core_orb)**2 -END_PROVIDER - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert failed: "//msg - stop - end if -end - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 - end do - end do - end do -end - - -subroutine select_connected(i_generator,E0,pt2,b,subset) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator, subset - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) - enddo -end - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(2,*) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np1 - integer :: np - double precision, save :: res(0:1) = (/1d0, -1d0/) - - np1 = phasemask(s1,h1) + phasemask(s1,p1) + phasemask(s2,h2) + phasemask(s2,p2) - np = np1 - if(p1 < h1) np = np + 1 - if(p2 < h2) np = np + 1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 - get_phase_bi = res(iand(np,1)) -end - - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, subset - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - logical :: monoAdo, monoBdo; - integer :: maskInd - - PROVIDE fragment_count - - monoAdo = .true. - monoBdo = .true. - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - -! ! ====== -! ! If the subset doesn't exist, return -! logical :: will_compute -! will_compute = subset == 0 -! -! if (.not.will_compute) then -! maskInd = N_holes(1)*N_holes(2) + N_holes(2)*((N_holes(2)-1)/2) + N_holes(1)*((N_holes(1)-1)/2) -! will_compute = (maskInd >= subset) -! if (.not.will_compute) then -! return -! endif -! endif -! ! ====== - - - integer(bit_kind), allocatable:: preinteresting_det(:,:,:) - allocate (preinteresting_det(N_int,2,N_det)) - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - do j=1,N_int - preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) - preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) - enddo - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - maskInd = -1 - integer :: nb_count - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - negMask = not(pmask) - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) - mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) - mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) - nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) - minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) - do j=2,N_int - minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) - minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) - enddo - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) - fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) - do j=2,N_int - fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) - fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) - enddo - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,i) - fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,i) - do j=2,N_int - fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(j,1,i) - fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(j,2,i) - enddo - end if - end do - - - - do s2=s1,2 - sp = s1 - - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - monoAdo = .true. - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - banned = .false. - do j=1,mo_tot_num - bannedOrb(j, 1) = .true. - bannedOrb(j, 2) = .true. - enddo - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - if(s1 /= s2) then - if(monoBdo) then - bannedOrb(h1,s1) = .false. - end if - if(monoAdo) then - bannedOrb(h2,s2) = .false. - monoAdo = .false. - end if - end if - - maskInd += 1 - if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - if(fullMatch) cycle - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - end if - enddo - if(s1 /= s2) monoBdo = .false. - enddo - enddo - enddo -end - - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) -! ci(istate) = e_pert / mat(istate, p1, p2) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - PROVIDE psi_phasemask psi_selectors_coef_transp - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - if (interesting(i) < 0) then - stop 'prefetch interesting(i)' - endif - - - mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) - mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) - nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) - - if(nt > 4) cycle - - do j=2,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - if (interesting(i) == i_gen) then - if(sp == 3) then - do j=1,mo_tot_num - do k=1,mo_tot_num - banned(j,k,2) = banned(k,j,1) - enddo - enddo - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - - call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) - - perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) - perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) - do j=2,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) - - if (interesting(i) >= i_gen) then - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - else - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - end if - end do -end - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - h1 = h(1,1) - h2 = h(1,2) - do j = 1,2 - putj = p(j, 2) - p2 = p(turn2(j), 2) - do i = 1,2 - puti = p(i, 1) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - hij = integral8(p1, p2, h1, h2) * phase - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list_in_selection(myMask(1,1), list(1), na, N_int) - call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end - - -subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) - use bitmasks - implicit none - BEGIN_DOC - ! Gives the inidices(+1) of the bits set to 1 in the bit string - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: string(Nint) - integer, intent(out) :: list(Nint*bit_kind_size) - integer, intent(out) :: n_elements - - integer :: i, ishift - integer(bit_kind) :: l - - n_elements = 0 - ishift = 2 - do i=1,Nint - l = string(i) - do while (l /= 0_bit_kind) - n_elements = n_elements+1 - list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) - l = iand(l,l-1_bit_kind) - enddo - ishift = ishift + bit_kind_size - enddo - -end -======= use bitmasks BEGIN_PROVIDER [ integer, fragment_count ] diff --git a/plugins/Generators_CAS/Generators_full/.gitignore b/plugins/Generators_CAS/Generators_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Generators_CAS/Generators_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES b/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 54f54203..00000000 --- a/plugins/Generators_CAS/Generators_full/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Hartree_Fock diff --git a/plugins/Generators_CAS/Generators_full/README.rst b/plugins/Generators_CAS/Generators_full/README.rst deleted file mode 100644 index c30193a2..00000000 --- a/plugins/Generators_CAS/Generators_full/README.rst +++ /dev/null @@ -1,61 +0,0 @@ -====================== -Generators_full Module -====================== - -All the determinants of the wave function are generators. In this way, the Full CI -space is explored. - -Needed Modules -============== - -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Determinants `_ -* `Hartree_Fock `_ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -.. image:: tree_dependency.png - -* `Determinants `_ -* `Hartree_Fock `_ - -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -`degree_max_generators `_ - Max degree of excitation (respect to HF) of the generators - - -`n_det_generators `_ - For Single reference wave functions, the number of generators is 1 : the - Hartree-Fock determinant - - -`psi_coef_generators `_ - For Single reference wave functions, the generator is the - Hartree-Fock determinant - - -`psi_det_generators `_ - For Single reference wave functions, the generator is the - Hartree-Fock determinant - - -`select_max `_ - Memo to skip useless selectors - - -`size_select_max `_ - Size of the select_max array - diff --git a/plugins/Generators_CAS/Generators_full/generators.irp.f b/plugins/Generators_CAS/Generators_full/generators.irp.f deleted file mode 100644 index eea5821b..00000000 --- a/plugins/Generators_CAS/Generators_full/generators.irp.f +++ /dev/null @@ -1,75 +0,0 @@ -use bitmasks - -BEGIN_PROVIDER [ integer, N_det_generators ] - implicit none - BEGIN_DOC - ! For Single reference wave functions, the number of generators is 1 : the - ! Hartree-Fock determinant - END_DOC - integer :: i - double precision :: norm - call write_time(output_determinants) - norm = 0.d0 - N_det_generators = N_det - do i=1,N_det - norm = norm + psi_average_norm_contrib_sorted(i) - if (norm >= threshold_generators) then - N_det_generators = i - exit - endif - enddo - N_det_generators = max(N_det_generators,1) - call write_int(output_determinants,N_det_generators,'Number of generators') -END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] - implicit none - BEGIN_DOC - ! For Single reference wave functions, the generator is the - ! Hartree-Fock determinant - END_DOC - integer :: i, k - psi_coef_generators = 0.d0 - psi_det_generators = 0_bit_kind - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_det_sorted(k,1,i) - psi_det_generators(k,2,i) = psi_det_sorted(k,2,i) - enddo - psi_coef_generators(i,:) = psi_coef_sorted(i,:) - enddo - -END_PROVIDER - -BEGIN_PROVIDER [integer, degree_max_generators] - implicit none - BEGIN_DOC -! Max degree of excitation (respect to HF) of the generators - END_DOC - integer :: i,degree - degree_max_generators = 0 - do i = 1, N_det_generators - call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) - if(degree .gt. degree_max_generators)then - degree_max_generators = degree - endif - enddo -END_PROVIDER - -BEGIN_PROVIDER [ integer, size_select_max] - implicit none - BEGIN_DOC - ! Size of the select_max array - END_DOC - size_select_max = 10000 -END_PROVIDER - -BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] - implicit none - BEGIN_DOC - ! Memo to skip useless selectors - END_DOC - select_max = huge(1.d0) -END_PROVIDER - diff --git a/plugins/Generators_CAS/Generators_full/tree_dependency.png b/plugins/Generators_CAS/Generators_full/tree_dependency.png deleted file mode 100644 index eed768663d7f287bfec3d9b93f170370955e4983..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 82663 zcmXtA2RxO3`#$#GlB^^N$x6s3t5A|qWLH!oSsB?YJ1t7cuFOgyD?7Ak` zYU#NjOUwCQJ}cn(ULNJ{>EF7f>62Sg+Uq^$muB4KeZu(5lA8LLDw@AZWE%4;8&U^j z#%YdBGhhLC>|K@kf&kw#+DV~fxLHvXue(E5hol3nVYRu&7%(B+BA;e#Z+$Y^d z9h7$DW`H|^nLLj%s^ONd;PCLUZSnoK^K_waA3fshr}0vzj(ghz__KmUn1gzbU$}5VM@Q$vg}vc*HqZOFG18W1^$&RUg~w z|GO3!7mara%CwA+ZA)jCNtaA|pPilk_3Kx>_V)HJEqTZcrgzvxY6_%`baWUVCtmF} zH33Jn9@jZoc6N7ncXlQiXgQF5Xl|yCYdV={Od4oyZ7tatu!ofU1K6UNBN&24_> z%o#JYwCWc7Uz~Pf{OtOH%prkGOG^U-1IfwBtE;Pxjg1&CUhm$$+t{c*b6uA;(*FGU z^B0NN(Tq;q<@@*V9b}T{iZGX@`yPuqWIO+NIXQh-9U2%AP3i0FGfQU7fA&mFOl;0F zc&~LjOCV;tF+q)ASVE%k$&)7uC(O;GmTJZqyy)oYE?v5G?b3P-nA6$#gCT1C4%iWQ10U%Z6ckVrm?Jg0 zxw%bEP37d|FpKyBi_$kkO@iI#(1U$eP;g`6b3@d2iC@2eW4Jr$DG6%WV*UO7EiEk# z4Gs7KS7#^7yo*%lz`z-kf0w1DCFUAGo;Ld@^gjgdFoPU4+z=hbHoW03EpXKKl$Fg(XR^!io@}s>C>lVgpL_E8Qu?%ln2|}nI45c62wtSOD{5ehK=~_*)uHF`uh6Fh^4Z! zG80qWp~AA)uN@p6ZFq%byz#4*m6hv-ckbMYY_O%Hi>kp!3<#*HQN#WBukr6PAU(-X z-jb***#1bl;@Z@)GiL@8_a1+3QIMCHS6%I|rWR0Lz4h?WwHGg67RR!1NqqnQ{m`L9 zr%#{8Y~U>u3tkQi^fWZ5%iToYlxWx0uv4p7UvhS?_WUuDqUdR4WTc>=kZtgw)MZ@5 z|KEjE_$(t>lAoFS*RNkC&!1yI>{RlqIsbfkXz1>K^HR5&uCz3M*2oa|fDW@-c4`BU zj~_oqMn+bz|I)Lxp@4+ zx7pbrLuJ=CR{!+$;6xVruKfD=)HFOS3_H!1mrF)kl0qXfN>}jc(W9%QTbuV%QVg<; zb_)oM`28J@k7p(&QIXirRs7+@hs?}Oy?f$WIXT$vg=bz~ocfT$$H!;ZL?J?(t>#c- zEuGX9%d6~i>U-OX+LWSvLexXl=O+0bROx3#sI7FZl|{i5sWIJ3U;+jD+s2NxG@ z;qH`Wthvn2sD{;cp(U@MPjsS{`(+J|r(+ z-_VeMwt@rUj(59^Ft)jYP=YQiE9>S$oIhfuvd_}x{*ut6S+>0FnJYJ=qN-QEJ~(jU z!}8kNP6aoIrMZ4H9dZWx((YX`ckbPrnwVhY<=yz8_~Z7ydzff*_m$&H&isHi4L+Aw%Zeu$f`)sIIG=a7bmrmUKwI=+TNwGYKN-ljWcs1fZ`*XbRNtIH123bgG;LuRu))Px}o@7ZO zjrUvYdzXK;s;Y=`-m+L1wc?G`bX{GXK^($F?lUcTT~YD$a%a4N^*-h<8S0?*KZX9o z#db}qTPy84aeR3STSo+~|6GiJKqt1p_PA=`z!`q#fJb~kzinGy&>5S3+GQ=%(hx-; z#NQ@gUZ+X8wJo@5Lhj0tnW3RtPIqunkkQGL#j(`hWS1#4l7(btm&R&?v9jhbFK(lZ zs`g-b^P5rf0NM5HHScJH3AZnOenCn@&d)&>X>Wf)y7&sk(MZk5G2C*NmEM19gQ;%Z zxbcLEz{QNu;+h^<+V{MZIYll0gn-{uBn0apBP?I4uT81BNJ`3(4-C}QlB{q1 z2xwTHD0KLH$Be#enN&Z8_QlKE#TouxHZq}$e*$?G1Cn;ckB}!N(e&n%_4Wqnk~cP5 zFWAQ4`qgMr^1Rg}lZM=SRAp?O#LYdhK>X)V!l*A<$XlDc!mNQi{mF0KsOe#k*RAPd zeP%%u=EQlVnuI{$+tT4A^O(zf^2#}rn*1$}&At8R9NV_-@vD^xQ6>+Pp-63iRa!by za*pnv(JxRgyyZ+WxK?Be{`qW$vWLi6_UDIAF8Rfv0&Q2P@*c& zbL*kfv{mPh>q_?XLnNCr{we~@^e^i-FYV%fZ%z5&T+Q`KZN`lglYN&PQ zZc&`%&pcFMRUO+jfdGA1J-&sSKppqDvAK3>xhZxRf#1YL*H)lwB-W)&*F*O6WGEq^ zzOhQGFowbPx6oVLU4Q=QddZU#SUKfCYdm`vZ~lszaVm~*cmLt}A@%$En*3^9T=8U7 z%mii$iIwKb`lj6k{;;rSL`QS(uHLYR@_~lJ)P&~Ejl=s-m~JN_L`EIv;$jXY%*<(C z8PVjBFqw|}zB7_5Ta8@3YHQO+^v=6U*J1`T4MZ`=SZq^-+~{Dnlh#(F+`Fmt0##Hn zVcx6UY^J9$^w?PE_YZFUY9jymk(v+@SQ|mNGP!-l;pEALBFXw8o?XnF)N%TE<19Wr zJB_z#yye~U*L8WL6T7T_G0W_sxO?v&8394Ih&Y5+ z8~(P1Db=mAk`mU5sQK(;6z=Y6FWBW3nSPp1Dlh{u(7Pn3nus+FmbGyKU z7y=>HkCK^ueWg9^8U5lP5^@q{WxxsfvOTM7!8d8+?@%oLpxS3j>gVV3S3Dwe$GP#1 z->0oc9mr0l+`LIk2*}Uh-y5h#K+1BwHQ9Ra)5nilSy?ta>Qgt#3511(v~us|$l)OZ zVXP%_bkNCFm6pqW*Qrz0;orV2`rNGax4OY4(-xuW9IZK;>9w}Rz1x3d8$r@#(3B&P zu)a|{x=C4JK|(=62#_mK=Vdu?fKbEj^e#I31V@%e&ao6%506K(PF(*R04oxADBboO z>kCbOoTZd^#VN+e)1I>}F9(oOscBJ+{U!+~JE~W^x$%q5d61Go7#|;7zG`Srx4KG5 zWqQ|ITWnV|YSpierHmGXe6xV$H$j0_=x`o*i@r=}zX=i5pG1qIdNwbleis-bcU zm35cfT6ym#n&NRxp9WLJoUfLFOKIiYdY~OG*P-5~^ z_u*qH-gcjP6)7JXl{<;Lb~a7Z_E%fo`21&fGH0mBCV=$1lAy3dz&Q%4-M*VYZCW>c z7ZWr_FK&@KkKUCy>fPO7ea*)E5PfiMQAx>}H(te>0=1%)x{UgP@!3a?9NCrF@}u%E zpH;bHV|@&_t}(l+x=jV5=E$u3?S`N^A-=Z$-tUWi!EWjcqrM|wAkfFnp;L!ZzYBTBaN17HE_UR-E@bZzRxbsrz#q64C$H+2O878bM9 ze?Kh$o`GTlI3#DM|9V3ER8vEP(_krsNf`~$xr33{`tri7(HjpQKD>P8N|oQ*5^!D3 zNu&6#ZS3qk3U1SHL+RLQ0pa#z$eHP$chuOn=?8WQzO|MF3~-(6lM=tjy<^A9e8ms( z(V~^LsBuE|UH9=`51%J@K>N%RhI8YDC_=IZ$MCSWS)4dsTfm0T}W6 z%hFOHL(4Z_QgU*i>g(FIEI zfx4s6tXM!yOyA0C=j?P^XD}+M&6rE&{=0tv`USABq@+YjMn*2->7P`B;QwK3qlcOF)Rk(fo_Pu*^0Kx|P`%jyj*O^Ngr(q_(zPxpd zRc7ktix&g}Y9Nf@VM+={()p0eYD^^wsa^eO@8F<0YCse_7$1K4H_EoD-y{T0frMi@ zgZ=&KJ33JqfE>W785-h|-JuiMc3uuAR8|(h>}_^%a?;u>DJ|{l>Z-v#?Jzs^;R7RI zsG1RRGF~5M&dkd@QXZ`R_Y>9@D<_aZozmFT(}Qz>&%-Nfc!kTjP`qau6`!Th2f)Yo z;fjro4GRnF?KPncM%6md(b0j)>gcGMbnO(u{eQPi)vSnAmdr18ACaI2_oDHa0fcH#RoA6fd7Y zA2xne{Ts2iPfi27gVM>zr$T0*?tu_D!DNlqcD*d4&gfi}*C>d=7!(#B2UTM%$`>am zE&X<4!C3T;8h`Z0O`S;1x3DIJhoaS)~rm zVNR1J(Eqv{)lED=N&zIG*=kPB-l9?%r+Ao?IDb$&;*;weza{!}RoB$u0jQ zr0(ifc5#TVuD!dn4+lZXd(pwm>-D2YBd>i$m@^4p-zCWNDi4P<`YrWe7<}cd>M|B^ zM&{1f_SEA-iKG5o8(VADTTxL_bqYKVzk>2XE7)nIyUh0H<1}oJhwoHbo!^=Udr?aybe=q%y0y~8x_~g{nN6J1PE59c9=-svE{os(9on2sAIndBR ztU`X?;?Vs=jAAd1O-wkrxJ21$QJW%l=;MY zjH_{c%F=RjO$t1FkmTM~`uyEo%u%iU{Xr4KC*CD1kxuFf(-c7Q-~Ym~J16yq_x#Wy z>7;0P&7+6;nHiDXCQtzXPTgAnS;s^{O47@so=7@J7sCGs`}AoHv)P=*KGSSBSWy|$N^*U6LJFE4#UXf0;E;ESR+JTx@2;WO^` zb$L1NHnU|c(vUiN8i?B0&u_)|#<63ujl`QxOg!n~QHpq6SokB~{8bSnRhK>S;D&gB zOSt~~E9e-+$Ns@VJKorvpyx&_JS9X$zkPo-s^T`yjO@|k<_@<`79zj9hzr&tDX-C}LUKk43D+uV4)mGu4M0D&;CI0Ky#$PEZDYNk4EacN? zr=K?t4k}7XT`l3IQk!5Po+uamp|aoVVpo)ab;tub=knLDt#NyY z{@tD#mibL(9SziDQ@IG|D39HQbbXGRD_7uhKTwL#L zi!sYa&Oco_so!$qZ*doVhg|KE!_2}n_-JWq-`3TE{cL+6m-6r-@lQ>Qwo$8_*-CQa zF0k>+{kK%!``^6g>Dk`amSvQ;xw(mWWEM`Ax9?vBoK9>9O^RrYbX&}*(`II7mYI_y zflS|WYY$iq;$Q9|{v|iI851L;c53*{*jRwO{KZIpp;X|i=j|$M*p#?4K~@^#ZBY_$ zi-4it*=IUZ;pvPVg`qaO$Xi^#JeQ?+FLtLYA8zdYb8rksdx2B`Gxi{2JSHm>5d}e+FlJ;SrLC+s;a7h1R4-31c(8yQS0zwV7Z!& zwZDLd8;FUvydMP5IXR^~dNlw2yE0H4unRV&%(w%fkPR;xxnuHFd#Z%RYv%AeW#476 zQgpK}LI+tRUtIk7WMpIn$MEl;Kl{y!2t*c*UFJlM2|u|=|DV}UQ`lKf125+0E)(g@ zy1;o%BSS@ zbGkDFTr6cUF+zp_fs)7c1$aK734II1JU3kNw^gEA$#3;VX=&*ri3CSyXC`|3x%v6Kye;<9K&>}`guz5MG&a5+$);%?8Bvjw zBSO93U)w4?z9-M6Dkv&$7q{^GTu<}NHrSYW^0<;-zkZD)jX((W>ZX7CbkeI=o;Eh) z!Bk8p`Da3%ygG^?h}=p{eC0gKw{6?D?c2kvMAi72-)t-m0t@sMjVP8&1phJW*yBKxp!Ep^CBAADOvvH@+nJey%LA(J zZpb0Hg@L}l+qZA)`jA|ew?MRxi(@J+Ru?5sv&gsiNe8%PFUJqtW54R^HWyZJ9u-KC zq^IYKa<1N3a`s<)Fvm$6IQI4H()!9ZB|eXBj`GAav`dTw6Iq33}^vnw`foS5Z4Qgd7hGtuDi7rKRLt1>YrH_78cjt3tmb={Oq)Q6coIX z#!$E3ucwSTYiT)xY|#GjP~Er-K>DJ`aRMPh7p2MjwzklAg$`q4;xoiJkreIhGG0{Z z>gmy`$7@A#H~~p0De`(sjjGC9wt508MPw^dGtlyPtA2>z(DNE7sO13v!J`|A~E4l0;46FctI8 zoe&=^$<=|o423g09q?5{udilAMYVF8G9=%JFm(*|11i+7U(YY50@$88bqY0)>S8p$ zLYQ4TNk34n13PYTa33>urvEnDP*lo?-xvIYoLM^o!2z8AEG|Or0lrJnm64R>oOq(X z0mzsat0~~r6~qB;?J!-zGp}823=NsjoINde_r=KL zCVL0>Q|i{xSL~(xq3Y-gK0d{sUtqjrTIZh>c;41l;DJf{CSt?wJb++?%k=cXT5B0u z*~k3_pt|z&8F=qz%e-LGPB-j`;o!|S6sDx4EIEXkKOxNS)|z9KC&=n3*7WwD99d*0 z#uxYL)2F8M&nZX)FE>uQ$j^N;6EnGf{m{MEhH;m!Zd)w7HmU*{RIJeY-1=4zDx?$u zvWNU&;W`ee{PN|t{KwGxZ~?+&BJl$tdVapa(vE4|hl6nyP-5LU_G5Du z^Ht->?A44;)NaUuz{{sjp$alIH4V?MjE!Y< zBb83NjOqj%|G#1d1rQ(te#UQ5xLmxbu)uU|ZFSYM$~RJFkDf4l>C2Y~<>X$0(ZLrS zJc!#v`@yqWRn&ho@sEp&Cus3ZDtYmhBXQ z&H#XQ#tzCXDne|iuVZ7@7cS(8?^D#q4c8$gAhbY`+$PP%%}qj(=lK9YfFcw{q(`;0 zUAqIRc6Jvp-gF-m{WvgibKVk5koA2GkqC3@#`e6lRQp z-4g21w?tX5qy(P{A#+hKxK<5e!9nK5&BysWLGC&paHtvFCBqljbO{3O<;$A0q6z_} zk)3l9O%qO+FZ1y5bVSQL4aodgj@zt#_(&xC-avyx3I%w<1)RLP>J9cFD{FFYZVuBV z5qvD?(uh#H1;PQg`RdDmy71@na)n|ueST)-v!S6Oq?)PsNx?T>nKeD-tGB)C=qPeV zwX+=cI6Wc$Mpntoo`C@_k5SQM{LC^kGRCdKqN1V_5;|+75V$+aZanuA=zjgcWFb}6t>uLYl;2n$Z0U%98!g#E$FidjM6MuqHKNG&?GKWZ z!6A5~vV4BN?X5z=IKn2%Qo+4@Jv}_i%gVGgH8r)hVP7ymaOOpaH8c73rMc6nt#Dnv zS{xa9#NPf(V+{Ak`nqH^kUvB1xQjR{t+~Ep)Q1X(4&_@_tB8uysx-Mu3yX-9;S6E# z;+FkL*{{l7&_Eto0awYC30n${E&3^4T>0Q?N!5Y4ovR zrj84`M12Niml@Tc3PhftKV5JHxnelj*nWR*pd(f}HxU+i6+KYpqqdHSh(OrcMnyQ8 z#$_kT>A%uy1qu<9>AyTqC6pNHuF1SqUQx02w|dJUMd6OV(2u@ivO!I+t<8;<-&14+ zkU#$42M(&F#@R@AgfvY3PP}ysn~91*O+#~i`Dgk&4u+FyXRs4M!b>HuAA2ajiT`AVzgtJ*X66Wy!Nc> z1t?0CQ)C39i2|YP>e*ftjvb!o)`5y9%K1h5w-S&|W3&;8`m6jZR%MkBdQEU8JT)zR zEHVEY7LDco6gN6AW|Wk4;hqKt6!z@VI!AX(o%W#v_nWU-YCQ;EV*B@FBUzq3tIRhU z)$kcr-Gs|)toHN%xdpTOfUwuS5&{CYnIirIJ=)J~?^Dl;hd0;~<&5yU?_j|n7W{f( zwvV16`^l4c;4FrR&o-FK=?}2yTJG70Y;yzg-c6x0J6pSK4?Z2mIYKcg0F$ykOnOV^ z+afhFR|q}+8?#oOulU;#)W{_Weq;Na7GTh)!llL84|8>{Yn?&hV{R(%Aan8u`0 z?mGFdPwxS}(692nd-kwI))T+;sKoW40!cx-O6Raz>)aciH*;#DqobKrmTTUHVz#RWL?W4OY!G*9%E#bSo8;3}#x`1p{efc;w% z_ntF7TAS}2p+RZxnQpjT$E3Qvy4vL+Baq-=W5cp-+aE+ekza);3P4>=EG)y=HpxME za!j+yT2fcA3&%VhKLy25%|NQl9nB`y9 zIr0q4bL8q?N+TdZ*S4$pZ~Ds6(UJ#2=wYhVo_0BU^d{^uKoRf6dv5>fKCbF`=@R4s z(X1EnXMvg(&dNQ(`FZP&yM(Wl>IcO@q1V7+8QF_@^}q%MU;-pS8Qqq zRL9O2fjL6qAqgL3em4~(4}suy{d&tbgmCxS-u)%`fx5AE318u>Wy{z^0>py^~1xwgrC3LRhdrwD!VoXD-GZma?Q5L3lBrW!frsk zwUd~FDk{i&M36P6GPiSw00j)2@3PgjzBLA9iKt9ie>C^L=Lzr=V5e_jKxMvrF=Nhs z42%nb07Y~qRIwm5>Q`ZZmwF9jLKQp1IswP_-&bq{OgO?}C4r?i>LE1Qcd zE6;k^o0~syQ;n+fFV4?*inz7lwGMjs)YfZ`L*Uy1F1URTfwYs7mF4p}lp$Nc^)xq^ zng9<~XWY%67!tjczKyj{qRs~#1+Mbb3p^18N{dZX{tr@g$p_mgkrF89i5?h4NL zF)``w$vb(j)uP-Dr(-t2>NPFrjvXSeKJ8E)+fHS`!@wLG?5S6azM;^HVbr~LXNc1=Fj$?b`U|bP zNY%eXhU5vp97WI4kI`z^$)kRL8<2Jz>+6N33%k+}w!to%6e=o}qA@Z4YqFJ`RQ
yec~N#>BwPs zd9VNaa^&Z#W^Q;m6~Vgb(!Gvbzyux7PvPWpy2snqTT7z;1RBHP!7V50^UVzv($X(& zLG;wAaLjs|M?6EaqS6^b<~IfG*!x}Vbz;3|6S)ud-4&)&-cUUE?)I+i9jaKrPMDOx zU*uK1PrA1pCg6Sho=#6Y=-(|E3;RAc28#(eY*5F!T%z zwX>}@RcrH#gn+=nTA)*eb*OR5w}`6^O`lPAt50FR0mG&yZt+|)&3Out$9c%`EG6cZIdvqWiS_H z_50l>2Qheh?Ez6R(_PaI+kdmg9=z$t-rl>qf}$nI)tLnk9(0Fk7N-CVkd97MTif@< z<0=V$BDF9W>xwf`WsoDh_TU ztT=FJuDKfT1|TyxR}>P`o@qeob=5oMV~4$Gn;>gTeSLjv>#PJ&vGrd=rnAKSR`(%y z?C#^{`w8a@PdNLz?xwQ%i^2z7J0x_LNKMdM{{CB_kDn})S|{kfK&izVDZ{6zhGhx{ zKUV2|5IerJ`w_n`5k?}nz?`AT7fD;$f3?5l976t437+H^z$8TeStyYxZt_jm?bG-e zeD^N#9UiDTP+nl8b3}!@YsM?sNGCyBx&eXB^ZS51)JG-D7493Tk}wEbI=Tz*?_UK# z&$`ECpnMk)c5oPX>dt|(T&{V0*;`E8#yLVr> zFa^e7!O{dJ^X1FWFaVgEL31?vT#e6ulAn(XC=aRv{>gRcjJS@SoDV~zZ83DRtMWtm zOH}6&rc(4v+3%;MRDvReA=rJ^hAJWgBJ=_De^&$BdN)(_`ms}ax!KEMg4O@@FAf&do7MUlp;w5A9<<}PTsM9(= zohBM^D5yFQ!z-@3xjccOj<`LF9P9IU-o|x;TqXgW)qlz*)L!VMJC(hS54JE-oJ#f`IB^28Fi$2YCxOu0Iy&Mt1@aN@cJC&ejo1VM+;Q(a6e#2ieEQux zcOct@R6>=6BxiQ|^tj7w6jngsmVXNCYj@ST$E$sN3|#{G3)xaaLIU9|?q8Mb>h9j4 zAnw2eg#$(I*-G!1MMWL`{nt_C&VDM)>2xq_I#>iM8FF@tg8P&7^jcV&!O#l`keYP1 zWas7zA3C%GYzvyeO=07>|7tfxGq`c2Xdna{fU^fLLv;OERgb{D^6lHruNsTWD)HyN z&>sLF2`)#+ywFgT&h^O$F9ih!vHLDbmEzPuoVa`Yw%bHw3``v`tiZnz5kU)$di#(v}Q;0t=FW!0ZfV;Od#uEGv^b&6%dnjPYn5wGP|C$Pj zu@c=nU>6!S0he-eE`TpZPQGvfI@-$G8Wi==u&`qfkJ6n?`+E5ABUBxF1_o^(K79SX z!pO)7wuPFJaq0K(M4ug;GU*_KzkK-umQUI1XWEk|H}!?6$jPDSgL3iu=TFbk2aO^k zB7*wd7l+Ez^Hp*2RYYGGmm=`pu>UN6)aW2@ngR>;8)Q^B^rr4^s8iV}dT{n}mlCH- z>RVc9W(kwE?DAzUWkb+&UPzrVGz{R6KvIkQcj2?{-MbeUNYX2H?BZqFHKZ&UV~CvE z`tns!d3XiGLft8JNFXps7U#u8o;RNEjTJL+yj=)Ye1_1m{6 z;^89TlB=KQ<+Xr(#?}`W_FDOMj>u~UXlJCCb>O!E5G^f7Rz;;9*kRpkefJK0Dy(Xq z4^hmL5F`&C)M8Qu;WaTkOV@sk3H0ye)Rd~v5`F$-M5*c7PB2&T z^zIOuGaxNonVIBmzVwu21lY8GeElkmKYS5bP__4|4Q&V|+JS;fk6|`2{8o6)R8pA; zX@M}w{5SUj8=1>A~oj%=i{y7N&rHr_^IA|># zLJsc`63_mO0DfI;S!D01n>RZ+j+{G}rN&PnOwZ0LHs6Gj(a^IlSN<>>-qG_^o?1lfhL<(MV@# z#er4_@Cbm?*M}Y;Jv}{eFkCU&d275XsiUa9Uq2iX^kM4<0<|bfyfi zOG-`##Nl>IOLJmZNMVfQYz#INgNmi|cX-;_4U@){QiH7tq8>!Ru^gx%>Fxk)x3x2p z?%#K4RPmFf4tnuVr$8bFKL#Hex|+beyAhOU(Ua8Ksm{dJkwHZp>bm@M99$E$Mc+Rk zO^GC+$Nt-lFoG_^h*eH=gpH6)hVmTvDl_p!o-vN%e;sS+$l{8DVnn|NCt{t;S$n8z zC`6&0-R{KA;Tjr>W+Yl}kd{X!}&>Eo3w$dfZ zPRz&u3n)f2YS*qE7`RAIfM|kyN-OIC-N&2O=>WIb(JYL}$ST87xUV3VNA^LRZE?r9 zcis$b9u8VsRDcNewo(dok(wnhUTE%nvS%^y{3#}Zk0 z!N2+%lsq==?ekGcI2ac%s{jH5fx3vvHZE(n_1<)Qo0pHZgSlWZlAhVHiQ@kkK6F@es)?PZ|{zq_*UFW zRKvIV`Sa3Au4^u&fofSsSu;b}R0!RmAw2qU#@G#riXJvHdem}rb72MsQ5WO=T?nSs z^sAmQg2C$WKKbB2DXGqP?~W=|0mc_(h4MAN`zjcyR)dsnA)eZPK{`nzJ-%*SS1(>y z@Nl*AeN_FATp_*kC+K#u@B5pek)C$QODQ>rHS$YuzB%F^z6GA=mF0;zKn-QmK*^!_(AC|lk(F?~XhIK8kYif9j{16c|?+~fPeAMm+;7Ta@ZpZE!i$dp0t zj#F8sCcv5hG>B^K@o~K!KeD1b5rZ*M^mzgmOiWBvR8$b1KPd>Y8^CQf3O9>CFL zla!KzFG9(49!f#2!sE_hzh50*c~76xQB%wNZ>|Hiex8`HiK03Py#oDP=+8pWnW&1& zNN=yKkWe^n)!RE#cI^WCIAO~`@7a2BHqu@x!* z)yQYpGPrEaD?IiSy;>d~9+*<>hE&)SLD<5{@%HUoz>K0;IxZa`fXlMxc2`z=y1QXf z+$Sa`BPYj1OM9mJh9BhrUiBDGXn40k#KBww+cyOj6?C(IwzJN9wCuv#1>Z7IGIBF& z=~3_5eB4R%**G%CFoZusKx3xb?Tm~GoN_1{kCKw$wPJ?xWJK+mI8oh>Y_ZqY)Fj59 zQHbY|y?sCD3jFl)g=-5W0wx;LAIKhrs5j1|Dn#PlAzm7F4_K0Z}cR4k5lFhpXu!y=bDbUwx`K9s*oI1Syk~kF=}gR0dI5p9qbDs z+BA*=|NcUpxO(+E{9|+d&*7akQmddr9A4T zKR35VL4bgj)kc?Q{or5)26N!RHRN}=%-S8xS@RmIKP>q-9gCEk;Uv2>1M0D+g+sp^>aOtGb678I}guLPfy4xLA!9B88Q!wn&Yr)M@AA| z!1kHLAwY6r!y$diA(+^=aEVGtw2zG372ZxYx8flmH)<{sZ{?er$O0My+`ma5?GPNEnauj*6vbP9)|yY z)`dSSa5&_C0LChSeoO3dY-fCxC%Tg_a?qaS7yN-1*?lI@sOjj|;HLf0TF14W%!94> z<3}6bd*_4jR$(lfvhoJ3dFW+vx^(GeEh_-xND&|~M36BUH5Gl9#D;7SKC+NYhXjhC z;o%|Md)1N4>txzz093@KI@@AoFXNx&J222uxbv`MZ@`lazz;_U(O(&BA!ma=k~tw` zaW9?vh`zzW(Q1Dyb8{a^%qXiT%Eb^3&`Rbak7fCYd|gU`fvN%gffz>JyMVsfq9RGmrX*zr%^k)Oc6nML5~$~3y&;;zUci-; zRl_dd53q*PLFVAW;cEZU!9i|VDkDif*hKaIJ^mmtzvcv>F!mH2D`!jWk6gdL;w453 zNuJouFDc2a9*;>5IQ?Xdk{o12=Tr zX*X}U2Hx1waFOC>=)6vjah}NQxqX|RD@GPM3J#4)4#tyXg6<$8u#w@Kfd#f5?l-LQ zAO24Ux;fo8a^po~27z`u>4sqK^aK*_ikLE+5lbF8;dF=uiRiCk=u>aC3**r*3#L{oTJ3<#h2eV4P7 z69oZ#^=K0?jl80w9dmzXpa)x6XehQlFIuNj6{8Ua)eo-3CGs^QFOAAGukg;@yKlGW z3%9}_a%JRA8R9d#O*Yp?w@fr5sbw6A`HK)hwE5R5FlQaYymfqB!_u2I$(I4*H#If_ zv2t;8!e-j^kN6HDaXU<`X}h{^nP}05f<@qBVOe-py^)`tO*zZ?(Og4=lrdZpAJi8W zB;r!C3_Xm5fE3Bw8z_A8_;DtXWnx=1)6<~sta&Hw(Y67Dx5K4NQB4yFt7W7rwiO;n}NO|)<6*#qrOTXIleemk2y|!?kHq;v}UaRxD=uJ znQEtRfV*2_vYA*FxH_B_~? zViY0nll)G_45{(gC@3(1sycV+5;q42+TXR$QtJnD&4bj0_tfa!k>8O=gxR@v?D#V} zOw>Vdy*SjfYA{)LI5vox^Cg#?I2iTFsrHU;lhdZMmrVNNU*viF>_P!vZ z4CdzK|7-E;Ucj7wn3 z$VtbMn{a3Ih*GPsNRd~Hfv9eO9u5KI$m(=J95%fgVrLA9QcbfAp%7t>5_~Vp3y=;w zhqd78x|ogNtHhTYA0Ob({{(;-G4`CN9MFl~3}1lp`MxV}@gM^-!s4GlA7}4t!@#QI zNmI$pE=$sM1hx+lYxBbuI#LoCldy^kR3E6<9J6Z1du3%!yv1*83P1&?nvFdCzu@hyc_WSjYP6P;Hr;r|oawz$K?8bqPh~E7cwOG7$e81*8|=zra4O&y zifH5uKzrTVqsPO`TV^pIaXv)EFoSrOD}WZKLo!{aqNj*NOE05WA=)I4Vr#_m5}b?Q;+xxlft#3H`n3wI5u!C07n;g zTTOut^h(z%aOl#Y`A4>o;VUs`6~|ujLVfS>LWavJ(}2yv4J8-kdsK$(sTAS-%>j4l zjU;ft0F!aCu_`WOgx+H7jPmjUJfeYMc=|L9+HvrC-=_}MKE2P|*Xk?(c5a@ifgPekb0xUn$-7;Dxieu05T>V#*AvW1d zqj+4*Qi8@MkN_^iO@T4|-@`*%;gUz)m=d7I4@i|JcMhH!R9$*XAVy`~@ zc3{U~B)#;NlZ842$~gepUjR8wfvG)5AFZ(u@B|$DK%#H1PJ|^_ZN;@u9pH?HSOI+# z1wAwgxGiTS;jk|@Llq&$vG3f~>5*{M=O~{Y0L~61enLfwhtVL9!h5?FE3A7C9V+m@ zf02&if%zL2r%k!^zk4~NfPhg#z?pW42h%b$KmWBEh3;ipZeBD1OfGoAiHl2#?|9zR zgG$m#&tP55$T%#N2;Kpvc3kLT^Cs*KwN$=@2lA{Bc-ExctMgAE>|Rabk3#VK`X>&4`k|- z+4|||nZqM>s@#IXuHU<|MIN+%i2el+7?H9CJZz}^)8WB{=_dFB{x$D?Ao@_Z`tS%E zwCk0@VGVWx4~m%~k|3$znow(1R&E3wpA5U5ix40$|N7}uJ?{=k>@?(v{BR$;7Jk8# ziGoN~h@AZyyN{CW6fAj!lbL1P7N_J)ZV#=ss8t2ml1LHypo ze;;ipZ!lXZHDPeMjrE5hVr<;g+xvJ;0=I(YUJQKy!mvg$JA3*6qb;8UisT9=k` zD4)5d%@KAzzRCxzKDKj=3H*<0gWRSk{}I}`upQ)vws)}g_IPQwhI6q?$KOM4R{X z=WO#1@yAQA3==`u=7vw_pBu)c;d|gZfnrE(UIBE=N>vE1O*104(xL)}1`jV0wkswb zoB}S$<9Dj`T;IYth1MWk@D)L;U?DGl{+tei2qWVo8OJVRe?QP~SZcs>T>rV5fBka( z*Wv&V^y@fCTc^*Qd1q6%nH!{?0nG~SeRx1a0gM;2J_ttilxRegws}hq4jmV&N1UFO zhsm(NH^%a=4SSCIp@0&2oX#r0{u+-00NOyCC{c%Z%r-xD${k1rrxDT%wk7rso_3_F zs*0zXj4YC|^C3n+gF#J$VikIpP+|*;kzKoXf$)%(l#GAr*%eSX{st2Q5TewU(LF;> zT8j+_eh!;THX50bsk^uI1jW79{qToFBoG#E#?D8~Z*RX)OzcO*+8eU$g{KI2u(HGL zIXFb*7pMYYen&p1vC6+EcA3!ATfh$bqk2m`g&meuK~KaWo{|Ix7i$4aWZ&hb`%-pF%E~rR zU*k@3o9k}`PK1$$*NI@9?d|PIw0MGpfdOK(ATu?Fiq%DP68a2F^4sKOWMCkgM?ddi zsZ(Wx`W_eg6DB56PlOSr!<(b2zp-|WKk5HL)n z+|{vKGCUH2m9+%wH15LYECWPph+wA?){Kn0AV~rNAOu0Dg6x%(lLPy~&&6%G6Q~}v zeSivc$@vKagE285p$oxb(rSgFFdJ z61!6HjE}>`i{%g|F|~Nw*|({wSMZF1uXt>b@;M7#4(MgYKONK8=TY>S0~$BM6Re^| zL#cy^iw+|#wm!ZY5E#m2qL4w*J2?w&{WRTJIID6)Vf$8APJw}7dAa7sRrt{J%1)d) zgI0^{V1{Arc{asqd*%_lRtY>9h@5Z&Vcqq_?_gWNpq8L3xNX}VRO4?+c!gQ_NJu!> zg)v|Y;rqaw;8AL~Ug|ss1i;oLVsG|C%F2~s^hVJS1bp6GklrjI!v$^o5_DZWm5+p| zQ}o+^oQ>~HuqgvG_WohwqCRZRCz6EXec4V7GyQh*GE1%oYTGM zHuKRqB!v_eKdu77Uu|-u057L~7I$*eHxhg2o|&Z=6vWnA4-F5aMKJ!(orX!*bKkk% zxdgRNA|K9=R*$x|F%Z(y(~IE*xqqKC^5Qr^J_!M3{kH|;00OYec9Qq8^Yz}!<3V8H zDn;0D!X^VfatD2wppp6v6FntSUWe}z(*v6&nvY7BsEPgHSe7x?b}RsRu&+)tu|d-8 z(Be?;O@IDONUFVDq=8`9kN1YvbVunTsvJvK^v_u?rZp_&4` zN?y#vUHZpB-1WiWhlg;1_}W-~sqZ`HS_UbWo{=%^c@O9v)5y}AjOgNEyU&EJsx=B2qh23 zFgRsoWENqDSLPr)E!K+y6GkNvIpZG=0(*dnygg*LtN$0m0c|KNJA2Q_h^tm>~?qkI;HzQX>rgGXN8aFb#+svrJ_mz z%w4vpR}I%gGP@Bd`h3JUmVKQ62WZ+N(ZUH;Es0w-fjB@DKpHQvZ2$ArC7tv-vL2sv z*Q4h4kQD8;jL?+YKViLs4%JjsyOLDb z800;d+^Gx3JYnXluPNlS=cS>xurGFf7;wXV9t*WZp)&4qLd$;MBF`Z~Idx*z9@1y>S zbFzWKyCx5N&Day&upXuQ-tiDVuo8CA%8vKZadcD1YUpU1R>R(w|4>>(! zLePc9l#8Es4>X3;07UL%vI{Xn?!$K6fY6Q`D4H3bs+Ebou~=G4iseJ{l=L(NVGzaK z!y9s<>>?mLzCc5Pf5RuPs*!v1^z`J?SRN9h4SzlX>z5Xt_N`NHQ@P)F#$L0LS~Gsi zmj*W{vWGcfw`{3=Sg?ql3BN_WH|%!E3b1zR#Nx|A6vj$|n@pOdYfde9*eOfLcsY~| zZRG@rK&qL5z+v{@GJ9@3I~SNuTz~+>K@(AbqUO-#XRb=)RIO8ge0+`!HQh-sg;W;& zo=Qyoa8)*GJ==s5;YwqW3Gnc1I#yY5H_$HLzAYF{a2{>=HF!#$W@TR_ND5=a6`;ts3!7vNlTU0gW$ z`&?*7+$}HlgLQ46xPMuEAAQd7Hf0od>>;S&q?{K3*Hr ztr~}4|5Nhoy5?V{xug3}rwHp-T(L-Uva-yzc^z@lH+bJX$FFVnvD+uMEh>EUp6rol zAt53|x-+k6Qg@rx%TZa^!5OeX`pl}mYANL?8UuNN$^b>?)x(jh0 znokEzZgpu$%2g6MF%gytJR^vp86#S?Am@p!SSTrnD89u+ASjlFI8G zzu9x=cC*KHeIsCKx%v07ZQC!%L3PsNs|6Brg3Xq|^xSDVR!zAMITtQKb9FrU*&h0Y zgsA+^9c61pTKZi6(V5U0HjsU=u)Ibq#pxzyW z&-XKkj6aha{=|j+S!A_l&FGJBV83n1D2Ejx+mH5Rw)yHq;1k`?X4vQy*k`gRqK7Do zypd^{X!=^2hvs}5r~&hzH2+=MKW?P!sdY`(DT`qvxEqcI?z3dYmu#-{#R&q?+hOIV zw{Sfmt~=J6S$53me`-g!S$ROkf9C zDe9V=t8b_s%-MJHr1Mwp1Z52kLdMnHf6NiX0Yu*ZAiwX~N{tAQxNFVd^=FA6`dOMA zbZ%N#!6_EsL{G%pFV2MliR~XIwqeau{YO*ES0FZqfqd@VI8g)7W}@A@FT!R{un`wQ zs`*i~aH)^Ke+axz>ufa7YiZDRr7kRWeeLifZcw<;ZMCtHjG3I~q6~S8LQ>iE*#L|* zRNHhmW!wwVtAe z=4OzhjJa;Bi53h@YhE`kymb+)CO8=gA4^G`%^bD|!6ulnv>F#JJ5) zd+(1|cx^f|h4d@vCLg(xH)3DEGjYHH5S-9Th(s6yydQbfs{4Gu5gDUNg~4Z<&;HR{ zTrNiZpPgNnQ9Eark8d217e(b(OS6 zJSh3aFG9~2CZI@!i0MmXm2`c}D>*+rYXMpR19OJvhXt#R1O|Dl5w zIqXhUeo0A|gKpx%d8^`Oo}brTFkL*-MYV^X!ne>VF#{%t4l$@dTJ?5t_vSi?@ZVqC z)NU@cPg%#pwfgwsWM^HSMB>LcZ)DnDeY+}4!A!UqSH47%t&00ww58+@EA^S4o{%a( zahgsWp9|&!*$3wP)ST z1S{?j^SoMiSq6K1Yl*yx6rd->SB?%`qh6$Z2i_MKty#MklzjnZ6eTI@E_e43h`v;} zlGY?t0#_2ZNVTNd3l{XA>FVaDyvZTBgQ%e@hk$;%;e8^i>Ei4CvI6f+Fq4g*Ef~Um zI+yu9bV?aSZ_(zgEcG3Z0fB*t=}GfDT}^xT>?tY-aHsAisld^t;onmi_nBq9*Y+;v zp*kL{jCJWcu|PT_UAjM2VZKO2NNR0u<>A2}gx&N=A@1mrBc$xzZ~r_M>vOrb_6c2 z4YL<19j%R1BF##3-OQC&W7YKXT zw~LZ)eLHKU`)AkrRyG@M7(HYY^fvIh*sf!`X%1NPz36Q{#AWCECncmg9>D`_V!08>X~v`?_nY zq&Spm3V>ZvUlSq@jNIawBOm$4X55J~7w56wYkUd>b>8AU{VDV{CsG9|@7V|=!+qYo zcP%Z|moLXZJ>RkV?Y&_l{JzVM543K{f(6fB0quorslEGZu99cP|8N27>cl3$yyYsJ z(Tnu}SB~mAJ^T(kxu5(i!fI-q`9l3omCeC)bz&;K;e7X&9U@T1L%%E*SwYYZRGDQb z4?c9r4JykC_$Hh@GhJQ9M0>}tb-W**D?`Jr=YU0IOHcl}*C@6M?1J(oQhOF_Tm%r( zzyC6f{`MJLEd=F3F$H#Wd3%A2F8=oK8+Ill%zopbmB~>SG-TL*%kGMsq&1V|Zsv0c- z%)xy)^ucGUtNqBb1%l;J{m$q*Up-yj_m9tBgBUK#IdS45C>CT!*n%ww=!{B<5K=2o zigwJ&pyz{s=ll!nP8=WD62-m}691%X+9_B!t+!E#PaQ-h#9@_>1!1)hehXs^k2Qc9 z0E!W5`;S|xA+nl1dkg~uiu+!8pg**ja94=4bcw zLE3@2W@07|3!*YyVimS%A-G`GsH>|7?NK&ATwMH}aLhhrOVLE4kX~>;D7XBon|>54 zR8L3e1yTTh7_grrsRIZl?q##!rASAgG;!NDT>nYHSAh<%S_R<`@_6ike{;5uZICJj zL*%~%jUth```|$~7PL4X5iG#uGdclic9|@!BuhcGJ|awYht<*`EOtnxS(@U-BKf`) z2DlS|$zkO0)JTE8A&zK^)p4qv`NN;cUpY3o+-%MHX; zwWM#KKkpv-+t}j@GLhvEV#UyP5LL^5yG|HnUV~`wQRH7wy-5z~_hGkV<;Yq&Y5vHJJ~MiAI1YQlHlCG6tAKX_XWNe z&@ntBc-AyRDFDdHXmWx7qI*g6tZqqW9fR{hUx8}W_I+r29gCjk9h-vOl{4=Cq{Kmz z*0>(P;UXx2=+iOb{{3$cb1ntUAJ~TNi`$69&ubPTQ3JVAe2^dAzc00MQ_d^%@#Ed} zGsM(=P5N99FEa8|-S65$d^GkrJM{U#e;8yg+4h!1}s zf5XsFEy*sQU_@2Q2M86WHkw%a*)+BxBL|yNfu}h{zX({m)SPUDi{lYCb{%@tODgKq z+rNh&2_^m#USPw(>09;;N|fK<`Hz6pXU>#({*sX2dgj$&9&PC^j_vFA#7RDl>v?G$ z5&YF}Qd9RNtgr62gThfg(u#9=D{#vASc+$lkV&w)^Gn8XWb4&lJW2kcX~)d%i;z%) zOk&W0xJqfD$_}dpMHQ7%n27=|+{hYbfB#bL!1>04uNF}j-z7f$oh8a&{`zaTUH+<) z`Cd*GYb-3em^>i21+y{txpbP_{=_sk<+;3XT3EgGjC_^*Xd_XT{WuS#4My<$$& ze*ODT4j4=E$-d%4o}1PgYT-ZHllJkwQhpU}NtE$Z)AcGs!`XhH7x)DtfjV_6P?dHl zA{^|v__OlDh%nf9o+!| z5jMw}GiO*e#H}-D(kr}MKOd8cYxfJ^su*-FM*FYv?;V_+s6#(fd^Q;G%A*|QTiiT>eQMoeY zlDsqx#?`A^c1ug2!M(HfRzP3P>!v<$PPo|~ zzB>VQj7$CNFUfo0P8IWq?tRWuwkdOf8HyAsy^dldTH8#+nP$l=C-F$FoD0<8zblF( ztE&ng8w{t~q*I04wa}Q#9{Ki&WTIeXZW;Pn7Y|9*on^5~r2afvgn<~kryk#wrb(or zkdE7(xpSx8;kz|k)nB%>$d0*HSGRQZ`rL#hfsBkw8xGlmBhRoIK|P22CUpDS+vn1z zuU>tIwk2<6hvSFWrwu~`AN5;jV{7{d?Cq}3Uq`y?%-Px?ZuC+AAv1`5aBQLk{l4DI zyl9(aA)R?GCdy-{@gHwrzKlBgkIp*p*9BG=3OK!xKw_0|5UEUqMDUYcGkzkBkM64N z^`1FqtPwi-dk~ocYx{lZ>G-_-tmnfO>xf1&?&mk#v#s~$?I-BNcbqrxPblN_PAq$I zIU%URM^*L{X+GF9u|>w|JN>gM1QA+3$2A62kSx<671U?osq}<9EtO96NK7Zk#lZ+` ziNL~jk_Q)f7d)g0LI(k(bC94WKRaQ{7U#o<4;`u;G9Jb+)k&jI4}5ko>8Hsy<@K&< zz1(}M8qY#R*+m3q%MU)EK3k8236oN$9T*|cw)!bewJ})GL&0l>kyWqr-Nc7;iSKzt zIHhX<(aHD2&2pmutLYC&b4m9}8Gd~J?1|6){6gpZ3ftTotc(`Q;-Td-YZkm}<|Z99 z?C77x9=y(+s3S+-z-tWp(JmG_HaZb#TaPl4M?ovb>;9!2`K@e7$T{fJ(58C)x+CqR z_l4Et@}*(yXdV*D%^PpE5*_@`E4K8QZ#*}|#s|%2Vxpt3?*S)`0imjW`XJIvu4<%b zR@uu?TF$elYHu=THyVKJ-tVG3RX1VdLL_B|hUc0!UjeE8K5Wwpk{_CJk)x4xfs+gk zlmLTn+&In0Pc1{6kbc^IMatmM?4XE_Pxfj_Ltg*6T%jlRblamP*$Bie!rGYD7MMCm z_w4kK{x2|2Y7MV_tdvnPD)5;FUpRiB@p5}+)j3X^hRUjxI-aM1h+kf66pI;D99t7k z%(}-DGA5nh@Xa97>dhw?;)+OXpm-34}>D{jMWvW;w_D$OXs@6sCP~szMmR zh;zr;5&BW~#djq`&)i!Wa0*u;3bVie?o%AZhUQ3^_I!9o#VSONG{4u9>4w|`A3(4T z*z{+{#r`8nM2^od`Aka~j0D|dR`rz^v|_Jx?zR zq<)9BAkdAvLaS7%bn@1Yrw>U5d_+=V8-f0W#~HiXvk}d46-gC&y9^HHXP~)|ms(BB zj(Sx`%1nbnW{1%S@42zlMH!DQuzpg4b*olIUbH4R!iQF zpU=Xj4*E5W0bH{d`JSpWU#9d&PgX3sfY9y_Z$CKtV*mS;fUB{Emf6BzMloPv>rPi$ z4XVHQQ1PIGrJWtD?=!{luB32nrVu-J5!6#)U*OP6}Q zh3$m6pQp?>>)Wg`V#rYc{y)*z(}rn0+xtQW>HMVNrdkSVc)Dndg?7i(16#Jq43vkl z3&J#Q+B=q8=c5z}zYwyiQ3!O{;0gQn+_AH#%Q4UFH(jNecG;;@BQ&lg+cjnQP55-s!n6F0v4_;G}7S*!{{;_;s0WoqD8%JM{l|>&g#X%hvbQ<6YF>oA$C=ZC<(ho0!=^^9tjq74%<3ZHG&K1j@%VL_*Q z==9yb{{H&Qm$)|dtY-`gB_n3d;15xERxNc;-M6n3i0>n7m9!u5fb-wYL3KyD*qIIA zmcb|E-$k(KZQa(aUtbpb<;sm4A87AWBXbV(uCd4SuhDeO{_4?FQbbE*zeOm?%XJF= z@m_VK$dm9NzXn|oh*HxsTm##?vj&~_etk$?d(=QDy(KLAQ`Wzc}=;=&f-?kzk}7mMLGWG zpHMNz9E;HJJZ!1#psUPpg!*;h<@QoY5S$r-lum-s|Ia^h2t$E7Z9%ulv!{k4e$d26 z|1X`VW9{-W@4H-6!w=BG4=$On^wJ~t+sZBag_SNem4R)=fweu?^38$xuI-_MqwacmNVZy!fC;dn7iqu_JUOr>nqQZj=d&H>$h5Sl?e|J`{KW(ld3(r3qqbt=K$k!zdG-L-Y0LFLL$NX=qJG{B&2o5TE*nOANAsO;y5z# zN1K$-f`L6`j6dwGGaxwxFkZuT+wbWFXIdcv%b_R~;(mT2!`p^_s-SA5N zzzeBLqOl4ksHsK%oEW9r5s=A>(kD@Cve_)kL)%!saoTEBkr)e2El*ZVKX(Wkaxy9&-sv$_xT zp79;nAKeVwG&dK~Ryk|aaLl8Z_LI5CtrkDcHKdqf@Do9q!rh}v{C7~kUZBEc&k&7R zjwRj|;uI7fzs87&dDSDzIuI(wI7?>qFWvV&q;Lrp{KtOr3h7#gtqZY+TN=<-@Pg znCyp<59zzmymGDiDS2{)(!hb6h||d9++XjpjOdC#`sJI*^er_sPputPKU90crf&i} z9nW+5i~TRbx&f8qs1rJia8pIz{{H7NU?trTr)6~iSwb@DLgS~l>(`wmt${0w1D}I) zgyRe9@he7W(ZdyErJ@qHZq>N$L0-t{jI`8gn<|m{tEjMORt5z05=c(JXk=k(dY^H; z!!r*^8AQr({u~rz`Ys${oLMY1L0Cgsr`Pq3jVJMZI4~&0#YEKhoVJ4&7S{BRtNQfy z>zdW8lc2WWy&Lt*{%3o8-Qy9e>USSMmJ>Yw2Hy5Sg^sybQ;?bR=VSK3C&Uw`sK}p> z7mO8|z_JSuJil?iJs&H|F~*{com1#;XrXzlF$lO66FF=iZ@1jqPuDQuy>JMTjB7V1F){J)33`YJU+{=65hon9yABMAFG74G#Xi`MZdkl&N`;KT<32 zZNbnPREQu+4Y|5xKBb1htH-8;N@u&Xr-F6%Y|%f3A`x}9sP*5c6X5T$+i-yGRa19t z`=NpYVF+x{l?|&_jl{nmy8tv_;Mu6m<1;79q}LIvy2-^tn*I7cd-`zFOMvL{P?fa zr(LwL-$rn@&wTY_PD;~Hjwk(BuH4q`z-2rMkui40tlQ+V!9?Ilgg(%q)xy`chICLw z5=n=u)VMT7QY1`A)U7yt0pm!3);@EbzxYho!tLliLME(Ck~5AOj*7O29Iw4H#U5^7 zTr`b@e_YID1V@!|Fv7QJQ9OB-gKpNrjJAjNJLcHFof6?KO(&ud()F{u94f zII3>1h7hAN=`+LzY$0C06o}&l;rd5a4j>` z-%l?84{_iI7*`>dm<~inS|gUB>n4A3yP|l$Ctwk8jubEH>azw6n(&Jkx*>$wPy?uv zF0vXoNYwhYIL3=7_js{H96l|)3lPRH!vCS z<4}dT)oa%#Z`-Chb>0+!6E^geM^X8nD6Z$6@|rkadUfJHaJ5U6+f)?{#Z_3LFx9KD)exxVyr*BcyV_?dte?&K z4o8WB-INfMWp?$fEqkP0;8rr5UnA!nsN z5|Vc>A44Zt8MItcxZr=uNnJAkBv?ETlyjVB6Udp%qjbf5Pw|B(WVXHg_4C~+9+27b z*H;;mH{}tr*yFeK(iJyO8XY{9`ii~EJ=XQ|^zdLlR&<3oT`xj7*`9D9NYEVnb$2T; z{SM~)`h5hg3QEph1;-5Q1acD&MlNf|mUH@5v&DG<0#fk%1Bkr$A+|6y!g}}^3>#LF zI8Y&OCY>liX+E=OS2qR$E2H|e(wbiq><8z}v~56l59?HNKj?v6&bKcaAXprw6`%I9 zng#e-!|}qo|KS4s^J`Dwr7Wr@+7GAad|hb6ugttg26=%M3xxtJC3Phw{CtcRds(OQ zjKUwIX6~ynYvxRNjlY3cYXJ1AQ)QE?Ia?II_0EY;AyLq*k*F%pB3t66(ivdDpJ+3A zH2DKhTNuN)cP~RstgR!Hlcz&Wxi@go!P=I4ZE$2@3$ug3SNKqKgJsj^gI*Pm(-v3h^Owa`eN>A%iZ_{u6m93WT87*XiRW#mg@FD2z#>U^O?- zs%ivyAQ4nIzL`*5_HEFSsdU9o8zN=O1u1vFYE6rX4wKLXm}z7xCha#T+LTH8M4g zC#H77KPRo^xpROge?IHEfwQdgf(PdpWfgjXO6eJ`-oM1U6Ce{_l}d8}VVezyWX_z} zJb`zSlf&!Wa6IxTqMicx{T%?TPtUJfM7PGLdpUO@v&Bk1HbB!tJ$4K;7@c8E`G}k_YtOMq^)*?#KHS2;N^TcbXup*V(7}R1q0OCVaWh9Bp9l4 z&7ggt^CA(jAV~n!SDKR~A(N!93HTeZ>zf>d7A*-`^qSK_A+YH~D?~>Ys%KnP#mi5m z>sSiXS1W46Pcfk>)^Oe0we>A)IEy2LXpzw$1NWxK+_z7kid(Gyv3tNn5#s@G0xGcq zz~|$h)!eVIFCg!Mnjw9%2400v0lnta6PWYD0C@Z#vLpIS%x@07=e!6R3}+Czv#?J8 z{+l<3AjK}<`VocA%f4groub`~XceO93zcy7fHMgM5>_2#fb47ly^hs`um=kX#!9GH z8QxY%Wgz0<4O!RzFc}*aU{wi;sN6ktO}J5-wQ=7{(QnZH;S@zL#$!4XCh^Bks1?ge zZuQ2<$q3lIb^Yk6mPFAY&>s8UVit!ybCq39lX)Ef^=;v6Se+GG zfP4U_=y7I&BeL;Z=ek6fr5tECDiqqVYNn*f#D&JbT_44NFsclXM3F%r`fDmzUKdYl zh5dY?{SO*QB9a&%zl-Le)eQPYt-VCkTG?UjDtAM2^Zs(eFeK_sHUs1cOaGyba?=S5 zWEg{rlrq9~hRNCpSb~azi<7hSzi;1S-a~cAJQX@maT~=BU%WVR!h`|eSJ1IXQ^bCy z3GQyo7!b9mXCPT|F#qCUWWYdV^CMoP{>G|(PtS!E@-2n* zuByN;1WuPogph&h3&K!@Nw?m}tkFx|m@7-D07tc7 zHigz8EQC<344F~@WcZBlfKx>u2N!||RaH|6fxydzo1n6*n!UEyHE{~0J*cujd>34^ zr<@$w7SIl#Hh@D`yhs!?8N)>3gW|lCEh+1nJV2d(2W?s!T6k`j|D4zXzX3Y9n_GXL zD)+^Q5X-LOFXtWWpmu@73n*>LeB=3Ya!J)Ue^?PBn>%2$AzA`4Dj? zpMHLE;}SnV{&VUHGu7;}_E&pI{hp20wN@JZB8@@vSaiY>CAVWI5^F|5S3`bDWp4hl zkKzO;J-}8YP9=ECR2MWaP@|F8w6cD_Rl;Xs9&#yK=WA}I*xT$ zuabNPgojU>bqUus;r3~+Lk&G!P!K7xjm^cA@cS?#QJ&!Lq6BRMy*&?&$UpB$5@H@Y z*Bom6W{TYPUZVWs?*|zB+A4ZL=wr6kv$-J21~{!caXrkP>Xeb8;#gT zkNScSW11ONQ=Qm{XiSdMoE+BDOFR<)~Hw#!Z`4E#+1iJ5kr>)~3@;R&(HdVquhGWfux6~TsH_m$L(o4iR`w60}z}|oz6{-~+v*o?S7hK%1wy8D^J|c;} zG4`bts_464tX+9IH7hF=EStW_XUk+xxTNaJ#cq<;ijp`umHx9ZAmBz>_|dRC5I$Li zz>n-$GQi=Xkcm&H2qQOjmXC9dok+G$(m~nCpL~K$b`z_JpzLMTp0s67HD)*-6zo$7 zB~cY$@53e+AXIh~)PGv&m;Y7?h3bsi!CK5rpU(O%lB=g_7q?Q*Rx&Eh%3#M&RD2vN zJS1VD8hh)_vgS=(8ITQaptEJ&T^G)u$E_d~XygA&CKXAAQK8VWV!Nz~YfL+K3`epm8~7G6zf8fPOkcneM5JYW%F?gEt`ngpd6 z(jrn?#<~fDyO4nsu+PHbgIkSTxeS89B)pOJz?oObj%A(d+HwGZMYf0{M)JnFShat6E63>%P zL4wVu{zE|3`Cc>w@Z{h#)IJ_)-LT?jcKFY_r%wkmJS4~rGV!4BHf>|$ZO(_UJ)WSN zu^*7>7ospV?Mt`xf4G!rY1I)l4&E(-&UK(UT@ zPPSI>$A%P;83vqd1d=fm>_YFZz+R?$KdOp1a1E>dX#T7q4!{IO%@#yDak1^udQ1#1|?LV#zz|i zGHh1z{1oC)pKo|#7!Z?r+r#8=~>jyLttE zS4mxMFh07sNjm)U@W}t9q_J8MqRJJ`J608ITwzcGHuVJSXM#vKS|6Ck$QS2_$#yMb^qG-HDOPC}RBq@8) z_%%_TnKpYI1s^My_g4@qGL$|6OmfsHDmeHbBfjgp#5$AWCsiYoR_h35?8(?Y%%sBTnS;wra&S{HN+!xKt0vezLS<~?wjH0=mvz~Q-C>x;_ERO za#^#(OG?@y>0I^;!Uz+CE8vY6ruu5pUnJx?(?}pj!G>VH6&H80(R=88owNPI|5Y|x zIpHTI5b{IPH}EC~TTA`xAd24o1ZoMvpD0E}!2bR-`S3MfOIa>o^$8XlHk^jfEo~>vYd84$rnOC77y}8 z`i}>bIf1&;&X_W8h*$K2eI_<-*qz$6+AChNW=1k$s4|X{urXs!WBmq94*LX&y5xKI zeD~@8kDURMUGZ<`-@Db*l%AQWoQKKq(_W%oW0vo1ZN|Abwx^n$qM~BCib+467aP7W zJ#ee%@CNtnPgzc{*u>K7Hyyab72|cb`DYKF`J0z72d|rfL0?jZ_W_H!%f7Z|ugHY% zDS{Wg!+XPI{o%u5V?f30pS4Q~8tP%MVmr`-%G< zMG>DBFP$+#1ogiZpO;$+G_91}Qg=+eIL9wxxy+||R0 z^h0UZe?GI}p3F=zJ~DK+7JL6a%Z z#yhOtYh@GV;E~#M{ECU_GCd`%;Sx;ziB7)&D~V~6CJVRpoA7o6D5FTU^7*BSYi5#p z1-tjK*^pU|k(8Irli|(?TrPXaY$0!w$PK+rCNCP4SqZaKTx4T!|79Bnj;Ct&t|M5A zz05n4ym?yQYFEn<4)7-V-Ty2Fx;j!L{tT2wLc}n?%YgukJw+m~yB^sO&deCR$;(}= z=I7Rr!Xz29_5aTA9+Bi^#yJ@qYuEjf80|WF-#U)U`7|hW4f8u*PYlNBw!X^ka_X~) z>_$)@_!(q{qH=C*Lz14SIBS82@m*hBJ1EIh(wYQS+b3nZq%}-vj_md-oQ6VXe)X17 zOQOI@yBWL+vxS@>6PaC3dTL31cCFJH`c*Gd;La*O3+S^-?Q_AuF;$Hr14e%ScT6O@ zRU3eF5$@sFCmbYiwZF!9cI^CheXO`~!cE)GGOf~ej{$QuyUo%ZBtk>Cu zC{pQlIM_~{^kKUd$=iP%QqgAXTVk6}jTMPLPF0byo-`?s4meVAGA*q7TMsfj_hukt z4&nL;!za++v7+!dhfNFhuQ4U6s*%zQCrwkcz+W>!zDPJvyq(}LBe?}T48~)-mu^>R zy(r)EI(%uX@#^2w-R9the~z%Y>{B3>@mKk!@0%765c`>)^iv{m_MzMnw?@amt6P-Q zch1&vlZ!d8F`WOtdfZb$T1?_2^HR>s$jH#m7hG7PKh-OgX;%JG2Fu^TysnQk0)F6{ z+Z)d)Z_#Sa?PI)6cAm;W@q=j*zK=QXH?ENtpBEUCtZlLw*V!-wEUC|Rbu?RlK{_IA zx*NBre|UBgZ|=-8aowR`Un|H-f8RBz;jfk8;O~u$8e?xGUK6`E@zAsE6?ePm>-GJv+D*%1;Bl$QjEPQkIQZY1jM{XCANcJl;T3J2b@$%A11C;& z60LuX3itBT6lo0|YOj2g{tk7VS4ps~@)djYEw^InZqRwu-SsSDP%USW!4A0rliBVM z=Zyx=6P1(gxBas^I{%xx&%%XbqK6kZuBVg-S3`Ro_|tN$;B+#4?nwY)K!2W{`^ec) z^GuNS$j)v>05zpd@8YNGz6;FE%@e9;k({G{q5{5rUgxxXzrB*etqVrwKZthJRyZL1 zH@yL9Dr%b3CMsx=h;+wb$771rgKj{xKl6Qgm60m8uk#|k6qW279n{vY{YG+d7a%uz zUCSK-64n~6VHdq`Qu5c(g+1iItN&lMs3rXsh)mRbi(qKo)-~ROLRlozePH?G-8&9- zM_KhjH)JLa0Hc9w4d}St@l;=$yR?ORKo)-W&??=6zU$%MMWWri)m4 zsH^kG0#q2HHuxmfp^=lwGi-I0aeNqT90h?yS9zGB;nukaQ>A~dmX49wcuk;(zBP){ zmJxvS)4?^^Q;3N$gj@6W|8u9r3HW5Xdv}(VSq8?hB^X)S*(`8xoMlr3G!ax7k#fk_ znNkDwRUT5K9Hai6mlJaeMoBc+42pnDvvY5!Ym#^IyZ7%QWW}VX>TZ7)folc01WahG zs}#3g`9%w$aOKnSH0vY%lw-0r>b2os@*b(+iNfFzq^ByUR*T!=9?|(CX#_|)n~4NoD)sG0}PPjQb=N}4%mPVu>Oea}BOJz%-s#q9LC z4n|Uhg>|qZ0R6B+O|U6Ed$yC5kd{niJrFE%-#?Hdapv-9p+Sg5WODUKe`EznI;-wW zlGk+3y}5RyuI1=kUFWZ`$DTavvtPrdjWy5DuOB z61osXJytG7foYCPS?Bk82oz;QW3*)E5B>lQzI~d{nmbihxHk`nXP%ooUB9yt>LigU zsCx1z>JHKK3FL$-AvMX9;b8O-wf^{#2`RJi@P!K-QL6I5$RMKJ-)?{^98|JMmZXU` z$=>xj3ica}1G`$QdfVvWzxK=RyA)k3LgFySj9gq?M-rl85t2GN7mmQ*i5u6=l5J#7 z9GwNKyPU-izoS92mE%z$J9tnW0-P;^eti6R7)VWpQSV_TQzI?lq~Ltzlb|`jNsu1u1R#K{Pw$h+uc^Duy9E9#kdvv zdGB+!_MD`%J(thhF)5(>{t5S@pYA^-XKAcZRF|uLCKD}Mcx&tP zK|dZ?go^s;)=jSr?XDQEH}v(dgp!i%jW;Jg|5yT`MrV`ACwX?ykeM$;VxBn}Sjn&9 z^Z}2=OY_*VzxWyWh)37NHzhzV_+yq_%@EKgk;{DW2>rXsb30p8H%-BppTaZ9P1U9e zdKX)s{#U_bk5V|}H=jpz6S@XQRRB0gFxHLCcYCH-WPBgZl+6A6yBgyL!3)9Ts<9Cs zSVVkNe~05!BgHwX;JtkLp4X!);%W6#SbUhG$JM+f!^Ahn>uJBwQq-#w!v=oN?(Sfy z85U=RBBCRB-2ACisdA^{_6gtx(i;?@Bx6&IATTu(e5I}Dyty}( z>RCqS4a^`%zUw($qkA)QBGil7#uRc1H9zA<@Y4MHz@=_{_img)14{D9bFDkls z>sIfmisMXVelhjDvet+ZA8|4g#>zmXbkWCh9T_N}9T|NZ}YnHvx0)A|gaU zfk=Pc;s2t8J~CPJi#MUF@KTfTIxQWjKUr^;w9c3@fBzPR3$r9mCi*1`we+)6JQ~KE znK6hd-{|#00@glusjjYMNhvevp8mk0(*mxyi*)|mX?F!Bd)CV{PZ)yWg(N}(+1l!kqjS$xyRk<(JN4yjqEj}c?U== z22MZ7`2dwbA_>mBy$5=&;e}3}F$2~7Lhb@Y5a#m!{m&4;s>@&DPfkmSUhg(WTG_~@ z)R6N#61HfpO`pCAq?jHlzX_H(W*=Z+*Hf-xWmQoj_UMWG@zxLvHZ}B~i+NoNzHUx8 z#g&ld@dDAD(hO#r?nQXRH0=gYIAG;vM?;6liuLHuJ$tZ!f6ovXV-pjXbpg2bjwd)G z-3FmVzGS6^xRfyT4`4TI8%Yc`bwIMBIeCH6s8L_Qrs<)AVp7`!Wbz|-@4}1>*|33r zmZMjnea_E0{aLJrk?zpAz+(g_Q>)`G<$K(<#4$1ebwRPoQlz&J$L9yKj=|M!+Lg4c z&?O7A#ZH{KaqCtfSv*+uST~R9ldzfD1oapmDF!@z=%(Z8S5zd-N`hoThlD!-%+kAH z-&+!sW_sX&QH-mj?*U)ObIu&RkyyK=M1mw4LLDKSf2(Q>8i(^9IYjcjwpmRbg5UMF zZ47s5l^&w}?1^{}w7fdT#{UW>&ygdi|MRHaZY%Ngf4Bg$vXLqWcv^y08qhIa13JNQ zzJGC7@7^+MZCWYQP$&Z_t|4&oC)heo*Wc|2;9fpl0!0QNSU4-*$wVSs?=^(Whn@kE zg-=?q{=W%q;K$UDjH2eYQ`nP zN#HL)cr`DfQwdF(QKKlvIPUL8SQWQK){a{-mM*{W!H7N7g?=^juU>v4xhp6b8GP24 z0*`J526VZ(k;P4!u>R9n01%!W^fcnC;F!@Jq!irgWYcb!p{7sL`I^VcL5}KfSfR$F znwmI>awR3xH}zh#G@pgYwu5sI2F^kZn-sw+proY#XZKwpW~&d8?Y$sGPaUOIxEM^6 zZhMdom(3!FcY;B!>n{!K1A``I-|{tu{6Kr69#P@EdBaUC#_qvQ$=ifGsa+pH%b~q@ z;f^>APt(%V({Y+Bh{pwrBaN-AoTOh9UoGB)o8O47a4@;rho2Q<*SK*=EQxr+XY^>^8nEl&8?1UZhT=Ju z`7cNdYAbx(w)E)9*ioRsVFmGAwV*{{9bMMBI`YL?tA)^Rgg!LO5n|Bl)v!oW53}Y7 zhhX9SN#~AMp8yfP1jh{kDU|@aXqC_HrSMhh8=ae8P7rUDu zU<8->p8~rWD6h7pkNMveD8`vdqjBwK&&CgAFD7qr%CBes_6|o%g2_K#)++K#Szf|b zojF5^fAFAf!#aLxZ4~=RAug(jIojX>wW&|b%LPX+lP%*2Y_n$B{CFAPn@Kf@JXVsk z_$Wcj>?hAOmug6gx@xn$()RX{!_J6pCP*+C4c7rb;MJ#)-$px4I`!BD-M%dVpDcC$ zWG9B*9ZXl3-_0iHN~noJ!E5yqt4n#@hy*Bha$>d-F`Wz%e2UIqYDPXglqijdq%a^H zV(Dp8*>s0meX<_Ri3;3n7c@y4b)4rdo;fqK%?O;>fI%ZF=LhoyV11Bj&YpeHMW6f; z&N!zgpZkF`I7$@c{hwPG@g4y}Uw{Mk; za@~%?3}H+0nPtHK-eH%ooigHO*;rrXR?rA;ZD{m6dbo0x3tFrO#kiZi)yx{t^-`Jc(T zw85H^=KRK9Rpl_{B#C0f$x97ZcxiL&Z%nu8FR-q^{rCYn*7qdF;0$%(|LaXm>)o4< z7*FBicNJOV9(EJ^At#iIv{G!ZNs~b1^8W2xG^$3GiTNt1SK+mczE@&^}wbv_)Cm9P-{;Z55x|sS9WIu1$~?fl(`#*}R|Weegd5&CEf|Keu;a z03SvTOJ@SQn9#TK9rtC^_`&@Qk_V2WLpJ#PDE!M!Oib>FquUP*JOzs(`_`Z_q8_5H zznZSmgkF?=!0l*1`Ni`G%yD%EAFCX@^?l?wd{#-3fDB-AUAu99&ITCEjAolb{MEG( z#|UaYF^9=bx=~k$ZvV4->_m7FN5mb=t;G|B9+ z&$8LKEZ4kI6uyvE2q~8pzX`@F8De&uiK?j*#S&)DhVAD8|1j@IiSs$PS>8X=r{c~X z(~%>E!R`bZ%0+~1`D%TwnzlkU#NzT_DknF0jXqHoHg!IMy4({E#dLi+;*PwZE+zuS6_h7Vso6TW z#fL;@WjzAVOWhR1J0sbXl9uL)D)pkD3-@?2-uF(vm5d7qMTObG<9~oj1@3nNwx-vi zfe1c}b1GIsjnGMxc|G~COp#SxjCQ&%G{q&N_)MNK_LDk(J| zNv$DK5wd(t`VkiVhi@Ok0R;t>Mt@>|MpVrsQWR|3-K6Xvd1NF#2I35G>fQ1zpSqXVk9@3s#yU{Ph66J72rbG)F&Qrx+qpZ!>nz2!0`gs#pP*(GjWK2v=9i5%M zpy$)5*3r?CoSS;5G<6bD)_i7kt!pZE%V_Pvp zEX@e-$EabTF-=UpCCx_$FTS7()cux(S&D9QLMDb|e`ST(Fm4MW=HuI9=Jy2_tlElTv?%lf=0{QKogD?6n zS;9R}OX%^csi{2j*8mA4mqgMbNOA;QHu_WmgQTQsc6L&a^R&9F@Bt4AX=8Z%H){0! z6Sju%i}(s@K2lP&Y|1OcU!sRwv258fQkP;yzKS&tvF5g#&YxC2GsdGErCxzv1yiEA zrA1v+6Zh0D#rn0~XAmzyj7H|AJwWf;5Ukq>1(5z;!=hqAQ5V(E(Ov6Mm24$RMnz^H zGNCm&QceFLmjLU4s&k@|Q2;J~P;G-wN~}drjyV^li81AE(b;%G>cxGNL*VaD9+Ycj zpV&`B17s>g8DS({fGIu07P0=vIOKjHfWOLI5MFTZ9L7O5^Xk8ntC?6>JgKT$#B%aq zo~B5(ME`(q!A}Zp*Dkkji@Ec4c&RXsnr=3^B7GK$ zB>B1Tax3Y;!OW!#6jSY-zaV-0_B-GMsA;HJUx6D)7I< z+rwsFypw5i_;u4{E`cJK#_$4MGI|C~+Yf(IU@<+tFn5D<*mhkOK5n$d#rJW0x>G*pjh6y^70Kp z2@VoEAd&Zr&D^#mCSD~XDrj1?A*!K|l0m=ugiH^3KmdkC0rE_LkTq%*E-{@OA2e~p zXgotsow@}bj`(rm!hitR&viK75|LYlj$%to?g?9iheb;TkMM;HbGcgf%j00(8x$Zs ziUTK1m{>r8=~v+H-!p9@muUhnL)lLBVBDmIVUdvn|LJ`OAVHlMJiAWVCI$ruU#+Vv z!2Fzej@bg=C!KwZljh{C8(Va=z7>){v&1*@q61PV|3ma+2Vn|E=CG-wZRF#;rZ{jk zvXepP!IA;mZqoal%ZMjDK4ejvjKo7;SFAHtIF4}M8CC=rN$#Crnfh(A`t>R#ZMS4GKVAE0#m@$B+CI4u(i>uxLW<*DpZ(B|Le`Bkzmv>%@&*6hMpEQt-EV4|IDs zF%S>3>TR_l(+GzxV4Re?q)KeVUMBsV5F=uOz_q=`3$depHTS(gI$F{~^W(>lDaEOu zAU(qBjh;|DL(M-j`1fowpaxXY6m0ZuIcsxswTo=)L_ohNRO!fdg6h=Y*I5*TBNa*= z=fhB%_Tj-DV6O8DqzG7o8p6M)`XGQh#$xr2aTdN=!F0q={PA>RihC zFj!*Jw0eN~%w`?{6^@&ib}fQjxO~?erivK_ZD?$6-jSJk4p@xYSXw>&ZqJGCPYzw# z-Snj$g3bfv0cV!<_T1hiPqP|AR&UD=GO^KE!~6P52H2*#QNC z@T^OAJP14WFs%ImBNZ6VgX+2w#q#j`hyW*h2e_URz#%Xa`*|^j+=J&AnA zw!e)EiTChSL;-(%zTVKFW%>!%IIP`o@BGrA6YI*&ENw6U6)VE9aV_exZ3YhNq8uSl z)HanU?Q8aw4g#SUDXvhEkb&RTKFi#*@Q{#xB2tw*bX(acxHaM;Qna>i6s;yby;sB@ z8X{OTV9%s}PCcb2{q*Tolp%|<(M7r&7SpYupxvH1T8Y&$OjXV)d6(I3VdNu4r@+w0 zrfvMbe;XT>IMW|LPAt}6B`7);EUeCf>%OL;#{|fMDL8J$!`o;*6HhPQLKQ&8%yc!dI8tuOs!5Zw%NAC} za!TUem-DA$>1FYe{hZdUDdI?L`sSoT>2D^tSJMC1<;e#GGCauXHYdG#9v)8_Dtzxx z)TvUUQjCZF9aO|%6I!i&yR}DDh2i}3Sey3=NWQxTegXAEzkUyCSHJ!OsV2p+^0K!H z_xom}EBY&|%;$>{rp|oSYoMy(UHxS)<33 zN7do|9f8`(%5kKhROQ>oSTg2ICk+waZ8futAzd9M05`}aNQ}T@>F81B&qU^( z7I5ItmS~NcZ>>6HdMdsRBCBP~3?5JRl`vD13mpdRMXqt4q1uq!5F0Uo3Ug1|$kb%1 z`L7|xVkctw*mS5p6A>R8-GuUf^eA(eR)&O_85}!gL@vZyhR*`>(#N9iRBiy!jzG$1d};XY*%c;s-|QnZIz7VUVHI$A@q__q0LJ^Tvpsj@$&|p);ZBJT@w?9O^;b*!5NjBglxMW;=beB4fe^DyGv!C2t_3PYT)R2(WqV3=Zxv^uv5G%t zo*1;#vtg%_iv5*Ko-&@;sT`+hx@UMq#Lshfu}K7&Ty5cP(j;h-u$x#%7190Jfa3z0 z8}6#F+EhRrij<9HFWC-@6Xholtb+^cdw6&K)$V#E9g-G*Lk@i55w^T?| zLyGnw4VCh|ZvB40=a1*P|M2beP498v*L7a!d7Q^_oXw^XSXmgf5J7eOlDX*KEFC>Z zH71Og;$HvbQxnnSGMlJ<7Ct;#b6OW1nm#v{Y20?ucuE43Em#R|XztK3RPEJ4P&zUi z-jO-lMFH4L0`qZHfw0oSAl(9W0=)Abs1@!S1~HbLi_bFU^6Jxhd8u~#@+$q9*hhe& zHJtZB1X00f`3Z{1`RZM$%<8W9ES^ z^m3qTP}^jfIaaY>QhESDf`4;8di02I?A&V(1HLnJ2HwH`m44(fW|RG#gkoUpfxH$J_BrtvV>ybQ}IaSA~l+J^MhQ{)-Gq2L=W;VEJ_SDIN4x<@p`d zyMqU>VqfuRJ{tN|dP%%Jx0s)jMCf8}w0N>jsp_~#RoW0Jj%FDB)P_{R2p7s~q&L{; z0l^a1un;c^QZLroQJlS&w6HUuRm@*ZF|DFL|g{2UN%^=4f4knh+pRyS?~ zS~qA4854KlKUE+>o~uM!kLip4{^FbSbM9Q`TZscSQZ5cQj%S@9Piq1DCRSjN1io$A zzkhFY^Vh*vXiT}~2r0P;YWyT)516|;X?Hbij}6R46~Uh+n&~VuU}&zRM@=IN>?+jg zO3PK6+uXEx!@`y0jV-)i{-aWn(!4q0XzQu;jWgdNekKNq|+Bt!UIFKJ=G^j5`*dgo4WtaC^6~$!UJ9l0`#{+}TGzNLM)sP)sIF zB{ihBG{0uKx59e`s6nf%t5K>|eY)b>k1YqOiHqfgaYk7gQ{A8Od1CdKEE+P7G2*lc z(S>oqkoXY!Xhe-%vOe4j+AYQfALtz13dqL&@K=S49uL|h*8s)X%h#_TR8=uX!Juki zoub=kuH>|K4kpdp&>4cncYlG;*JbIFY_;rXM-~RLb=t) za~)t62q9IPs4?X3ixVJ(;NV~!{T}94-OW96yXt}K14zPY%A+gY?lBER4DLb4Yix9_rl{628)9!q_QKK zmrhSDqvFc1ccx1RZP+G|crXyCQ<7_LcJ_Jli>k$$yEvL@R->Q9#g_egcm<(Zw0}DM z!>HI!Y0oA!l_2-*z!wcoKsA808uOhhRiKh$$4Nx)wM}$dWW*`8bri%@f(fuccx!%A zwM@y)n@g83H&KW_cLi4Bax%8jXK)%2Pi>s z=e`yeCn01|=f8jNGiA!gGdhx%Yco&fHN8-(U32*Oac7@R@@VrIt;x=9MaAQl(R$at zdpDwW0OGS_M8UB_K52oIsr$aLM^h`KuvUV&EY|6ez(C-g7Dzc{O7Zns7Ieh#-~Z8R z!Kwe{0!(DEI&I`!%~7$Wblh4}Bl>{$1xqDeaQpp59nM^+mabT1X+^e zl%sP@qMkQ25#33k0A*=EmuPLp-hyKncR*VI0b_eKrVUe$irGu!fX9l3kFSoBjjWvL zvs&MH)%LvSLVC9(E--!YzG1Q>`6MYT5iRw@UW=M*+VMrOc>xQVzcuQcQG$ZORh8~n zS%^-CNwC{zEC^q~NIO0zBnWx0AM&B4*sZ#_Pz_U!ci;amwAT^iPK$_qRyv;mRJN>r zxuIPbj3bH++-!jJUK<-5)9RqQ8twka=(RM(jJ_&t>ZI;TFDlkg&cFH*2|W(Q*DrT& z{PE*6orHOBJVCj@Iby$8#vVBvi{}T0Kn}{QPLuWNC}TT0{#*Ny6}*sGk(Du<-5uV zm~M~im0K^WX9dA9$ttS7u@mQPw5#zA#}^|)L-Tg+n(XKpDOuC?x0%thRD?E?>7#UV zv*fxC6KV4%r|mQzo%xmUVC#)xppaU|-QI9W2PCZDql9%+l51g2Fmkz)K!PcwpFUjZ z6Ox76vYR+hXwH-4iQ6VY7Tq;IsAg8;{upZVs~$8cnDaT=!=wG?VoFo&T%U8guJ>|r zb_V@@^XgSrdb+*7Do7-Eo&L|DfrUqX;+Wm8hH=7=XKOq{3>-yJnqe66Me3`{PMpqv zu+AJoKnjuqa+xGoCTTyuvUUv{(e#(z??56H8Q_114!Itzv~7AGL9yxC4wR89TD+gF z7mra@SC`RXy|1>&N%0g|U3>5P5R0f^yQ}nFEacjqpTX%$3sG%_M!|VMkT@X>6^u9| zQV5Iex-83L;J~&5eT{_26KGC~qq&ymr2h=DVbVKR(CymM-|ZY9)|W)n{y-n&wQG7$ zAAae=ft|E*yQ#+Sl{Oa-KYqcP#PTtv z$C;Kz5eS&yzJITjr<<}+&Y|)Y2exjPBBpid^jQfhrlhMnTbP!op_ic^E64*|uvo_z zY}#(0?A9+S;1BRmzkG4H@r=&ycH39Y4klZq(2uk+uT&ObAM6|-h|5$b6D z(#O!sD605*?z_n)omZOGrEp@T1Ylj_4h??#AOP>Yq7X(9tNB~pE^g>w=)!_P0?1HR z(EL?R^(2ky!4WKSX#tNPI;Uhg#6f}#>6#!wB{FPj4-SY>kEhllw3MIVkYoOZn9)vjMrHWJqX80jykT`dU(vFNeZI2Nz>)^ z%gI|UPBcwRlrn4``z0w#dG1F6cjAq2lbd?1i~zALt{M0FZ*gT6B5?8>7(r>Riu2!ktAi9*s ze>$1CF(C|LVBup#xEv`QdGQ{}$`MDTh8N0iF2*(f#W~HsiZvOqVLW(yt}!X=?)F{I zW)s3lrgkP9HifK%C#kyYwPT-}C@+EP`;VrJjpazf-1j)umuECOxNc>*L+pSXcPsAS z*QzWS_^5Jg{f`&5wKCJZjG2ScrTMeG!r&1F#@!tNogyzfDPE47Zm7{|3H5}>yQ!pr z>Q-GOum9Jp!+U03Z~PfDa5uBq z*SkjoOzV5x-r2W}aFPh|{rmEPyVurSmE|m`83ZQIh`)XuW$bcFYDvB4$>-}{m=zT= z8j6WuW?6OL3;q9mZ3Q2?B%xr)Q0G&Fb$}m$pJ?FJ)#^Hrc*gWxrkaj-R2M z8qAkYkMkf!OO9S*I)RZ*TJN309bKJ_Ou4xIyM z&SXf;v%Kj~ykJLVD49?)B-rWDP*Py- zd39yw%euOI4G=Tbo7enX! z*zVb;c}eX$Ms1RvoVEuo4#sk*Wx!X7tJD;p7AIupFAK=T*oDd(n%NKVR0jtKUV1R% z-^;Xe^Yb~H$LF4wXwDl5$a4|&!p4RnV^{3kFC8)!cI)Kl-eT*G69DJ~Oq$ zO>s+m3L&Ldf4ZyK zql>pkN9mJ_hA=6e+d{%ZEY~c4=8TGz4r#RH;-)NS zW9GEk=9jDc-qIdmJuTgAZCk(|TzVPe00jxTAB3$@u8H8G^fdKyL7SMyU=OL`6s*q{>jicS)tr(aW45WHTq=FA=BSiwUncQ z5tQgFS{=MyIz&LXxdx#GR-B}FPCmPoIZ@#_fHEAVK$aHdWgPH(;*VL4=hyXS0pOjU zIi?5qio9Qx$>d(JT!{rBoB+@n%qPBo7oEZb&n#`J+u=)k(@oWNLw?G^~6)F z;68C7K*Xx_>sRLZ0Fe-avA+pY+Ny;PgNOrz3g!=u>vA0JaGMRPFa&1fo04DU%8uyC z>4WVw;KfoVQ12b>3%EqB%QnxcOx!~wlg=bu%oz}mpt)OnaO?rOLah^JAE@i; zGw&Te%R-wDKMQO4g5UNgVtG!UgJid%bu!rdnwo4rJiQ`}ga;j!GZ{w8eIP6A+4&{i z5oMe@RasbQ%#2yUB8a0qLJsG>d&lQIg^vrQZ-waXlf@5+>DowwBP(+9K)e_?k&}aY<8Ys>9-VY_fSt|x7Fb1sy_J^2I}-#t*37qoX-_(Uu*3Pv`yC@_ z!EQ@T3??HZ&XED|FX%?G(smU1q0THRw1>1H;($p>;mvl4i^J{6?4TnnD=IqtsER3m zi8_rEa{S4;CNh)t14ls8*V5F4bZYdho)&T7paDbn!mAZ85OXfNkA8morUy^5sM!c; zSpcW`$%Rss4mzfAW@Z$64E2j?c3QB*!BOS^Bb|{I2=9KcY=IE*2j6ew4DEpOgk31x zGKMkeHNkKW@RI`+<^sW|_fT=KXa4>B%Yi-ls?I(!xq_Lh;RqC!JYfoTTpa_t@@phY zlB0}ABx8Ya-s;%*KO}KphKslu@S{707Wf(WBfiL?E8QZoRYYOmzyC?^-kA(Y#R?CI znIS@!{A{(wW4k1)DX2lOJ)V~KoXVC22(AbHnVQC*toZWsVAyPc!~jP$vl$d|Pvj6* z7;GuouSxHd^M?@1T>qhn<*lrkqpCnf+ign;DXz=^e8c73 zXBthg&KRM_rFLpIH5Kz<$SnE~U;bwz4RE}#Flc07p-JsZ9po{`(+%b!f^<-HS|DY% zoL7eX9#mJG>x`!yf|%=f6DJWaDr^Gr{$}5>m`y;2JVoL=t^u_RM~!N?r9@-TEp81l zdG>VuB-az4QfPj*AWrG9DqmDDXZa0U#XYB@=;VMd$zw))Ikz0b3CsjZ`IXr(+D_J& z83m<~d!3k$f}=}-XUrO`;C{}cwELpPV2^owq#5($7lUnLn09y2?ymSHGXIkMiesw2 z^T-2Z@vImN(4Uk<+osR?GG(>)WWtiLeXX7hmMJ$qM`NTgxPN~cfrJWlH{T@r{}$m}*DtAH& zKVS0=wk8KDh0Vr*X~Y~e6iJV;^q(>`1adw^7;LEC={jWUm|&M|rW#SeU)n2aw0@hI z8`4r@;VQ(9dOEIC)Es`b_`Xj)?ss<(vdm=1M zuwOPV=1DnPxVps$Pst)sVeLTL{rAg(;X>BU(gET;H;cV|SqzsTwabfNo+ri`6Yx%l zUofT6@~iUEpQ6zV;7=amPD}IOXcM*KWw{@~ z-il_bwE84{71 z<~=uC@AQ}_^~(Iq9w+S%3G6jNn4;E(eRVC(QqhrnmBYP4B~p25Nayt^&a~pAmZVz@ z=xVs7{%1%SR{QB&R}C9>nW)5=P7{9jZh5)gkCRF2=&I=k=Gp~?tEM=1?ycHGt z)=uE#(_Q|5|KAL|+=-E!r1|iQEE5x1MU-|_*?V94n79>nl95j7J=RjKm$-~%f;D<< zJbd^q2TT8IO9gJINz%a9+x!k>o_|v=Et`MWuJz4a(_8QKQ}JN8f)6E44;9Su;Lnf$ zzRM6Z)%>lidbZuZp_6Re2(@RH_&%M00DfVx;Z2@~@tsqKOM9PiO?ln0lB7S-vXj~T z%1*3YkU!ekL>?}nXpRXc$jk)U$VrAx``5w5^`HW)+cI|ifAYGe=Xy4>`tXVol^T@P z>yKZ0tH6^`m1n};e1o9H*rZWe=&iy`2#hWIn%b3RA78!NklcT1;+=l-GGFFoE;rQh zpLc_92^v>1mb5A>ktV1lR2qg!*RERMZF_BF>ez;TLo~#t z;g%AP$N&s=ybe=|l95RMb>7llGv+g{-3I!#^dJ#z~d zvf>G-Kfl1ld(R;IsZ$eb^^r9LDCHg)<>EJO=vA84vTf}B>4!x}%k@egLk7b`Q6N+f zUHc1a^5%^jx&5`BpvF+-LoP`(o!6P&0Oz>|v2*9&kNL#=77UUGc#PR-c+1p57V_*+ z7@Qb>jc?bBVHI7v#BV<`8|tjoKU!qhZ;kYA2(CeH4oa=-@`hKWw17TGd=jKTuA11m z*V2!wyfiSQ7REcn1J+TOWc0?aWeQn}nOl&- zox>tbbj_riR$OOK;}*KpRJTLon%v@gUe=I&i;16D<&+W6A`0Y>0=!XzasTZ+pXExk z980MvWTT|%VfLS*M9;+`aBKFUhnZR=QWVp+EzMg-A5>~DhsQYBu&2hr|H8Dav@BCD z(b}usaDiVz?N}8zMvONm_Lm$dPTcxWltG!!0^QXr3={I%LvW2q3@RoLGQ$U$ERIFY z(O5*mP30>HWXRiJ70r0j=DvKC#5hLw#{DxPlq=Mx}R)^nUy%cwnB!pTh<;bh2e|8)_Jn>ynWn*vKKCM-- z85@|fA|h3}@+~XHahjp3JiOsnwIM_vVsGvKQGMX`B)J97B@&Q{5WASw$oWJ<1(^H!b4NEv#i;dGjGw$fzQqL=%TN9jwgCwxF)_+P&8_$0 z8C8Acu)pk$dn(Ta+8}?)PXD0@3&fhy~{vMJuGI=I@l08#ua!tZ=JSD~L z=dGsL)~Bt%qmdoNxk9|4>rIkIku1}0s|CIBLHp- zoFSrSY4VW3O>d`%Pw6v=(uM<3IUA3>(w z@&Rg}qRU420)HAR0Od67xV1rRYY&GdrO%Ls zS_Ur0FF$*l3GXpl734F zm;$9A>ypO_MS+VxEI(oBnLZP{5Qm5L9;|a4EN01K@ejC!gG-k6Z^`qu8Va7M^> zIwuUQYj12IZp&l}b<30x2)5luZcpn051V024Cu9jD}DaWr}yt^u~IYhG+AT(jET~Z zR|$;bJT1IRDVik5bK%xO7~iO55Ak`51szrtU+ zS$(aq7e&21VsIKh*usV8=-HMo-SekCpLB7*&>jdjsj%z*4yOk~=aUD-{RbGJnqRaC zZ=0afke)naxaDv0^+U+f8Gs&5jwbVwr%hWheR>DDR;_l~@n`y2SXr$EQS>=`?wunJP$}UA z*PW>retvcVmYI?C?I=;<-(wZc$aGD??qDSd(o-lpl#sdi5;hdSOmfYnOoR?7Lk+bS z`;b;;?0*Edn@W)o1Hxo=J zBsa<(cg0;`%j&U?bO)%?+-eS7KL?S4VTv2<^wInM1%JD<{4#Zc;Zgm^Iq`=Zd9K(N z&tPi_0x23pFsEXHCJtz?sog*WmcdQ)pPW;h6k7AT;novHKi4B+>9$JlkQZq;w)KP|E!p>r%&||9QBexIs z<9HAU$Tc)T(TjAO2x znS`o_r-*X!sYhQ<#mWfGnKIq9XV3YMau^~X_-?Jk^|4c?G#AL}@oU6>|jF!bMrFVuBbWDbOg;+8%6?18H?Q&vf1~*ex3^AJtU|t#xVNu*K%|N=uGM3 zv}>0@eTOw@{D>~KGcdWqjEtk8a{_86n-b;Ic!bZTeWxI!u1R5qSuN5;n=K`X5Vf&_ z4(FJPk5`J*>!6hoCF$kedwH)JIVYx^4_L6^3VmBZUCs-70q8g4#&ivwf)bhUho!v@ zp6m#ru{9Ub&L{RWjt;4U9LW3{=8El0Ow|8#xNcm*Ezp5DPL&p&@GS?Ab}0N*gzC zMkQH|VxEB^ndk3@9iq$Q%p_c%2MuBlX=C%<^<+CFq|-;Wa2)c_t)b#|f({^Als! z4jdqytRWCW;IX#8hgvx@T=+Rg!^qJo1|Iy&9|*TADepd`;Bd;8Q-JS(C~KER=$4k-nSX;nnM1v z?5Pm&5r}czPtdos6UM%rIX2wFfff#&Uobb&+Mc27D-0YT)|jSMzNJPN`M?SagV!~m zll&&jU^0l-snRpg{o3<=TXi;Xf}sxPi!tQWnlSdTIeI9c1Hi{?hKKbfVp z@pnHU7m+Ts^4KD4b{O1S^?SwkbYhzO4ctoA1-XsbfKI&acHr)MJQ&wP1;DQ?KlxG&?B%z$H`!3 zl|i{oQ;eTbM$1n{0NWD6LjSz?o!&)8POc5ag?E4d{04K2j*e!g1Xy?Ct$Pq%x_2Gf zq)gir`a9UQijeryTmC=p)J*}pLb05%C9$YTh(Lla=D*Ma|_22f;Cs%L0MC`8f6h%FEym0}F`b zEume*yX}UrkIl*nd&8{WxK~;&Bm%6st)Rm^ zbB4#Z#v96b8U`kDbQ^mg1M)&g_<@BQP6E5FklW`Vh&;_;*2vX8r!sviUm9sR$o7GAa_!S|_)b zyA~Y6A2-r6~RdGKlBYb7catFGgv$-37o#7AE_XoXfr5FB&ve}d-(nS02W#f50f zMCV+?-X|HCz=IO7X|D?Zu4Z$^bwz;wU9#-+Ac$G9aA$6o zd7yPpnZ-Zi1t!yipn?zGyeDTD>ZO*6HseITL?3So+N+-zGj<+p7!MCy2*D(A6cK29 z;n+Sr+noNnXD@Cyq%Y%s+OFJtFe}%ECZ3Z}5un|`i2IB8ugf+V!A!IL`r_R?#b+zN zGrUT<`~AOIbBtWjt4-_89t@8kDtg|Evk;-bTaWM@}KP}yc7lWU)q^*>waiNqp&99O41ncwIL%Y#d5}o6YJcK z8aRuj1^8!jzT2lZHHqy!0&>ru3af8@9r8;uHKCyF*%kA4yW!)I7WO%Er>)#LedD9B zZYLh|Zg}>TdPwwMV2=DIZ7A(@(@;uQr#~6rOEbO*GPlxpgFXFbsR&s3{(b=kcRmM; zYXrQs@>h%uyhmwBF+OPPupb{DWgI&;wES9g5{d!J%6_sxqK58Sf=Adq&|nTNb`iKO zvfPqDTiZMUul9R2vLDQF#UzjP98eZTw8jV2A+S71rTfs;nKS1CqE36c$$`;G1w=YI zHjy&Y_O!0Z@F>x#*U!bJf9N@xekUdL@RYB9J@{WiKwxIrbCf&BC^-Q>8Uw!UZ(9~> zCMVtNN59f(?5?Kf=EgGKE@#=guJ|GdcKWK^M5hU_$Oal# zhAdi?eMm9H{GpLXYh*17Xg9+HAWXRemp^Er8VkM4gZpZ4ghK?YL9NeDFWN~3eu-~= z4m`qM2tbkOTA@u7SuaaXe;pm#9g4g2uJB@0q}S4f&EI>B@1c<#+Df zxOo$$&+^5Kf%Mep`Wf{v{PxT_1!)#&GmUW!;jZ4(ncaUE_r>p<-r)nskFWbe;Ojmb z$M6i@Qn@BDj-Mg;749JSmW=etTelW729j`>X?M#Dcq1`n8Jv+;BT9475C~8|pQ9bv zBpqRMm&ykQ3WFX=#+!%_jo2B`CAL6sYMSoe7-WA=@mgk-nczwAYFyi|QA_^2 zr~%Q#)x-l24>aD?NJSxoT-|@Av^#}a!8SQz+%%#iJz1kXexW;@L`NbaM%v~J2>}RQX)k%!kcx(?)9+=#tK<> zt`o5b(;s)YeFTkAyhHHUW3B^;hF-z%{pzCWI^-#|0SovttWAk9Vo~CM8u9|Dp*Rra z%^QFlUct^C7?@5cH^NsJito4orZmaOmn>uo&*u_{)(N!4Rf#!zoj2l}) z7z(t~y&)yynNL>22g504kg}h%3fG_>+#uP;vfw3gmUBQYMm0`%rnRf4FZK%eyv3>n#-$5e_6AV7e zg8svkByWbxt6%18;LWI}<<0a9{{O&NN)QXE4%U@t&KToM&|!r$qmpVKsEMb8h5ruk zkCGeO6fNpUJ!^@r2N8Ao`LP&DT zRqU^P3+mI2`4h}^dw*lc3;cnXfK*ZT!50JK3Z~y_^rBIWiC###1)R0q-0Qslxh+WI z9s}11bEIE4o_&~U;bDem$pv`EnB`bny z#zM-%&H*1X$Y$9S&HjKS-vPa@tR$Tx)U%T46OiRHZ#F7Q_Chu!xj`H}sC?hcB}gN9 zLoTqo{&@i#2Lsfz*ez4K=04&1>&`nCsmn-`REbw*?i_qW5@wdBx9v?KdG*py}+NgY-t27=Am4=G_=nS z#(Ke{uA%y5xWzDE5sUhbFlEqy0qMFiG2mri9%fHx3Q~7fd5SFGGxJhFF#O)OosHps zS3SK@a#jpgNZpxhE}F(jE=$dBBPI$2*jY4BcJH1$YgYH4RlEUr1UVfsaSQf#T{j;@ zs6YFTG1^kMEhc1SahV0aOiKVTlwmLSrkSAbgcu6d;>~)~Ep~!SkW-NljhwLh zldKqRnD9BS$5v7TvcRQAv>F)T=w#_g-GpXiM=2FJ{k&5&Re2?vD5t-wqOU)qvOv8eE5))wAb%>b3 zhz>T&sb9W-cedW%f+B;)fa6#RH!*SPRk7Zs|DT^9)@lU~s|$q)T3oPO+9D*fNo9$T z*fJ(V_G09RB_=5yI^b<1(8i#iXETd7^jM-SY%n*D@|iq&#LwvmuW0r51~x}vq?g+! zDUol_trabYkX=ZoJcbWNbBhbE*3FyqNI;AR7yqM9wNks@(%j^+^1O)~*vRrJc&3Ry z(s!1059uMEE1GnC$Bcn*tf;K)XubUhgQ`gc$M-r-17!r=qPz4pNPt0@VT=|mptvUY zrP6ja<`h(q&E&7MvYZ)pW1P$bQ9Vj;4E^^)lp*vK2%hWsFPA&}>Xog?FnA$ka9Lw| zfEllUGA}5o$E`spHb?-Z3JPji{6TW-*VD7%sXPfqBM$XM2m@^*2+-b0aYq3T|5W$T z0K93EI>7YA4Up3myf`pmH4%?zk5|F((2|K&9X7aF3-X;2ybm7QwHns`a{bTIMFF&x zxPJFJiui;l0N@ALb#W2V$j%ZS;TojPOP2Ke((leD83AV`qxl2;xtqb5gYR%jKEzGn zKDDCTL}vRhrYY{u$HOG`#{l0Uo{64(PxRK;mb|%ZVd#(MF(^n|LnE^JMnE=6dMR;n z={H53F~<+uXy~if)dvg(TyI zr}1HY0DtOU3)xLi@c(6b+Wh%Cj%nwwUq>&u+8=)GY>VhfnR#+4g<{0D*eUIV zrxAPg5$6*zhHhg}w2`!{B27B>^V=`9;aL&(gF49*RW>B7|739oGZzm2B`Aadl_`;e zqWg`-xs`7Po%N$#=1A;Rh=(*uD^wgOx4unN?=iWe6JACJR8p8HEWL7-S&n`y%CDd+ z!JXogQZHrk4GJcvNf`Tky|@@7q!7bTT>m{frUqn9^b7D+aDw z8SdW!09J4@?Q-kK1A7Gg2J2d`pOKi5aEqoc`KM^(d!;ek&Gw<<2Qf&ooGfI&ON$Sc zgGLZe8uTzBo?-DCP_0E*sR?ty$0bFm_y^&ua4Zn)?a50NV$i<=#SYmNziK= z&>Uk9*4x`d0p$7mDQai|*I-ksugb%`(E6D&HRab7#vo2FhdqZ=TLX#Re%;bB3=|d) zZcw|!JVhoS{a*iF_O*OeptgH>ayI80tyNMQ+7+}>_UqpMUGS)4HP&emk7&0A$r&ya zBhgOwR@;d1K@Q#gpgco-rv*xM0V;F0-t!}@=gA$+n_+R*7DySlJ{9sVVo=RJ8-s>N zXBYZ%x?%gsG#udZsv6}D&KU$HYDeOxBF!^!Uv93Gwd!mc?$u+s&q*hm6J?s&9E4|b zdAbW!0e04VqzXQzT?L_``AEGIzg+*0{PO7Vz}*PaBMR)SC-BXiw^95zESxjM{+-g@6r!(*Bz?kkS=kA4hL6F&a;fIsAP z1L;ImS%ANy24Ng)i=~SfJ6Nmsloh`wD6D(n?UA#|7C>>3%Bt{J zwD=Vn8%cp-)nC<&4oWEL6(z8i*<|BxN+Wn_o7DE>^aYeL6DLg)$93|sFN@!{ONx72 zA%Apw4`*KFjk$wEnu5Ux&`Z$mL~7h^${MgtGU7%L2d?_!5slW_ZI5eiTy_(6Dl7 zYT2w)kEkf7WCzGzuy??)ftTmTLcV9Tua>V^H=U#VE4s!p2nlgEl{XSUVk4v!@FY}hE6tL5vdZpI(K@~atm399PHMy!^BU$UGDHnlf)^S#+}sfGRLwH+ky0lVh2j( zv=bsNb)wA69QaZ#Oe~W3y}@b=_bOjn@xNREJ6uoa4fL5d?aGAu=mA9_P;9;yNcu6QgZ1fK4%a z93%!Qnar2~@97{PIqfm;|3T4UK1OkveY0(u8V8$##$+&4m1xK8Fvob^acmSEqv|c; zcKW?1=SpB=8c&eK@e!oMEf~i@Xlz$Mi3$P_2#7L#pVOBQ9SUOb{Gmvhc7{M#FbTOO z5J4on)JbmPC{VB(nK$DHw6^=(>wXp-%^-G0=Dr)SE=?^7q!qqjH)dYge`Nb81(;Ev z^I%0N5q4)wW(P)JP+Tqw?rW^Uy%RTCF#Q6M$mcTqnqmor;hVNSH~SS0AG)A{lm>W)tOrN5xeiIQy`Uou}o@ zTLn3XE=-83RqHF=ynDAlqKR@CX}ojOSg^(&iU1r|^K+eRF< zx4Fw8l~;M~#nhk?jxuw?C9fN2-P{?zymxsR=5Y-0;PXNhwKGhLd>rE48&$>9+6feV z`kMctqpm$rqO-E&Qtjs>)Dky}u2(H0)i|dDB7n8^?xFxuleKad`B>(y@S*_zmtx8l z_OK(fnd}Uf$_s2duw=66zXeI8mbyT8D>qL)YJm(%i&N~~)@&a_=C!UFdu%!f; zP)kEa95Xo)SE05Mv>;%ibB)LT?0x8n&Rciv$XoqwgmJa;b&aOps>xay=JN_ij?ire z_v@#<5l{Lddq-zf@EDRC0XQ7Tc4WIGxsvRXe$Y;69p^^mB7VU`pqGNx8ecEzu53HX zpE(R41=3;~0)dbtfC^s_2JW89D{=8Pr%oMpU@Wu=h=WNt2W=d=o$`iH&|25@wH#U@ zk;FKpyYIB{zq@qbP&oaVDF*eg(!SJYs5!0ze0X|nu=xDHnAil%5Z?YZngow zs4cw+xr);4%PG<)?xmNP%Q`+hPl{{3B^WJ+DQ%A=mDZ7z4j42@Y1d|sODcR8o^soa zhP=c+S#SX*njOwhp%$Uf%tyiW+U>bfXKT`vv#T0kF*q5gH+=Zc(Kv$HcWWj{FQp`$ z1aJb1C>EyuQI)}_zlN#eAO7sj{4PQm-TSI|i8uy;?aH>GmN|X;v?THXH}(JcYm7?< zdq}Prd>SJSI6KU#s|uHB6YH{>Y5?kXyR_7lBAcsMFNXzwAU_DjH~<#4L_N9fptg53 z4M46FWK1ny+@R#nykXL}b9_PgmUvrTzq)o{1@lKo(+qTTTLt7wLP;TqHiLZ)5=hgF zsY~=70l}gxT=;VBvpdl)`3c#D;`#OK*J#Rz;2Gtd;cu~%lgyf$(%Kq<@ym?OHp#In z6S&LG^y$*YmUj=UACpSP4xKn%zE(%rSD9QciA{HaJlwK{p{gOJ8 zRh|t3ve|a-yZX-tz9Es9RMm|^OmE93!qSblIEOOzw?n#BODRqRj)vQ|Z-*+HuIbN? zY7E7&jADjk7S~*^-#>r4HJVidtf5lgIQk&#aKCQ+#_*o1>Iqm7!5wIQq`6EZV)?SV zo6I4_c&=)}v}xdPUpNFzL?EI<3A=S`epT*l4y&yd7v~rfzv;m(gd^6m;{(q2`STM( zEMcv%UxHi)?F7H!g}GP{kilTFnge(vPv_AGMc;qS`SEt?YW66PyX#Kr^csK?H%4T| z$6pL>S;r7e^plY6am%Dzy=)oMsUW!?o*_1QKtkMa788Ia_>HSEwJ)_d7a2yHZd#@Y z(U2xZM`Nc2?qNPTHwf^Wo?B4yw*t;G9M_S3qbOsH6+B+#kRo|$q}!6zq5yK)&yUZV zGq~!bcVK(>@Nzkl`AZZ!WSwwDuq%Lg0$GL%m!ZYdsc{NK8pe>A7#mZ~RRocmbO;S? z0rw*3RLOnz=TOqttxG`$TZviUcm!e-WO%2K`hOCaY2)>&+Mz?n@#7RnSe6cV1q@`cjd>hx(a zJbrWCw|AOVHLhp}MDwdJdDCcvh?HV~*cG3vPAhFY;v&Ukms)iG30oJyNXVy;g4qTx zwiPOK`g0h<*afUUKzA=E=L?-A_)Ppw6TwOxz)%zbQ~c+rr`Gf}`r{(1sW}54jk$Rq zMhlz`Zuj@?*dZr~cC5yxx}zvLeihU$HlKPSaKVC21%4F!R6lrARM{su@bPKugSPbMxAj?GQ`f26OW>a@`*2@ zNK6+;dbAa%PQLy0X}etl;SYFyo1IgJCTp=pqoYX9AqcTvJ8Ed8>E3?G&@JSwP+9Da z)mI<~tJ8I3aUX|yxNu?nJmYW6ARVd42F{)9Gig%K`*HO9=#9F&Z}gtq=_&W5Da0lf zP!LLTD_yvT9v-mC^6W<+$gdDw(IyU@F(X}fbc<-nR20DaF|AwG*$Kh~gAf4e@c};F zG-oijw6TusUHpy3*QA`2_?@QML3)yVExZXVh71JcgkFVdRrc32Y;fhar}#MBg0oU{RSjn|hYDwM$5kcM72U(9SFv}w!f17^fNN0|AmO9;tskz-)Ah^EMk%~L>u&>-l z9p!W!0*G~t&N3_wj=wf$w1wKf$c(0tO>uEo1G3*d`!a;p$*C4}(Ms{S1G(PS_UTUR zdU)Cnq9qC2gvjAIK|lH$(pAE;)`als_upI!wEL{7rR8j_&cRybCF>q;n2W$4JsL;C z_&HR11X$>(9p-0C42It?CpNjC_-J^-HBxq650fpkXU;t1f32;jCKkPIg~YdRIL#co z9B3DTtq?ni(boyAwP}h>!OcPV_@LDf$#9?u@)$h7|8|>G*OQw5dyL4pz;c!kF~+6 zL6_abVfemb4@9cv%PU~_>*yBxZp z24NA?exyFCZnOFJqVuzx=X4zweFgW9OtWz6$h^1d4~m?c9*8_R0l+F4-UpfTy?Zp$ zYcRqQ9#T1^mXWH-3d~j48@3vY#JG|`^iHhZvkN`fUSnPoMp>G@gBR65w->@N?E(IK zgSuoigj{+*QiA-x6Z#9$QUlSGdok7#6I{V!epUZKInq=ipRAVXGpYAP@l;!y3ypK7 z&FFPtF@ioqaQC|Q0i-*Ic}h1r4hh8fMG)wY1dh%2&&*Fx?eclpt+q!N)Y9Lke7F3v z7#u(lI3JA671#F+?){~q;U_?6(bUrDtbABgg1{b(RO)GFCMzIf#gHekK#V?f6W_J1 zS_h%5CV`q&2%DzsP76s8AZ}k>=U1)NDU(=0B_VJpzjlzefrJLH6@!?4c!-PMmchMqVkW%#*B)fh?X5L4lXXQ z>7=|c4b`WyC$er=Wna~MMdw-&*k+L7uDON}w;l9s&8~LipGst9WEiL!P+NyEj#_B1lq!Vb}(2l@tber4qV0Mm1xK6J?oMb82e_xr*gWc zn5_>R_6JxVhf{9irp=qH357Azy50c&pk^uVTH}63u#C`utIgFU;_b8Wmu3PQp5gF@ zJocF{otuue{YuT)Z~ePWLC++SdrpDLL{ZG5;*5>u#hb^p5hfGZzPUW2WcZNc_PI^n zaR$38Ed+BQt*hQNr5pN!G4FQq%7Q+Gv6a&~>e99wa7se;WN*MAxDGri2pqA)Lx0Or z4#@7l1*=kn4~Hux2y4K91%jq;>b|J-9v(EVeR`Yn3l$WeL@K?sW^wz+292@j-B z8})3jRFAAAg%t!GQ|Rvri-%dgpA=Fi zL*>`n>D9?=Xe1>_Z0to#7LMmbU!(9>pyEmM=$M@J{_v?&ch2AFY=J04yuJYvm*NT>fW7yX`n zhkaC1yyokl$Vc)V#Kkk zmnZ4Bk=#KyPjZxP_!*+?d!wtoz4{VJEbQLvg@qxYgh9p9?PeCmX(C&puv~vJH2KGu zx{>&oP~qV{oTeG^K~Y7e554S?5|Bxwp0gOT!f(R4={Uhp^@B>knHVO9S{0aP8(*auoUuVGZEad|{dp6CYMCI!=y4N_ih?%e? zel^=qcn(E?IIbSnGx!+YHQT>UMq2Stv2i$YWvgl&2n2+r{kzoQg-S0=|3MGvK0jgg)k-Y<5mhcJfq z^2!G3kHOCv9bEPF>0Vc3*m{n~GDgl&;TV>e$6<<;R-@#PMqd9bz z1CCFW=xPkh9_J{8j~TiZJ>WW?g471B5t0|Zv2@+rV+`UIcnAv zALX#BxhXqH=|@AuBpiK$N+X*p~J_kYNl~ z%o!Vw#Fce5e)8nF+yeCmj9)ANtC0w6SVs&f(iZtmx;LOrgBDZU0Cp0Tmn@-xUj}~)j3ak; zC4LfBQgOOCFcBa5He^+-Wsyq_C-gmP>8$d&FlT?!gYOWezls#=ZTx(Jbx*E>1f{$$R_tjkwfI9CqRl)f8>3J_TJHD zw{Ne5701WpTy$}fOL1Qg_m9Q=;|CR$y|vxaOKX1*?A`kVy&1`zY%2e6Otq@7M>gPK zol7}&WCRI7TpYbmyX_ym8BFn|hnJ-k1EGF0u}iZ4W}<|CTdX@TN`;#Gk1)mg$|-H2 z`v-tiydcY(nE_!|sEm`LUfwo>A=!Me+wjS5-$ukOE#L)sp3{zUXZ31&#-&R$T&S%7 zvYZ% zz!Y3ydtV~_lHJ&+8KI2rq;RHB#Kj-zMk)*)$^dW1O#+9sPTL{2j%^W%kb%}9lmP*j z{#Rw}6|rfDRG_tDUWTS+{6iKWd@c%d{68660uhp%0NTvm;Cuj}Sv--#CjQ7XJePP3 z+!2nE+MyxfGZ6)XKu$XN4~LZ4JRQGH<#Bi$xzVXMp!PMovVDO{9Y*o>ot&cdE1^ty zij=5c%mJ!fEPL@Ew+lcXCKPkJn`w>EuI1X`-El{$NCsegfo^f}XMXanTZut%$22}1 z=7}6U=#oB$B$5m7XPR*I$Oa71H7Xm>?Iq9}bk%Blz(|P6|B-G^e#nvLWH}Bj?Mq!7 zA?^6_1$Y(nl&OZeXw<>jG)!vS6I@3$z5?e%SYyi!L_RcwR6a0VN7grpGmTYE96MlE z>ArUeQ0QM8?m=>vbJ!4WMwtWd z*8Aw~Y<_pcbh|{2bGY_v#q*V%tP``>Gcbm!tJr}cY)C%w=Yg-tC&Pd~`NV2%D6{5F zH$HOOByC;6ME(BvAqs*uF^FVD=qbDVr_Y`(+db$rMLYLiT-~*8cv`qxbG{XUzjyQf z9Ss11jRfsF2kXQN8!06usmPLcV^0g(lr|)lBt_GV zv}xZYDk>$upS$<{{r7wRnwci<=f1D|x{mWWj`KLlFJbiHZf0v~PU_|Bl1xEIRK0v) z2aIz}Pcw)I^+Fh;P||nMFpB+?5a!U*$cyQ&dSI+5iqt!_IYAn^SSR;DE$EC<%+|dA z23MQ-PdmIbEEo77=8z^mO`i1sya1Z;`GZl_S$k;1^e^w=T%Gh_CoN?f@}*oUXc!hO zM{|;$0LJ@!n)!zhl>WYhUJYFf3$~Y1HkY7k-870{1}F%GJ*SPZ#JJtsSbO<|ghb&F z0Hf{zsLb^7K^O4YZz0E>#HzI^tM?ly6s?-G3Im!xs|?DZTCizt+m`mKTS^3eBi}P& z`}Ui)wNBVewFsbnJ4w=n=Vp%Xtvd(fUy9chwq~2uafGO zQ_8%ZX}&m>02AJ}hNPEKR9_S;;XU0E+|B-AovaN48A*pPZFDyp&30;0ai~@9Y#_Nr0&IyLhIg3N5GV>ig2tV#AE@c*saq zL?wessc*>kQE6rRoHnoag9n3)?+qK>?qVR`xug0yhy|R1_03VtsIm4C4~$ZC1+*S5 z7|CZUqnuv9d`S*1Cc=8T*k8$PKvKbMHn`><;<(~nJ0gDw&G7ULr8}3p!RwCAx1X^> z;|nK+;1V9Y9b+v+-7iNp==D1zrV}&@CzU-hk{ z3+GnYT3i2sG&i_5>R-^iLo7-Og$DHxT9%h(ZNCxXv5a1+5+Eoh$&|f&nE}5qIr+)+ z=do@KKx-ykkot^7Vvfoa^kYb`-2o7xDR$1;(0O-ff0&R{RyNMk@|!@+7j>K1Vr_&N zVrx1S*$Djj3&=u!!<)yZv_~RS!m)lG+qp1E0m_?sGqkCg1-|^sLg08$I>{=#S0PL; z4g-#jI1R!4OZ2zv7hA-yu7GwRtOYd{^GL3yY_OY~8&b=#m9fosu5?53o#EDxP!TdY6}AYnX8WLMlpD1nQjNK|IYP!t*|pz9LHBnZ~=sk1&*v{N9aS z3IjMN>f=X`9ox*x=1yySC^RAH83j;P-O>OMLMSbs`{&U9q^*Cd z{T!1c@mQK5yK7HF4`gI;q2wq}XewNc%MxoGFbRRe>*Q8rU(CcpGOL%D?!ODt_+VVZ z!vr|FIz!f6@z)pFT>TvQz8}v46SKpNb8uP!9|h+pdiS-@Lqty)#|@b4!Ww$TcM@bT z1k=r^Ab?cN=Bk>S#kf0Xomm1}aj;fxSOdM`Gmsn3OM_Y6ZcV#CZCl@h&xN;Xy_el8 z*q(y+U^<}_)EwJYSdS+b%+TN6G$vtJBD{1%9~5gMa@Tx1<_mr&yzS0ZtQQ0#8$yjm ziwYY%yREa)h`sHM#D&U)4eu*TPH@7x5kF%Z#_Wpl=i=u^!N8YPI>lCP`>byyp11czdqi$h;X>kMtChX3eAS)+z|Brz&flTYj#&=TjT&(r| z`}(90cEagz)6-kgM!H=wtx>o}nT*Ojm)82c8IF#Z*?UAHOO4{jj|}dpDi3*BYAzDd z5(}73ND+rir%4%V7lo;wi6Wg-Lu& zZHECAveQV>e{?U;J0KtjFXf8#_u=vQuE^Jzx3e%W?{4@`39TI@wQQU}dYFRz){R+D zNgt8CbGPN|bToJ}b^FDeCkx}HgCl^FJvjPC^~znYu6~Wfgm9It>3xCG@iPdhiaa)w zC&Nso=>NUcp_GtBE%mVCT-ECRjwvTx!4)}8tmP$m6O?v&@^stG+jtO<&Fy{nkC95> zv<+<0uy8Qj>rZKG?JzYl(egV{c5oKqP#ow`-I@z`)?XLSq$;9zn6hH{>YI*(Y)rxZu%S}Ov z(6jJ$bdJ|Z={wO`Nuiws<#j-UOgD7rb{Q3qX#O&~XP{X`-W10woXg^gJK-s)H`z`% zwe5j4hrd$A1eLX!09*CJ#o5W!S1xQzo8S@+QgezkgR@u_YLJd zdt=ofpe|nMt@>_3c!f7P_Dluw$}_kiGIo-Xpd6 zVpn~Niox*VYD!8CElOs35$%MF7*MK|@kU{Rrl98hefGJF%=4=OH1rYC^xw>B>CJIE z4}PdRYAezx9~b4#YYxHX?XC69rwZm%&TyuOM=_84@?~Ad&0$E13CNzup(7A{yLZnZ z6OV2vBO^E{<%=X%xaKyX^u<@~f4R4Ev@8hmyMoE?SzcbBXxD(F)oZ1P1T8`& zq9y3R%nw^JpC^l)oT{RW1!)3eFLgU^9>MI%Wx!=2`jA-MHKTnl@e$+qY4_K6KVDke z`zCjX^alV1x_>3c* z(~aGBBvAdE~&Q=lMU=#w(J9Vm1?e&Yk^fZR<&OC&{FR|+Di=?Ai;fT zTIxtIIR(@JS@H((?SWW$txI9gOG`^3C&R)vSKUR~ES`N%dC(vRyDz{8%X))a!=C2X z|H2jqgx;>Lodi?q?jDK4As@dVV+Mw^pFqFnLCc}h)VFa0@FRuh(K~lglbP@Z*UEq4 zNdtCx>Tz*bea=3Ed|J3@QN{Wns$KTX2taY=lbib-auoIrD3#!>dw-srD_72>NGN@N z7P1gkiDgtzB&)yV87tSr&FwtOBR!`8492O@t2GL|TJmgAI$P4UtuR?s>|{*=(#zL< z#hZ>_4(kUW_q}FUQ8?w5vEhNb815r{uwA`>&->TGjX(*az*2P|l8${dio6hR*O{_6bl%C<=_A(8JplajbH9^4l0P>!~e^le(dT-KL7UpJB4c< zi4lXcB{~^n0;#8uy31L_juQ;OZnxp$v14ttN79(^!z5fAMdG|rRO2t_D6AXXyyV_- zd>0C>S>NIC`wtovL0>RNuK(C}1!9-w3MW__?4@Kkx5C-m16&3xn;IF789kaWBYeJm zVcT-DHg6(GfoLddCOS)E8S4j)0>Bo`?2U~x4u+)BXc50@6H#44gE>Bx%dy>gs<_S= zUkK2nEXNjw93tQEYpMEDy|Xr^;t6vgmEa!q-S-fm!q7LoDD0j%!A9`h>5ssxIsV!l z{23#L4(;2TWjl}&Nd(7;v}q=G%ZG%J!mQX-5oKpqju%m`HB{(xst;l`1CB_cW2pK$ zQC%QuHnIqsX_hB0gdybFx@ftfgk{*SKVMWN*P6BY1^Wftfr`v93ky|v0=%`WI1bj> z^neXOaP+*T@r(jzp~rAu)!n=a=wye+B?}d3edxrnp+n~rzsRD~Q(jDw4i$&OwTCVT zM*49Wk0p3bbDK262(u3fLKiH&Wo4RNG3LhPLdR65g{H7EU=?9?HzWnQ16ys^b{NDt zPVw}-cXs)F8dUEqbw0-yPqUWLtYC1#DVc$P$Rf|4#kebo%L)B0?kw-kaF@~c-=O{h zrSg_mzI$CJ8pwayB!|??-PLzhOf;JkEkty(#rbI-Xi;k{D z)`o=#zAqG7Fj6s(DkqpDe1JDf=0`t{b<5W+Goju}ShljA^B5QgB{^ZVWX+n+cihJt z@JdPlbNO2^Y6ABMk}Ry%WqDIGJu55qnN#`{Ei?N~(uu(wLch;llL(G_(MHIEUu_Tc z0rtVe3kIWjCO$}I>HytA)(_B)2oqyJfYQD=r6f0`c~oHY?km+}K4QW`X zWYA4v7Fh*tR5+VcBAsJ7KV-3nDJYm47%0viDJCGYk850yO{-DV*j7GaQS#7XNqw`6 zidsK>po8Bo)$yA6iHCl1+EeH=mlW}fT(gR^yZ`9;p~hSSi~31rJvXpU#K%u)o&gVp zFt&Nh>gI}or*k809&>{I_^@RDd>XlKy#7p3;qPk}KV#EjTPSDN>xqA3zP;KX!kIMQ z>#lvKdqrkcMdoYm32yFE&!E3?M-H5)ldH8v!tqWE4-6kROqKG{0`38yVtKjZ`N(f5PbWro?l=E16y%UPU?XJ-MlCATK7C}v<7ANXPZf|aX%51(%v_vN=`Y=ehSEpG_E#mlB3bq*re6^(JB}~%b8H-(!-yHC z)*d(R5g~|{O?dSif=aTT&6H74@F=-2SiEeRa5!$uGqBN85C;EU9z4@n2oo6i?o6@*(MIzdxlzRrym?>!Uy2y_RZ-+NE~t%R0Oa?Pp$) zu*~<#&fwHXr&|iA`~Eq8_vzDnYflcIWAUT@(Slh^%NOh}+7g`K(zmFjFuiYXKi_+C zsos7Ye>-$t{G-^#A-DFgygzcB1ik+8Px^bwYbcyd$1R5A-&f5g%BZY;6p|YUwn1R0ma%tZB>#Y^b#Bd9wgqj$sQBh71|V>6f_}t0GEj zi9)HvP!i{@SIwyHfg$^;mQyuzn4aEQ(`&uVZR;aKZHkKcxNTW~R9!`BCX!(&IOu(} zkLb~%LOJEwF_J4vqJCZhk8tf4Ayytl3ljdo?!@@2g zTEC68v&E>Pb4IRfWmjx7Bw?q*+;_WcIpb`$=UPN!sFIG^9(v`L&XJ-b36aoHs78ky zMyyfaLWQuSOYbiXwpjA*Wz-J41BMD2TL}Jy_D?#lSRvrRBbYx()G{^S+BN6M!0tsY z#|Hmqa;B~5(K5m=EQzr~Q&di1&KChfP9cN48b3*ev|~2}5nAk@tgX1kIl#;74%$w= zzOqbQ0G4u&WpS}S4vNwC3?8z|ir%pf0~2I!#L_#ycrXSG5OQ8icM|ymXMkUy*?B3h zFFvk8Qi`=+?W@ipK}~FPtCUW0&u> z7a*0MJ}kxc;+enk5~!)FQjRl-EMjRvZY3IIMP!#3gAP_}=W0f(N+*W#l&S56Ie?%L zO?jz*pW63UbAj}1VjaMSb@5y?x>rux%e5;D_DnrI&FkIn*$TN{l zaYd>--w<@gN_9tjWAov^->M`yTWTzWVBK?bbtHylj=_Adw?F61&p~a}(V548;ztbj zA8+tN2>+T<=%b{i<;VRY_q(ua`6;__<@Sc=!+yu8pwis(1tQ+qxWjS6mde>CjY1H* z>bBV?;I7UMBEK`JFdPija>4fD>)!1C^+OllI&j$QFbV);+(`HN*4Z+naOjExySYaL zG#?%RBjXlT08bv&3j?dc@ZPllDqpPDAaiQE6=xrHMtZ;s@pjYNt3WSp#8Z#{F%Ksh ztNtBiuAUgiS-ih)^J>d_duVHRPxt_G*g&-{p_o(&*kBQa!NByD{NwZRH=*MJ^jEDE z=hD{rBF$a@Z#Y~hN5^{t^OT@=ZT9BP&u~`bj}(IHwl{qFR)qE0S(jqA>*a#KIdot& zUG*+oDGniN=S3Av?mlT$1hNYA8e2{z8Q4>hy6L5szlcw&F_R%=_f8Pic*(0*3k&Bj zr@}49hoK=)7SQ(9#^q86?XSOnyXrh%tooo53_So979alK!dMv<^+aJ-l3TvA^d=IM z&dp9*?Hm>Dq3fFOmG5Qv?}@XOR1kC>DXXhflTR+3|8XLEzy|!om=b7}r;!0DBpc^= zc$$on>o{lqG=_bl|B8vYhp(8dpN3`fp_%k- ze@gXFV=-pgl872#)knl|KVAdQ*&i>T4>4V7m4UH?5XR6IE6haN#>Pv~w<&G3G^f_B zBq8WppxIDeU1E(|RxS<1QB<#U9Qv%Op&@#;r7e*S*F)IZ5}b38jYT3B@7NGO&R_P; z6G^qz`23kEo$dK6H1C;vl1#!EZYC(p3y#1Z#)oFtQm_*12=|ZqUbj{3h6W_0%`u1spXS1d&YrO9 z&~bKRZ1xAcxrM0RHd^xga2y1m{?6;nyXsqHp{pA}3IP^RY!_Qd@_4B8y}Rp_W417C zoR2nR@H8*c|oVxM4fv#@p?{Nq;<(oeC{9M-&=XY#E zBP{&&On5`ae#B_=<~t~gI~saI0#5}ib zPrlQ>S}L@LD5T#q)q)+u`zr8b3-aCdPd#W2H2dTC-_viuW*VfD7CAP>U)!4LUqJ%$ z#tb~|2vvs&Q^%a+{*`q0QDV${_1XNFU`d<-SvnpCf46i}I$8-iQo?QngsXeiGmC;x zGS)#q%}_<=Z2?Zmj;qIgXVKw__YkL3(enbHA|x6lan|Bvy&7-^2{nNyo8IFHV_914 zA4fcB$H)wi@CVV-{A*EpxnI5)Z!Dk1r+qs-)E$y}b14%7%|M|U9&P(gH?S1hl?59u z$zguEmKh!*(YC8@NW}oX$&)i|BFyf8QvD>)tB*Ue*asAsnN(lJ>gi6QHq sc#wT$c;qqK2KHb#9;}4H|NgksR9Y=3??aU2C=s8D<2{^<9sOhe4`JvAZ~y=R diff --git a/plugins/Generators_CAS/generators.irp.f b/plugins/Generators_CAS/generators.irp.f index 10fbfaee..f47341de 100644 --- a/plugins/Generators_CAS/generators.irp.f +++ b/plugins/Generators_CAS/generators.irp.f @@ -9,14 +9,14 @@ BEGIN_PROVIDER [ integer, N_det_generators ] logical :: good call write_time(output_determinants) N_det_generators = 0 - do i=1,N_det_ref + do i=1,N_det do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) ) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2)) ) enddo if (good) then @@ -41,14 +41,14 @@ END_PROVIDER integer :: i, k, l, m logical :: good m=0 - do i=1,N_det_ref + do i=1,N_det do l=1,n_cas_bitmask good = .True. do k=1,N_int good = good .and. ( & - iand(not(cas_bitmask(k,1,l)), psi_ref(k,1,i)) == & + iand(not(cas_bitmask(k,1,l)), psi_det(k,1,i)) == & iand(not(cas_bitmask(k,1,l)), HF_bitmask(k,1)) .and. ( & - iand(not(cas_bitmask(k,2,l)), psi_ref(k,2,i)) == & + iand(not(cas_bitmask(k,2,l)), psi_det(k,2,i)) == & iand(not(cas_bitmask(k,2,l)), HF_bitmask(k,2) )) ) enddo if (good) then @@ -58,8 +58,8 @@ END_PROVIDER if (good) then m = m+1 do k=1,N_int - psi_det_generators(k,1,m) = psi_ref(k,1,i) - psi_det_generators(k,2,m) = psi_ref(k,2,i) + psi_det_generators(k,1,m) = psi_det(k,1,i) + psi_det_generators(k,2,m) = psi_det(k,2,i) enddo psi_coef_generators(m,:) = psi_coef(m,:) endif diff --git a/plugins/Integrals_erf/EZFIO.cfg b/plugins/Integrals_erf/EZFIO.cfg deleted file mode 100644 index 916bcd34..00000000 --- a/plugins/Integrals_erf/EZFIO.cfg +++ /dev/null @@ -1,34 +0,0 @@ -[disk_access_ao_integrals_erf] -type: Disk_access -doc: Read/Write AO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - - -[disk_access_mo_integrals_erf] -type: Disk_access -doc: Read/Write MO integrals with the long range interaction from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[ao_integrals_threshold] -type: Threshold -doc: If || < ao_integrals_threshold then is zero -interface: ezfio,provider,ocaml -default: 1.e-15 -ezfio_name: threshold_ao - -[mo_integrals_threshold] -type: Threshold -doc: If || < ao_integrals_threshold then is zero -interface: ezfio,provider,ocaml -default: 1.e-15 -ezfio_name: threshold_mo - -[mu_erf] -type: double precision -doc: cutting of the interaction in the range separated model -interface: ezfio,provider,ocaml -default: 0.5 -ezfio_name: mu_erf - diff --git a/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES b/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 8361b2eb..00000000 --- a/plugins/Integrals_erf/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Pseudo Bitmask ZMQ Integrals_Bielec diff --git a/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f b/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f deleted file mode 100644 index 2b4b2fad..00000000 --- a/plugins/Integrals_erf/ao_bi_integrals_erf.irp.f +++ /dev/null @@ -1,570 +0,0 @@ -double precision function ao_bielec_integral_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! integral of the AO basis or (ij|kl) - ! i(r1) j(r1) 1/r12 k(r2) l(r2) - END_DOC - - integer,intent(in) :: i,j,k,l - integer :: p,q,r,s - double precision :: I_center(3),J_center(3),K_center(3),L_center(3) - integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) - double precision :: integral - include 'Utils/constants.include.F' - double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp - double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - integer :: iorder_p(3), iorder_q(3) - double precision :: ao_bielec_integral_schwartz_accel_erf - - if (ao_prim_num(i) * ao_prim_num(j) * ao_prim_num(k) * ao_prim_num(l) > 1024 ) then - ao_bielec_integral_erf = ao_bielec_integral_schwartz_accel_erf(i,j,k,l) - return - endif - - dim1 = n_pt_max_integrals - - num_i = ao_nucl(i) - num_j = ao_nucl(j) - num_k = ao_nucl(k) - num_l = ao_nucl(l) - ao_bielec_integral_erf = 0.d0 - - if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - I_center(p) = nucl_coord(num_i,p) - J_center(p) = nucl_coord(num_j,p) - K_center(p) = nucl_coord(num_k,p) - L_center(p) = nucl_coord(num_l,p) - enddo - - double precision :: coef1, coef2, coef3, coef4 - double precision :: p_inv,q_inv - double precision :: general_primitive_integral_erf - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & - I_power,J_power,I_center,J_center,dim1) - p_inv = 1.d0/pp - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - integral = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - else - - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - enddo - double precision :: ERI_erf - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - do r = 1, ao_prim_num(k) - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - integral = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - I_power(1),J_power(1),K_power(1),L_power(1), & - I_power(2),J_power(2),K_power(2),L_power(2), & - I_power(3),J_power(3),K_power(3),L_power(3)) - ao_bielec_integral_erf = ao_bielec_integral_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - endif - -end - -double precision function ao_bielec_integral_schwartz_accel_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! integral of the AO basis or (ij|kl) - ! i(r1) j(r1) 1/r12 k(r2) l(r2) - END_DOC - integer,intent(in) :: i,j,k,l - integer :: p,q,r,s - double precision :: I_center(3),J_center(3),K_center(3),L_center(3) - integer :: num_i,num_j,num_k,num_l,dim1,I_power(3),J_power(3),K_power(3),L_power(3) - double precision :: integral - include 'Utils/constants.include.F' - double precision :: P_new(0:max_dim,3),P_center(3),fact_p,pp - double precision :: Q_new(0:max_dim,3),Q_center(3),fact_q,qq - integer :: iorder_p(3), iorder_q(3) - double precision, allocatable :: schwartz_kl(:,:) - double precision :: schwartz_ij - - dim1 = n_pt_max_integrals - - num_i = ao_nucl(i) - num_j = ao_nucl(j) - num_k = ao_nucl(k) - num_l = ao_nucl(l) - ao_bielec_integral_schwartz_accel_erf = 0.d0 - double precision :: thr - thr = ao_integrals_threshold*ao_integrals_threshold - - allocate(schwartz_kl(0:ao_prim_num(l),0:ao_prim_num(k))) - - - if (num_i /= num_j .or. num_k /= num_l .or. num_j /= num_k)then - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - I_center(p) = nucl_coord(num_i,p) - J_center(p) = nucl_coord(num_j,p) - K_center(p) = nucl_coord(num_k,p) - L_center(p) = nucl_coord(num_l,p) - enddo - - schwartz_kl(0,0) = 0.d0 - do r = 1, ao_prim_num(k) - coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) - schwartz_kl(0,r) = 0.d0 - do s = 1, ao_prim_num(l) - coef2 = coef1 * ao_coef_normalized_ordered_transp(s,l) * ao_coef_normalized_ordered_transp(s,l) - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - schwartz_kl(s,r) = general_primitive_integral_erf(dim1, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) & - * coef2 - schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) - enddo - schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) - enddo - - do p = 1, ao_prim_num(i) - double precision :: coef1 - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - double precision :: coef2 - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - double precision :: p_inv,q_inv - call give_explicit_poly_and_gaussian(P_new,P_center,pp,fact_p,iorder_p,& - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j), & - I_power,J_power,I_center,J_center,dim1) - p_inv = 1.d0/pp - schwartz_ij = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - P_new,P_center,fact_p,pp,p_inv,iorder_p) * & - coef2*coef2 - if (schwartz_kl(0,0)*schwartz_ij < thr) then - cycle - endif - do r = 1, ao_prim_num(k) - if (schwartz_kl(0,r)*schwartz_ij < thr) then - cycle - endif - double precision :: coef3 - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - double precision :: coef4 - if (schwartz_kl(s,r)*schwartz_ij < thr) then - cycle - endif - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - double precision :: general_primitive_integral_erf - call give_explicit_poly_and_gaussian(Q_new,Q_center,qq,fact_q,iorder_q,& - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l), & - K_power,L_power,K_center,L_center,dim1) - q_inv = 1.d0/qq - integral = general_primitive_integral_erf(dim1, & - P_new,P_center,fact_p,pp,p_inv,iorder_p, & - Q_new,Q_center,fact_q,qq,q_inv,iorder_q) - ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - else - - do p = 1, 3 - I_power(p) = ao_power(i,p) - J_power(p) = ao_power(j,p) - K_power(p) = ao_power(k,p) - L_power(p) = ao_power(l,p) - enddo - double precision :: ERI_erf - - schwartz_kl(0,0) = 0.d0 - do r = 1, ao_prim_num(k) - coef1 = ao_coef_normalized_ordered_transp(r,k)*ao_coef_normalized_ordered_transp(r,k) - schwartz_kl(0,r) = 0.d0 - do s = 1, ao_prim_num(l) - coef2 = coef1*ao_coef_normalized_ordered_transp(s,l)*ao_coef_normalized_ordered_transp(s,l) - schwartz_kl(s,r) = ERI_erf( & - ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - K_power(1),L_power(1),K_power(1),L_power(1), & - K_power(2),L_power(2),K_power(2),L_power(2), & - K_power(3),L_power(3),K_power(3),L_power(3)) * & - coef2 - schwartz_kl(0,r) = max(schwartz_kl(0,r),schwartz_kl(s,r)) - enddo - schwartz_kl(0,0) = max(schwartz_kl(0,r),schwartz_kl(0,0)) - enddo - - do p = 1, ao_prim_num(i) - coef1 = ao_coef_normalized_ordered_transp(p,i) - do q = 1, ao_prim_num(j) - coef2 = coef1*ao_coef_normalized_ordered_transp(q,j) - schwartz_ij = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),& - I_power(1),J_power(1),I_power(1),J_power(1), & - I_power(2),J_power(2),I_power(2),J_power(2), & - I_power(3),J_power(3),I_power(3),J_power(3))*coef2*coef2 - if (schwartz_kl(0,0)*schwartz_ij < thr) then - cycle - endif - do r = 1, ao_prim_num(k) - if (schwartz_kl(0,r)*schwartz_ij < thr) then - cycle - endif - coef3 = coef2*ao_coef_normalized_ordered_transp(r,k) - do s = 1, ao_prim_num(l) - if (schwartz_kl(s,r)*schwartz_ij < thr) then - cycle - endif - coef4 = coef3*ao_coef_normalized_ordered_transp(s,l) - integral = ERI_erf( & - ao_expo_ordered_transp(p,i),ao_expo_ordered_transp(q,j),ao_expo_ordered_transp(r,k),ao_expo_ordered_transp(s,l),& - I_power(1),J_power(1),K_power(1),L_power(1), & - I_power(2),J_power(2),K_power(2),L_power(2), & - I_power(3),J_power(3),K_power(3),L_power(3)) - ao_bielec_integral_schwartz_accel_erf = ao_bielec_integral_schwartz_accel_erf + coef4 * integral - enddo ! s - enddo ! r - enddo ! q - enddo ! p - - endif - deallocate (schwartz_kl) - -end - - -subroutine compute_ao_bielec_integrals_erf(j,k,l,sze,buffer_value) - implicit none - use map_module - - BEGIN_DOC - ! Compute AO 1/r12 integrals for all i and fixed j,k,l - END_DOC - - include 'Utils/constants.include.F' - integer, intent(in) :: j,k,l,sze - real(integral_kind), intent(out) :: buffer_value(sze) - double precision :: ao_bielec_integral_erf - - integer :: i - - if (ao_overlap_abs(j,l) < thresh) then - buffer_value = 0._integral_kind - return - endif - if (ao_bielec_integral_erf_schwartz(j,l) < thresh ) then - buffer_value = 0._integral_kind - return - endif - - do i = 1, ao_num - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thresh) then - buffer_value(i) = 0._integral_kind - cycle - endif - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh ) then - buffer_value(i) = 0._integral_kind - cycle - endif - !DIR$ FORCEINLINE - buffer_value(i) = ao_bielec_integral_erf(i,k,j,l) - enddo - -end - -double precision function general_primitive_integral_erf(dim, & - P_new,P_center,fact_p,p,p_inv,iorder_p, & - Q_new,Q_center,fact_q,q,q_inv,iorder_q) - implicit none - BEGIN_DOC - ! Computes the integral where p,q,r,s are Gaussian primitives - END_DOC - integer,intent(in) :: dim - include 'Utils/constants.include.F' - double precision, intent(in) :: P_new(0:max_dim,3),P_center(3),fact_p,p,p_inv - double precision, intent(in) :: Q_new(0:max_dim,3),Q_center(3),fact_q,q,q_inv - integer, intent(in) :: iorder_p(3) - integer, intent(in) :: iorder_q(3) - - double precision :: r_cut,gama_r_cut,rho,dist - double precision :: dx(0:max_dim),Ix_pol(0:max_dim),dy(0:max_dim),Iy_pol(0:max_dim),dz(0:max_dim),Iz_pol(0:max_dim) - integer :: n_Ix,n_Iy,n_Iz,nx,ny,nz - double precision :: bla - integer :: ix,iy,iz,jx,jy,jz,i - double precision :: a,b,c,d,e,f,accu,pq,const - double precision :: pq_inv, p10_1, p10_2, p01_1, p01_2,pq_inv_2 - integer :: n_pt_tmp,n_pt_out, iorder - double precision :: d1(0:max_dim),d_poly(0:max_dim),rint,d1_screened(0:max_dim) - - general_primitive_integral_erf = 0.d0 - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: dx,Ix_pol,dy,Iy_pol,dz,Iz_pol - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: d1, d_poly - - ! Gaussian Product - ! ---------------- - double precision :: p_plus_q - p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) - pq = p_inv*0.5d0*q_inv - - pq_inv = 0.5d0/p_plus_q - p10_1 = q*pq ! 1/(2p) - p01_1 = p*pq ! 1/(2q) - pq_inv_2 = pq_inv+pq_inv - p10_2 = pq_inv_2 * p10_1*q !0.5d0*q/(pq + p*p) - p01_2 = pq_inv_2 * p01_1*p !0.5d0*p/(q*q + pq) - - - accu = 0.d0 - iorder = iorder_p(1)+iorder_q(1)+iorder_p(1)+iorder_q(1) - !DIR$ VECTOR ALIGNED - do ix=0,iorder - Ix_pol(ix) = 0.d0 - enddo - n_Ix = 0 - do ix = 0, iorder_p(1) - if (abs(P_new(ix,1)) < thresh) cycle - a = P_new(ix,1) - do jx = 0, iorder_q(1) - d = a*Q_new(jx,1) - if (abs(d) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(1),Q_center(1),ix,jx,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dx,nx) - !DEC$ FORCEINLINE - call add_poly_multiply(dx,nx,d,Ix_pol,n_Ix) - enddo - enddo - if (n_Ix == -1) then - return - endif - iorder = iorder_p(2)+iorder_q(2)+iorder_p(2)+iorder_q(2) - !DIR$ VECTOR ALIGNED - do ix=0, iorder - Iy_pol(ix) = 0.d0 - enddo - n_Iy = 0 - do iy = 0, iorder_p(2) - if (abs(P_new(iy,2)) > thresh) then - b = P_new(iy,2) - do jy = 0, iorder_q(2) - e = b*Q_new(jy,2) - if (abs(e) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(2),Q_center(2),iy,jy,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dy,ny) - !DEC$ FORCEINLINE - call add_poly_multiply(dy,ny,e,Iy_pol,n_Iy) - enddo - endif - enddo - if (n_Iy == -1) then - return - endif - - iorder = iorder_p(3)+iorder_q(3)+iorder_p(3)+iorder_q(3) - do ix=0,iorder - Iz_pol(ix) = 0.d0 - enddo - n_Iz = 0 - do iz = 0, iorder_p(3) - if (abs(P_new(iz,3)) > thresh) then - c = P_new(iz,3) - do jz = 0, iorder_q(3) - f = c*Q_new(jz,3) - if (abs(f) < thresh) cycle - !DEC$ FORCEINLINE - call give_polynom_mult_center_x(P_center(3),Q_center(3),iz,jz,p,q,iorder,pq_inv,pq_inv_2,p10_1,p01_1,p10_2,p01_2,dz,nz) - !DEC$ FORCEINLINE - call add_poly_multiply(dz,nz,f,Iz_pol,n_Iz) - enddo - endif - enddo - if (n_Iz == -1) then - return - endif - - rho = p*q *pq_inv_2 ! le rho qui va bien - dist = (P_center(1) - Q_center(1))*(P_center(1) - Q_center(1)) + & - (P_center(2) - Q_center(2))*(P_center(2) - Q_center(2)) + & - (P_center(3) - Q_center(3))*(P_center(3) - Q_center(3)) - const = dist*rho - - n_pt_tmp = n_Ix+n_Iy - do i=0,n_pt_tmp - d_poly(i)=0.d0 - enddo - - !DEC$ FORCEINLINE - call multiply_poly(Ix_pol,n_Ix,Iy_pol,n_Iy,d_poly,n_pt_tmp) - if (n_pt_tmp == -1) then - return - endif - n_pt_out = n_pt_tmp+n_Iz - do i=0,n_pt_out - d1(i)=0.d0 - enddo - - !DEC$ FORCEINLINE - call multiply_poly(d_poly ,n_pt_tmp ,Iz_pol,n_Iz,d1,n_pt_out) - double precision :: rint_sum - accu = accu + rint_sum(n_pt_out,const,d1) - - ! change p+q in dsqrt - general_primitive_integral_erf = fact_p * fact_q * accu *pi_5_2*p_inv*q_inv/dsqrt(p_plus_q) -end - - -double precision function ERI_erf(alpha,beta,delta,gama,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z) - implicit none - BEGIN_DOC - ! ATOMIC PRIMTIVE bielectronic integral between the 4 primitives :: - ! primitive_1 = x1**(a_x) y1**(a_y) z1**(a_z) exp(-alpha * r1**2) - ! primitive_2 = x1**(b_x) y1**(b_y) z1**(b_z) exp(- beta * r1**2) - ! primitive_3 = x2**(c_x) y2**(c_y) z2**(c_z) exp(-delta * r2**2) - ! primitive_4 = x2**(d_x) y2**(d_y) z2**(d_z) exp(- gama * r2**2) - END_DOC - double precision, intent(in) :: delta,gama,alpha,beta - integer, intent(in) :: a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z - integer :: a_x_2,b_x_2,c_x_2,d_x_2,a_y_2,b_y_2,c_y_2,d_y_2,a_z_2,b_z_2,c_z_2,d_z_2 - integer :: i,j,k,l,n_pt - integer :: n_pt_sup - double precision :: p,q,denom,coeff - double precision :: I_f - integer :: nx,ny,nz - include 'Utils/constants.include.F' - nx = a_x+b_x+c_x+d_x - if(iand(nx,1) == 1) then - ERI_erf = 0.d0 - return - endif - - ny = a_y+b_y+c_y+d_y - if(iand(ny,1) == 1) then - ERI_erf = 0.d0 - return - endif - - nz = a_z+b_z+c_z+d_z - if(iand(nz,1) == 1) then - ERI_erf = 0.d0 - return - endif - - ASSERT (alpha >= 0.d0) - ASSERT (beta >= 0.d0) - ASSERT (delta >= 0.d0) - ASSERT (gama >= 0.d0) - p = alpha + beta - q = delta + gama - double precision :: p_plus_q - p_plus_q = (p+q) * ((p*q)/(p+q) + mu_erf*mu_erf)/(mu_erf*mu_erf) - ASSERT (p+q >= 0.d0) - n_pt = ishft( nx+ny+nz,1 ) - - coeff = pi_5_2 / (p * q * dsqrt(p_plus_q)) - if (n_pt == 0) then - ERI_erf = coeff - return - endif - - call integrale_new(I_f,a_x,b_x,c_x,d_x,a_y,b_y,c_y,d_y,a_z,b_z,c_z,d_z,p,q,n_pt) - - ERI_erf = I_f * coeff -end - - - - -subroutine compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) - implicit none - use map_module - BEGIN_DOC - ! Parallel client for AO integrals - END_DOC - - integer, intent(in) :: j,l - integer,intent(out) :: n_integrals - integer(key_kind),intent(out) :: buffer_i(ao_num*ao_num) - real(integral_kind),intent(out) :: buffer_value(ao_num*ao_num) - - integer :: i,k - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - double precision :: integral, wall_0 - double precision :: thr - integer :: kk, m, j1, i1 - - thr = ao_integrals_threshold - - n_integrals = 0 - - j1 = j+ishft(l*l-l,-1) - do k = 1, ao_num ! r1 - i1 = ishft(k*k-k,-1) - if (i1 > j1) then - exit - endif - do i = 1, k - i1 += 1 - if (i1 > j1) then - exit - endif - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < thr) then - cycle - endif - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thr ) then - cycle - endif - !DIR$ FORCEINLINE - integral = ao_bielec_integral_erf(i,k,j,l) ! i,k : r1 j,l : r2 - if (abs(integral) < thr) then - cycle - endif - n_integrals += 1 - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,buffer_i(n_integrals)) - buffer_value(n_integrals) = integral - enddo - enddo - -end diff --git a/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f b/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f deleted file mode 100644 index 36f0e492..00000000 --- a/plugins/Integrals_erf/ao_bielec_integrals_erf_in_map_slave.irp.f +++ /dev/null @@ -1,175 +0,0 @@ -subroutine ao_bielec_integrals_erf_in_map_slave_tcp(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Computes a buffer of integrals. i is the ID of the current thread. - END_DOC - call ao_bielec_integrals_erf_in_map_slave(0,i) -end - - -subroutine ao_bielec_integrals_erf_in_map_slave_inproc(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Computes a buffer of integrals. i is the ID of the current thread. - END_DOC - call ao_bielec_integrals_erf_in_map_slave(1,i) -end - - - -subroutine ao_bielec_integrals_erf_in_map_slave(thread,iproc) - use map_module - use f77_zmq - implicit none - BEGIN_DOC -! Computes a buffer of integrals - END_DOC - - integer, intent(in) :: thread, iproc - - integer :: j,l,n_integrals - integer :: rc - real(integral_kind), allocatable :: buffer_value(:) - integer(key_kind), allocatable :: buffer_i(:) - - integer :: worker_id, task_id - character*(512) :: task - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_push_socket - integer(ZMQ_PTR) :: zmq_socket_push - - character*(64) :: state - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_push = new_zmq_push_socket(thread) - - allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) - - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) exit - read(task,*) j, l - call compute_ao_integrals_erf_jl(j,l,n_integrals,buffer_i,buffer_value) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) - enddo - - - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - deallocate( buffer_i, buffer_value ) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - -end - - -subroutine ao_bielec_integrals_erf_in_map_collector - use map_module - use f77_zmq - implicit none - BEGIN_DOC -! Collects results from the AO integral calculation - END_DOC - - integer :: j,l,n_integrals - integer :: rc - - real(integral_kind), allocatable :: buffer_value(:) - integer(key_kind), allocatable :: buffer_i(:) - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer*8 :: control, accu - integer :: task_id, more, sze - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - - sze = ao_num*ao_num - allocate ( buffer_i(sze), buffer_value(sze) ) - - accu = 0_8 - more = 1 - do while (more == 1) - - rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0) - if (rc == -1) then - n_integrals = 0 - return - endif - if (rc /= 4) then - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)' - stop 'error' - endif - - if (n_integrals >= 0) then - - if (n_integrals > sze) then - deallocate (buffer_value, buffer_i) - sze = n_integrals - allocate (buffer_value(sze), buffer_i(sze)) - endif - - rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0) - if (rc /= key_kind*n_integrals) then - print *, rc, key_kind, n_integrals - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0) - if (rc /= integral_kind*n_integrals) then - print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) - -! Activate if zmq_socket_pull is a REP - rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) - if (rc /= 4) then - print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' - stop 'error' - endif - - - call insert_into_ao_integrals_erf_map(n_integrals,buffer_i,buffer_value) - accu += n_integrals - if (task_id /= 0) then - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - endif - endif - - enddo - - deallocate( buffer_i, buffer_value ) - - integer (map_size_kind) :: get_ao_erf_map_size - control = get_ao_erf_map_size(ao_integrals_erf_map) - - if (control /= accu) then - print *, '' - print *, irp_here - print *, 'Control : ', control - print *, 'Accu : ', accu - print *, 'Some integrals were lost during the parallel computation.' - print *, 'Try to reduce the number of threads.' - stop - endif - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - -end - diff --git a/plugins/Integrals_erf/integrals_3_index_erf.irp.f b/plugins/Integrals_erf/integrals_3_index_erf.irp.f deleted file mode 100644 index d9b1e9f7..00000000 --- a/plugins/Integrals_erf/integrals_3_index_erf.irp.f +++ /dev/null @@ -1,22 +0,0 @@ - BEGIN_PROVIDER [double precision, big_array_coulomb_integrals_erf, (mo_tot_num_align,mo_tot_num, mo_tot_num)] -&BEGIN_PROVIDER [double precision, big_array_exchange_integrals_erf,(mo_tot_num_align,mo_tot_num, mo_tot_num)] - implicit none - integer :: i,j,k,l - double precision :: get_mo_bielec_integral_erf - double precision :: integral - - do k = 1, mo_tot_num - do i = 1, mo_tot_num - do j = 1, mo_tot_num - l = j - integral = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) - big_array_coulomb_integrals_erf(j,i,k) = integral - l = j - integral = get_mo_bielec_integral_erf(i,j,l,k,mo_integrals_erf_map) - big_array_exchange_integrals_erf(j,i,k) = integral - enddo - enddo - enddo - - -END_PROVIDER diff --git a/plugins/Integrals_erf/map_integrals_erf.irp.f b/plugins/Integrals_erf/map_integrals_erf.irp.f deleted file mode 100644 index ecf72282..00000000 --- a/plugins/Integrals_erf/map_integrals_erf.irp.f +++ /dev/null @@ -1,626 +0,0 @@ -use map_module - -!! AO Map -!! ====== - -BEGIN_PROVIDER [ type(map_type), ao_integrals_erf_map ] - implicit none - BEGIN_DOC - ! AO integrals - END_DOC - integer(key_kind) :: key_max - integer(map_size_kind) :: sze - call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) - sze = key_max - call map_init(ao_integrals_erf_map,sze) - print*, 'AO map initialized : ', sze -END_PROVIDER - - BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_min ] -&BEGIN_PROVIDER [ integer, ao_integrals_erf_cache_max ] - implicit none - BEGIN_DOC - ! Min and max values of the AOs for which the integrals are in the cache - END_DOC - ao_integrals_erf_cache_min = max(1,ao_num - 63) - ao_integrals_erf_cache_max = ao_num - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, ao_integrals_erf_cache, (0:64*64*64*64) ] - use map_module - implicit none - BEGIN_DOC - ! Cache of AO integrals for fast access - END_DOC - PROVIDE ao_bielec_integrals_erf_in_map - integer :: i,j,k,l,ii - integer(key_kind) :: idx - real(integral_kind) :: integral - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) - do l=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do k=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do j=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - do i=ao_integrals_erf_cache_min,ao_integrals_erf_cache_max - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(ao_integrals_erf_map,idx,integral) - ii = l-ao_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) - ao_integrals_erf_cache(ii) = integral - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - -double precision function get_ao_bielec_integral_erf(i,j,k,l,map) result(result) - use map_module - implicit none - BEGIN_DOC - ! Gets one AO bi-electronic integral from the AO map - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - type(map_type), intent(inout) :: map - integer :: ii - real(integral_kind) :: tmp - PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_cache ao_integrals_erf_cache_min - !DIR$ FORCEINLINE - if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then - tmp = 0.d0 - else if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < ao_integrals_threshold) then - tmp = 0.d0 - else - ii = l-ao_integrals_erf_cache_min - ii = ior(ii, k-ao_integrals_erf_cache_min) - ii = ior(ii, j-ao_integrals_erf_cache_min) - ii = ior(ii, i-ao_integrals_erf_cache_min) - if (iand(ii, -64) /= 0) then - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - tmp = tmp - else - ii = l-ao_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-ao_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-ao_integrals_erf_cache_min) - tmp = ao_integrals_erf_cache(ii) - endif - endif - result = tmp -end - - -subroutine get_ao_bielec_integrals_erf(j,k,l,sze,out_val) - use map_module - BEGIN_DOC - ! Gets multiple AO bi-electronic integral from the AO map . - ! All i are retrieved for j,k,l fixed. - END_DOC - implicit none - integer, intent(in) :: j,k,l, sze - real(integral_kind), intent(out) :: out_val(sze) - - integer :: i - integer(key_kind) :: hash - double precision :: thresh - PROVIDE ao_bielec_integrals_erf_in_map ao_integrals_erf_map - thresh = ao_integrals_threshold - - if (ao_overlap_abs(j,l) < thresh) then - out_val = 0.d0 - return - endif - - double precision :: get_ao_bielec_integral_erf - do i=1,sze - out_val(i) = get_ao_bielec_integral_erf(i,j,k,l,ao_integrals_erf_map) - enddo - -end - -subroutine get_ao_bielec_integrals_erf_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int) - use map_module - implicit none - BEGIN_DOC - ! Gets multiple AO bi-electronic integral from the AO map . - ! All non-zero i are retrieved for j,k,l fixed. - END_DOC - integer, intent(in) :: j,k,l, sze - real(integral_kind), intent(out) :: out_val(sze) - integer, intent(out) :: out_val_index(sze),non_zero_int - - integer :: i - integer(key_kind) :: hash - double precision :: thresh,tmp - PROVIDE ao_bielec_integrals_erf_in_map - thresh = ao_integrals_threshold - - non_zero_int = 0 - if (ao_overlap_abs(j,l) < thresh) then - out_val = 0.d0 - return - endif - - non_zero_int = 0 - do i=1,sze - integer, external :: ao_l4 - double precision, external :: ao_bielec_integral_erf - !DIR$ FORCEINLINE - if (ao_bielec_integral_erf_schwartz(i,k)*ao_bielec_integral_erf_schwartz(j,l) < thresh) then - cycle - endif - call bielec_integrals_index(i,j,k,l,hash) - call map_get(ao_integrals_erf_map, hash,tmp) - if (dabs(tmp) < thresh ) cycle - non_zero_int = non_zero_int+1 - out_val_index(non_zero_int) = i - out_val(non_zero_int) = tmp - enddo - -end - - -function get_ao_erf_map_size() - implicit none - integer (map_size_kind) :: get_ao_erf_map_size - BEGIN_DOC - ! Returns the number of elements in the AO map - END_DOC - get_ao_erf_map_size = ao_integrals_erf_map % n_elements -end - -subroutine clear_ao_erf_map - implicit none - BEGIN_DOC - ! Frees the memory of the AO map - END_DOC - call map_deinit(ao_integrals_erf_map) - FREE ao_integrals_erf_map -end - - - -BEGIN_TEMPLATE - -subroutine dump_$ao_integrals(filename) - use map_module - implicit none - BEGIN_DOC - ! Save to disk the $ao integrals - END_DOC - character*(*), intent(in) :: filename - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer*8 :: i,j, n - call ezfio_set_work_empty(.False.) - open(unit=66,file=filename,FORM='unformatted') - write(66) integral_kind, key_kind - write(66) $ao_integrals_map%sorted, $ao_integrals_map%map_size, & - $ao_integrals_map%n_elements - do i=0_8,$ao_integrals_map%map_size - write(66) $ao_integrals_map%map(i)%sorted, $ao_integrals_map%map(i)%map_size,& - $ao_integrals_map%map(i)%n_elements - enddo - do i=0_8,$ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - write(66) (key(j), j=1,n), (val(j), j=1,n) - enddo - close(66) - -end - -IRP_IF COARRAY -subroutine communicate_$ao_integrals() - use map_module - implicit none - BEGIN_DOC - ! Communicate the $ao integrals with co-array - END_DOC - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer*8 :: i,j, k, nmax - integer*8, save :: n[*] - integer :: copy_n - - real(integral_kind), allocatable :: buffer_val(:)[:] - integer(cache_key_kind), allocatable :: buffer_key(:)[:] - real(integral_kind), allocatable :: copy_val(:) - integer(key_kind), allocatable :: copy_key(:) - - n = 0_8 - do i=0_8,$ao_integrals_map%map_size - n = max(n,$ao_integrals_map%map(i)%n_elements) - enddo - sync all - nmax = 0_8 - do j=1,num_images() - nmax = max(nmax,n[j]) - enddo - allocate( buffer_key(nmax)[*], buffer_val(nmax)[*]) - allocate( copy_key(nmax), copy_val(nmax)) - do i=0_8,$ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - do j=1,n - buffer_key(j) = key(j) - buffer_val(j) = val(j) - enddo - sync all - do j=1,num_images() - if (j /= this_image()) then - copy_n = n[j] - do k=1,copy_n - copy_val(k) = buffer_val(k)[j] - copy_key(k) = buffer_key(k)[j] - copy_key(k) = copy_key(k)+ishft(i,-map_shift) - enddo - call map_append($ao_integrals_map, copy_key, copy_val, copy_n ) - endif - enddo - sync all - enddo - deallocate( buffer_key, buffer_val, copy_val, copy_key) - -end -IRP_ENDIF - - -integer function load_$ao_integrals(filename) - implicit none - BEGIN_DOC - ! Read from disk the $ao integrals - END_DOC - character*(*), intent(in) :: filename - integer*8 :: i - integer(cache_key_kind), pointer :: key(:) - real(integral_kind), pointer :: val(:) - integer :: iknd, kknd - integer*8 :: n, j - load_$ao_integrals = 1 - open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') - read(66,err=98,end=98) iknd, kknd - if (iknd /= integral_kind) then - print *, 'Wrong integrals kind in file :', iknd - stop 1 - endif - if (kknd /= key_kind) then - print *, 'Wrong key kind in file :', kknd - stop 1 - endif - read(66,err=98,end=98) $ao_integrals_map%sorted, $ao_integrals_map%map_size,& - $ao_integrals_map%n_elements - do i=0_8, $ao_integrals_map%map_size - read(66,err=99,end=99) $ao_integrals_map%map(i)%sorted, & - $ao_integrals_map%map(i)%map_size, $ao_integrals_map%map(i)%n_elements - call cache_map_reallocate($ao_integrals_map%map(i),$ao_integrals_map%map(i)%map_size) - enddo - do i=0_8, $ao_integrals_map%map_size - key => $ao_integrals_map%map(i)%key - val => $ao_integrals_map%map(i)%value - n = $ao_integrals_map%map(i)%n_elements - read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n) - enddo - call map_sort($ao_integrals_map) - load_$ao_integrals = 0 - return - 99 continue - call map_deinit($ao_integrals_map) - 98 continue - stop 'Problem reading $ao_integrals_map file in work/' - -end - -SUBST [ ao_integrals_map, ao_integrals, ao_num ] -ao_integrals_erf_map ; ao_integrals_erf ; ao_num ;; -mo_integrals_erf_map ; mo_integrals_erf ; mo_tot_num;; -END_TEMPLATE - - - - -BEGIN_PROVIDER [ type(map_type), mo_integrals_erf_map ] - implicit none - BEGIN_DOC - ! MO integrals - END_DOC - integer(key_kind) :: key_max - integer(map_size_kind) :: sze - call bielec_integrals_index(mo_tot_num,mo_tot_num,mo_tot_num,mo_tot_num,key_max) - sze = key_max - call map_init(mo_integrals_erf_map,sze) - print*, 'MO map initialized' -END_PROVIDER - -subroutine insert_into_ao_integrals_erf_map(n_integrals,buffer_i, buffer_values) - use map_module - implicit none - BEGIN_DOC - ! Create new entry into AO map - END_DOC - - integer, intent(in) :: n_integrals - integer(key_kind), intent(inout) :: buffer_i(n_integrals) - real(integral_kind), intent(inout) :: buffer_values(n_integrals) - - call map_append(ao_integrals_erf_map, buffer_i, buffer_values, n_integrals) -end - -subroutine insert_into_mo_integrals_erf_map(n_integrals, & - buffer_i, buffer_values, thr) - use map_module - implicit none - - BEGIN_DOC - ! Create new entry into MO map, or accumulate in an existing entry - END_DOC - - integer, intent(in) :: n_integrals - integer(key_kind), intent(inout) :: buffer_i(n_integrals) - real(integral_kind), intent(inout) :: buffer_values(n_integrals) - real(integral_kind), intent(in) :: thr - call map_update(mo_integrals_erf_map, buffer_i, buffer_values, n_integrals, thr) -end - - BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_min ] -&BEGIN_PROVIDER [ integer, mo_integrals_erf_cache_max ] - implicit none - BEGIN_DOC - ! Min and max values of the MOs for which the integrals are in the cache - END_DOC - mo_integrals_erf_cache_min = max(1,elec_alpha_num - 31) - mo_integrals_erf_cache_max = min(mo_tot_num,mo_integrals_erf_cache_min+63) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, mo_integrals_erf_cache, (0:64*64*64*64) ] - implicit none - BEGIN_DOC - ! Cache of MO integrals for fast access - END_DOC - PROVIDE mo_bielec_integrals_erf_in_map - integer :: i,j,k,l - integer :: ii - integer(key_kind) :: idx - real(integral_kind) :: integral - FREE ao_integrals_erf_cache - !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral) - do l=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do k=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do j=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - do i=mo_integrals_erf_cache_min,mo_integrals_erf_cache_max - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(mo_integrals_erf_map,idx,integral) - ii = l-mo_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) - mo_integrals_erf_cache(ii) = integral - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - -double precision function get_mo_bielec_integral_erf(i,j,k,l,map) - use map_module - implicit none - BEGIN_DOC - ! Returns one integral in the MO basis - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind) :: idx - integer :: ii - type(map_type), intent(inout) :: map - real(integral_kind) :: tmp - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache - ii = l-mo_integrals_erf_cache_min - ii = ior(ii, k-mo_integrals_erf_cache_min) - ii = ior(ii, j-mo_integrals_erf_cache_min) - ii = ior(ii, i-mo_integrals_erf_cache_min) - if (iand(ii, -64) /= 0) then - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,idx) - !DIR$ FORCEINLINE - call map_get(map,idx,tmp) - get_mo_bielec_integral_erf = dble(tmp) - else - ii = l-mo_integrals_erf_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_erf_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_erf_cache_min) - get_mo_bielec_integral_erf = mo_integrals_erf_cache(ii) - endif -end - - -double precision function mo_bielec_integral_erf(i,j,k,l) - implicit none - BEGIN_DOC - ! Returns one integral in the MO basis - END_DOC - integer, intent(in) :: i,j,k,l - double precision :: get_mo_bielec_integral_erf - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_cache - !DIR$ FORCEINLINE - PROVIDE mo_bielec_integrals_erf_in_map - mo_bielec_integral_erf = get_mo_bielec_integral_erf(i,j,k,l,mo_integrals_erf_map) - return -end - -subroutine get_mo_bielec_integrals_erf(j,k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals in the MO basis, all - ! i for j,k,l fixed. - END_DOC - integer, intent(in) :: j,k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -subroutine get_mo_bielec_integrals_erf_ij(k,l,sze,out_array,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals in the MO basis, all - ! i(1)j(2) 1/r12 k(1)l(2) - ! i, j for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_array(sze,sze) - type(map_type), intent(inout) :: map - integer :: i,j,kk,ll,m - integer(key_kind),allocatable :: hash(:) - integer ,allocatable :: pairs(:,:), iorder(:) - real(integral_kind), allocatable :: tmp_val(:) - - PROVIDE mo_bielec_integrals_erf_in_map - allocate (hash(sze*sze), pairs(2,sze*sze),iorder(sze*sze), & - tmp_val(sze*sze)) - - kk=0 - out_array = 0.d0 - do j=1,sze - do i=1,sze - kk += 1 - !DIR$ FORCEINLINE - call bielec_integrals_index(i,j,k,l,hash(kk)) - pairs(1,kk) = i - pairs(2,kk) = j - iorder(kk) = kk - enddo - enddo - - logical :: integral_is_in_map - if (key_kind == 8) then - call i8radix_sort(hash,iorder,kk,-1) - else if (key_kind == 4) then - call iradix_sort(hash,iorder,kk,-1) - else if (key_kind == 2) then - call i2radix_sort(hash,iorder,kk,-1) - endif - - call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk) - - do ll=1,kk - m = iorder(ll) - i=pairs(1,m) - j=pairs(2,m) - out_array(i,j) = tmp_val(ll) - enddo - - deallocate(pairs,hash,iorder,tmp_val) -end - -subroutine get_mo_bielec_integrals_erf_coulomb_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 l(1)i(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,l,i,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - -subroutine get_mo_bielec_integrals_erf_exch_ii(k,l,sze,out_val,map) - use map_module - implicit none - BEGIN_DOC - ! Returns multiple integrals - ! k(1)i(2) 1/r12 i(1)l(2) :: out_val(i1) - ! for k,l fixed. - END_DOC - integer, intent(in) :: k,l, sze - double precision, intent(out) :: out_val(sze) - type(map_type), intent(inout) :: map - integer :: i - integer(key_kind) :: hash(sze) - real(integral_kind) :: tmp_val(sze) - PROVIDE mo_bielec_integrals_erf_in_map - - integer :: kk - do i=1,sze - !DIR$ FORCEINLINE - call bielec_integrals_index(k,i,i,l,hash(i)) - enddo - - if (key_kind == 8) then - call map_get_many(map, hash, out_val, sze) - else - call map_get_many(map, hash, tmp_val, sze) - ! Conversion to double precision - do i=1,sze - out_val(i) = dble(tmp_val(i)) - enddo - endif -end - - -integer*8 function get_mo_erf_map_size() - implicit none - BEGIN_DOC - ! Return the number of elements in the MO map - END_DOC - get_mo_erf_map_size = mo_integrals_erf_map % n_elements -end diff --git a/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f b/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f deleted file mode 100644 index b0c954c1..00000000 --- a/plugins/Integrals_erf/mo_bi_integrals_erf.irp.f +++ /dev/null @@ -1,616 +0,0 @@ -subroutine mo_bielec_integrals_erf_index(i,j,k,l,i1) - use map_module - implicit none - BEGIN_DOC - ! Computes an unique index for i,j,k,l integrals - END_DOC - integer, intent(in) :: i,j,k,l - integer(key_kind), intent(out) :: i1 - integer(key_kind) :: p,q,r,s,i2 - p = min(i,k) - r = max(i,k) - p = p+ishft(r*r-r,-1) - q = min(j,l) - s = max(j,l) - q = q+ishft(s*s-s,-1) - i1 = min(p,q) - i2 = max(p,q) - i1 = i1+ishft(i2*i2-i2,-1) -end - - -BEGIN_PROVIDER [ logical, mo_bielec_integrals_erf_in_map ] - use map_module - implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - - BEGIN_DOC - ! If True, the map of MO bielectronic integrals is provided - END_DOC - - mo_bielec_integrals_erf_in_map = .True. - if (read_mo_integrals_erf) then - print*,'Reading the MO integrals_erf' - call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - print*, 'MO integrals_erf provided' - return - else - PROVIDE ao_bielec_integrals_erf_in_map - endif - - !if(no_vvvv_integrals)then - ! integer :: i,j,k,l - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 4 - ! ! - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 2 (virt) ^2 - ! ! = J_iv - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = virt_bitmask(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! - ! ! (core+inact+act) ^ 2 (virt) ^2 - ! ! = (iv|iv) - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = virt_bitmask(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! - ! if(.not.no_vvv_integrals)then - ! print*, '' - ! print*, ' and ' - ! do i = 1,N_int - ! mask_ijk(i,1) = virt_bitmask(i,1) - ! mask_ijk(i,2) = virt_bitmask(i,1) - ! mask_ijk(i,3) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map_three_indices(mask_ijk) - ! endif - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 3 (virt) ^1 - ! ! - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map(mask_ijkl) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! - ! ! (core+inact+act) ^ 1 (virt) ^3 - ! ! - ! if(.not.no_ivvv_integrals)then - ! print*, '' - ! print*, '' - ! do i = 1,N_int - ! mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - ! mask_ijkl(i,2) = virt_bitmask(i,1) - ! mask_ijkl(i,3) = virt_bitmask(i,1) - ! mask_ijkl(i,4) = virt_bitmask(i,1) - ! enddo - ! call add_integrals_to_map_no_exit_34(mask_ijkl) - ! endif - ! - !else - call add_integrals_erf_to_map(full_ijkl_bitmask_4) - !endif - if (write_mo_integrals_erf) then - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_erf',mo_integrals_erf_map) - call ezfio_set_integrals_erf_disk_access_mo_integrals_erf("Read") - endif - -END_PROVIDER - -subroutine add_integrals_erf_to_map(mask_ijkl) - use bitmasks - implicit none - - BEGIN_DOC - ! Adds integrals to tha MO map according to some bitmask - END_DOC - - integer(bit_kind), intent(in) :: mask_ijkl(N_int,4) - - integer :: i,j,k,l - integer :: i0,j0,k0,l0 - double precision :: c, cpu_1, cpu_2, wall_1, wall_2, wall_0 - - integer, allocatable :: list_ijkl(:,:) - integer :: n_i, n_j, n_k, n_l - integer, allocatable :: bielec_tmp_0_idx(:) - real(integral_kind), allocatable :: bielec_tmp_0(:,:) - double precision, allocatable :: bielec_tmp_1(:) - double precision, allocatable :: bielec_tmp_2(:,:) - double precision, allocatable :: bielec_tmp_3(:,:,:) - !DEC$ ATTRIBUTES ALIGN : 64 :: bielec_tmp_1, bielec_tmp_2, bielec_tmp_3 - - integer :: n_integrals - integer :: size_buffer - integer(key_kind),allocatable :: buffer_i(:) - real(integral_kind),allocatable :: buffer_value(:) - real :: map_mb - - integer :: i1,j1,k1,l1, ii1, kmax, thread_num - integer :: i2,i3,i4 - double precision,parameter :: thr_coef = 1.d-10 - - PROVIDE ao_bielec_integrals_erf_in_map mo_coef - - !Get list of MOs for i,j,k and l - !------------------------------- - - allocate(list_ijkl(mo_tot_num,4)) - call bitstring_to_list( mask_ijkl(1,1), list_ijkl(1,1), n_i, N_int ) - call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) - call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) - call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) - character*(2048) :: output(1) - print*, 'i' - call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,1)) - enddo - if(j==0)then - return - endif - - print*, 'j' - call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,2)) - enddo - if(j==0)then - return - endif - - print*, 'k' - call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,3)) - enddo - if(j==0)then - return - endif - - print*, 'l' - call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) - print *, trim(output(1)) - j = 0 - do i = 1, N_int - j += popcnt(mask_ijkl(i,4)) - enddo - if(j==0)then - return - endif - - size_buffer = min(ao_num*ao_num*ao_num,16000000) - print*, 'Providing the molecular integrals ' - print*, 'Buffers : ', 8.*(mo_tot_num_align*(n_j)*(n_k+1) + mo_tot_num_align +& - ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - - call wall_time(wall_1) - call cpu_time(cpu_1) - double precision :: accu_bis - accu_bis = 0.d0 - - !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & - !$OMP bielec_tmp_0_idx, bielec_tmp_0, bielec_tmp_1,bielec_tmp_2,bielec_tmp_3,& - !$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, & - !$OMP wall_0,thread_num,accu_bis) & - !$OMP DEFAULT(NONE) & - !$OMP SHARED(size_buffer,ao_num,mo_tot_num,n_i,n_j,n_k,n_l,mo_tot_num_align,& - !$OMP mo_coef_transp, & - !$OMP mo_coef_transp_is_built, list_ijkl, & - !$OMP mo_coef_is_built, wall_1, & - !$OMP mo_coef,mo_integrals_threshold,mo_integrals_erf_map) - n_integrals = 0 - wall_0 = wall_1 - allocate(bielec_tmp_3(mo_tot_num_align, n_j, n_k), & - bielec_tmp_1(mo_tot_num_align), & - bielec_tmp_0(ao_num,ao_num), & - bielec_tmp_0_idx(ao_num), & - bielec_tmp_2(mo_tot_num_align, n_j), & - buffer_i(size_buffer), & - buffer_value(size_buffer) ) - - thread_num = 0 - !$ thread_num = omp_get_thread_num() - !$OMP DO SCHEDULE(guided) - do l1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_3 = 0.d0 - do k1 = 1,ao_num - !DEC$ VECTOR ALIGNED - bielec_tmp_2 = 0.d0 - do j1 = 1,ao_num - call get_ao_bielec_integrals_erf(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - ! call compute_ao_bielec_integrals(j1,k1,l1,ao_num,bielec_tmp_0(1,j1)) - enddo - do j1 = 1,ao_num - kmax = 0 - do i1 = 1,ao_num - c = bielec_tmp_0(i1,j1) - if (c == 0.d0) then - cycle - endif - kmax += 1 - bielec_tmp_0(kmax,j1) = c - bielec_tmp_0_idx(kmax) = i1 - enddo - - if (kmax==0) then - cycle - endif - - !DEC$ VECTOR ALIGNED - bielec_tmp_1 = 0.d0 - ii1=1 - do ii1 = 1,kmax-4,4 - i1 = bielec_tmp_0_idx(ii1) - i2 = bielec_tmp_0_idx(ii1+1) - i3 = bielec_tmp_0_idx(ii1+2) - i4 = bielec_tmp_0_idx(ii1+3) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + & - mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) + & - mo_coef_transp(i,i2) * bielec_tmp_0(ii1+1,j1) + & - mo_coef_transp(i,i3) * bielec_tmp_0(ii1+2,j1) + & - mo_coef_transp(i,i4) * bielec_tmp_0(ii1+3,j1) - enddo ! i - enddo ! ii1 - - i2 = ii1 - do ii1 = i2,kmax - i1 = bielec_tmp_0_idx(ii1) - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_1(i) = bielec_tmp_1(i) + mo_coef_transp(i,i1) * bielec_tmp_0(ii1,j1) - enddo ! i - enddo ! ii1 - c = 0.d0 - - do i = list_ijkl(1,1), list_ijkl(n_i,1) - c = max(c,abs(bielec_tmp_1(i))) - if (c>mo_integrals_threshold) exit - enddo - if ( c < mo_integrals_threshold ) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - c = mo_coef_transp(j,j1) - if (abs(c) < thr_coef) then - cycle - endif - do i = list_ijkl(1,1), list_ijkl(n_i,1) - bielec_tmp_2(i,j0) = bielec_tmp_2(i,j0) + c * bielec_tmp_1(i) - enddo ! i - enddo ! j - enddo !j1 - if ( maxval(abs(bielec_tmp_2)) < mo_integrals_threshold ) then - cycle - endif - - - do k0 = 1, n_k - k = list_ijkl(k0,3) - c = mo_coef_transp(k,k1) - if (abs(c) < thr_coef) then - cycle - endif - - do j0 = 1, n_j - j = list_ijkl(j0,2) - do i = list_ijkl(1,1), k - bielec_tmp_3(i,j0,k0) = bielec_tmp_3(i,j0,k0) + c* bielec_tmp_2(i,j0) - enddo!i - enddo !j - - enddo !k - enddo !k1 - - - - do l0 = 1,n_l - l = list_ijkl(l0,4) - c = mo_coef_transp(l,l1) - if (abs(c) < thr_coef) then - cycle - endif - j1 = ishft((l*l-l),-1) - do j0 = 1, n_j - j = list_ijkl(j0,2) - if (j > l) then - exit - endif - j1 += 1 - do k0 = 1, n_k - k = list_ijkl(k0,3) - i1 = ishft((k*k-k),-1) - if (i1<=j1) then - continue - else - exit - endif - bielec_tmp_1 = 0.d0 - do i0 = 1, n_i - i = list_ijkl(i0,1) - if (i>k) then - exit - endif - bielec_tmp_1(i) = c*bielec_tmp_3(i,j0,k0) - ! i1+=1 - enddo - - do i0 = 1, n_i - i = list_ijkl(i0,1) - if(i> min(k,j1-i1+list_ijkl(1,1)-1))then - exit - endif - if (abs(bielec_tmp_1(i)) < mo_integrals_threshold) then - cycle - endif - n_integrals += 1 - buffer_value(n_integrals) = bielec_tmp_1(i) - !DEC$ FORCEINLINE - call mo_bielec_integrals_erf_index(i,j,k,l,buffer_i(n_integrals)) - if (n_integrals == size_buffer) then - call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - n_integrals = 0 - endif - enddo - enddo - enddo - enddo - - call wall_time(wall_2) - if (thread_num == 0) then - if (wall_2 - wall_0 > 1.d0) then - wall_0 = wall_2 - print*, 100.*float(l1)/float(ao_num), '% in ', & - wall_2-wall_1, 's', map_mb(mo_integrals_erf_map) ,'MB' - endif - endif - enddo - !$OMP END DO NOWAIT - deallocate (bielec_tmp_1,bielec_tmp_2,bielec_tmp_3) - - integer :: index_needed - - call insert_into_mo_integrals_erf_map(n_integrals,buffer_i,buffer_value,& - real(mo_integrals_threshold,integral_kind)) - deallocate(buffer_i, buffer_value) - !$OMP END PARALLEL - call map_unique(mo_integrals_erf_map) - - call wall_time(wall_2) - call cpu_time(cpu_2) - integer*8 :: get_mo_erf_map_size, mo_erf_map_size - mo_erf_map_size = get_mo_erf_map_size() - - deallocate(list_ijkl) - - - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_erf_map) ,'MB' - print*,' Number of MO integrals: ', mo_erf_map_size - print*,' cpu time :',cpu_2 - cpu_1, 's' - print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - -end - - - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange_from_ao, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti_from_ao, (mo_tot_num_align,mo_tot_num) ] - BEGIN_DOC - ! mo_bielec_integral_jj_from_ao(i,j) = J_ij - ! mo_bielec_integral_jj_exchange_from_ao(i,j) = J_ij - ! mo_bielec_integral_jj_anti_from_ao(i,j) = J_ij - K_ij - END_DOC - implicit none - integer :: i,j,p,q,r,s - double precision :: c - real(integral_kind) :: integral - integer :: n, pp - real(integral_kind), allocatable :: int_value(:) - integer, allocatable :: int_idx(:) - - double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) - - if (.not.do_direct_integrals) then - PROVIDE ao_bielec_integrals_erf_in_map mo_coef - endif - - mo_bielec_integral_erf_jj_from_ao = 0.d0 - mo_bielec_integral_erf_jj_exchange_from_ao = 0.d0 - - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: iqrs, iqsr - - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE (i,j,p,q,r,s,integral,c,n,pp,int_value,int_idx, & - !$OMP iqrs, iqsr,iqri,iqis) & - !$OMP SHARED(mo_tot_num,mo_coef_transp,mo_tot_num_align,ao_num,& - !$OMP ao_integrals_threshold,do_direct_integrals) & - !$OMP REDUCTION(+:mo_bielec_integral_erf_jj_from_ao,mo_bielec_integral_erf_jj_exchange_from_ao) - - allocate( int_value(ao_num), int_idx(ao_num), & - iqrs(mo_tot_num_align,ao_num), iqis(mo_tot_num), iqri(mo_tot_num),& - iqsr(mo_tot_num_align,ao_num) ) - - !$OMP DO SCHEDULE (guided) - do s=1,ao_num - do q=1,ao_num - - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,j) = 0.d0 - iqsr(i,j) = 0.d0 - enddo - enddo - - if (do_direct_integrals) then - double precision :: ao_bielec_integral_erf - do r=1,ao_num - call compute_ao_bielec_integrals_erf(q,r,s,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call compute_ao_bielec_integrals_erf(q,s,r,ao_num,int_value) - do p=1,ao_num - integral = int_value(p) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - enddo - - else - - do r=1,ao_num - call get_ao_bielec_integrals_erf_non_zero(q,r,s,ao_num,int_value,int_idx,n) - do pp=1,n - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqrs(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - call get_ao_bielec_integrals_erf_non_zero(q,s,r,ao_num,int_value,int_idx,n) - do pp=1,n - p = int_idx(pp) - integral = int_value(pp) - if (abs(integral) > ao_integrals_threshold) then - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqsr(i,r) += mo_coef_transp(i,p) * integral - enddo - endif - enddo - enddo - endif - iqis = 0.d0 - iqri = 0.d0 - do r=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,mo_tot_num - iqis(i) += mo_coef_transp(i,r) * iqrs(i,r) - iqri(i) += mo_coef_transp(i,r) * iqsr(i,r) - enddo - enddo - do i=1,mo_tot_num - !DIR$ VECTOR ALIGNED - do j=1,mo_tot_num - c = mo_coef_transp(j,q)*mo_coef_transp(j,s) - mo_bielec_integral_erf_jj_from_ao(j,i) += c * iqis(i) - mo_bielec_integral_erf_jj_exchange_from_ao(j,i) += c * iqri(i) - enddo - enddo - - enddo - enddo - !$OMP END DO NOWAIT - deallocate(iqrs,iqsr,int_value,int_idx) - !$OMP END PARALLEL - - mo_bielec_integral_erf_jj_anti_from_ao = mo_bielec_integral_erf_jj_from_ao - mo_bielec_integral_erf_jj_exchange_from_ao - - -! end -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_exchange, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, mo_bielec_integral_erf_jj_anti, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! mo_bielec_integral_jj(i,j) = J_ij - ! mo_bielec_integral_jj_exchange(i,j) = K_ij - ! mo_bielec_integral_jj_anti(i,j) = J_ij - K_ij - END_DOC - - integer :: i,j - double precision :: get_mo_bielec_integral_erf - - PROVIDE mo_bielec_integrals_erf_in_map - mo_bielec_integral_erf_jj = 0.d0 - mo_bielec_integral_erf_jj_exchange = 0.d0 - - do j=1,mo_tot_num - do i=1,mo_tot_num - mo_bielec_integral_erf_jj(i,j) = get_mo_bielec_integral_erf(i,j,i,j,mo_integrals_erf_map) - mo_bielec_integral_erf_jj_exchange(i,j) = get_mo_bielec_integral_erf(i,j,j,i,mo_integrals_erf_map) - mo_bielec_integral_erf_jj_anti(i,j) = mo_bielec_integral_erf_jj(i,j) - mo_bielec_integral_erf_jj_exchange(i,j) - enddo - enddo - -END_PROVIDER - - -subroutine clear_mo_erf_map - implicit none - BEGIN_DOC - ! Frees the memory of the MO map - END_DOC - call map_deinit(mo_integrals_erf_map) - FREE mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti - FREE mo_bielec_integral_Erf_jj_exchange mo_bielec_integrals_erf_in_map - - -end - -subroutine provide_all_mo_integrals_erf - implicit none - provide mo_integrals_erf_map mo_bielec_integral_erf_jj mo_bielec_integral_erf_jj_anti - provide mo_bielec_integral_erf_jj_exchange mo_bielec_integrals_erf_in_map - -end diff --git a/plugins/Integrals_erf/providers_ao_erf.irp.f b/plugins/Integrals_erf/providers_ao_erf.irp.f deleted file mode 100644 index 1507d1be..00000000 --- a/plugins/Integrals_erf/providers_ao_erf.irp.f +++ /dev/null @@ -1,119 +0,0 @@ - -BEGIN_PROVIDER [ logical, ao_bielec_integrals_erf_in_map ] - implicit none - use f77_zmq - use map_module - BEGIN_DOC - ! Map of Atomic integrals - ! i(r1) j(r2) 1/r12 k(r1) l(r2) - END_DOC - - integer :: i,j,k,l - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - double precision :: integral, wall_0 - include 'Utils/constants.include.F' - - ! For integrals file - integer(key_kind),allocatable :: buffer_i(:) - integer,parameter :: size_buffer = 1024*64 - real(integral_kind),allocatable :: buffer_value(:) - - integer :: n_integrals, rc - integer :: kk, m, j1, i1, lmax - character*(64) :: fmt - - integral = ao_bielec_integral_erf(1,1,1,1) - - real :: map_mb - PROVIDE read_ao_integrals_erf disk_access_ao_integrals_erf - if (read_ao_integrals_erf) then - print*,'Reading the AO integrals_erf' - call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - print*, 'AO integrals_erf provided' - ao_bielec_integrals_erf_in_map = .True. - return - endif - - print*, 'Providing the AO integrals_erf' - call wall_time(wall_0) - call wall_time(wall_1) - call cpu_time(cpu_1) - - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals_erf') - - character(len=:), allocatable :: task - allocate(character(len=ao_num*12) :: task) - write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' - do l=1,ao_num - write(task,fmt) (i,l, i=1,l) - call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) - enddo - deallocate(task) - - call zmq_set_running(zmq_to_qp_run_socket) - - PROVIDE nproc - !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call ao_bielec_integrals_erf_in_map_collector(i) - else - call ao_bielec_integrals_erf_in_map_slave_inproc(i) - endif - !$OMP END PARALLEL - - call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals_erf') - - - print*, 'Sorting the map' - call map_sort(ao_integrals_erf_map) - call cpu_time(cpu_2) - call wall_time(wall_2) - integer(map_size_kind) :: get_ao_erf_map_size, ao_erf_map_size - ao_erf_map_size = get_ao_erf_map_size() - - print*, 'AO integrals provided:' - print*, ' Size of AO map : ', map_mb(ao_integrals_erf_map) ,'MB' - print*, ' Number of AO integrals :', ao_erf_map_size - print*, ' cpu time :',cpu_2 - cpu_1, 's' - print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' - - ao_bielec_integrals_erf_in_map = .True. - - if (write_ao_integrals_erf) then - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_erf',ao_integrals_erf_map) - call ezfio_set_integrals_erf_disk_access_ao_integrals_erf("Read") - endif - -END_PROVIDER - - - - -BEGIN_PROVIDER [ double precision, ao_bielec_integral_erf_schwartz,(ao_num,ao_num) ] - implicit none - BEGIN_DOC - ! Needed to compute Schwartz inequalities - END_DOC - - integer :: i,k - double precision :: ao_bielec_integral_erf,cpu_1,cpu_2, wall_1, wall_2 - - ao_bielec_integral_erf_schwartz(1,1) = ao_bielec_integral_erf(1,1,1,1) - !$OMP PARALLEL DO PRIVATE(i,k) & - !$OMP DEFAULT(NONE) & - !$OMP SHARED (ao_num,ao_bielec_integral_erf_schwartz) & - !$OMP SCHEDULE(dynamic) - do i=1,ao_num - do k=1,i - ao_bielec_integral_erf_schwartz(i,k) = dsqrt(ao_bielec_integral_erf(i,k,i,k)) - ao_bielec_integral_erf_schwartz(k,i) = ao_bielec_integral_erf_schwartz(i,k) - enddo - enddo - !$OMP END PARALLEL DO - -END_PROVIDER - - diff --git a/plugins/Integrals_erf/qp_ao_erf_ints.irp.f b/plugins/Integrals_erf/qp_ao_erf_ints.irp.f deleted file mode 100644 index df6d8d16..00000000 --- a/plugins/Integrals_erf/qp_ao_erf_ints.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -program qp_ao_ints - use omp_lib - implicit none - BEGIN_DOC -! Increments a running calculation to compute AO integral_erfs - END_DOC - integer :: i - - call switch_qp_run_to_master - - zmq_context = f77_zmq_ctx_new () - - ! Set the state of the ZMQ - zmq_state = 'ao_integral_erfs' - - ! Provide everything needed - double precision :: integral_erf, ao_bielec_integral_erf - integral_erf = ao_bielec_integral_erf(1,1,1,1) - - character*(64) :: state - call wait_for_state(zmq_state,state) - do while (state /= 'Stopped') - !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) - i = omp_get_thread_num() - call ao_bielec_integrals_erf_in_map_slave_tcp(i) - !$OMP END PARALLEL - call wait_for_state(zmq_state,state) - enddo - - print *, 'Done' -end - diff --git a/plugins/Integrals_erf/read_write.irp.f b/plugins/Integrals_erf/read_write.irp.f deleted file mode 100644 index 12bbf0bc..00000000 --- a/plugins/Integrals_erf/read_write.irp.f +++ /dev/null @@ -1,47 +0,0 @@ -BEGIN_PROVIDER [ logical, read_ao_integrals_erf ] -&BEGIN_PROVIDER [ logical, read_mo_integrals_erf ] -&BEGIN_PROVIDER [ logical, write_ao_integrals_erf ] -&BEGIN_PROVIDER [ logical, write_mo_integrals_erf ] - - BEGIN_DOC -! One level of abstraction for disk_access_ao_integrals_erf and disk_access_mo_integrals_erf - END_DOC -implicit none - - if (disk_access_ao_integrals_erf.EQ.'Read') then - read_ao_integrals_erf = .True. - write_ao_integrals_erf = .False. - - else if (disk_access_ao_integrals_erf.EQ.'Write') then - read_ao_integrals_erf = .False. - write_ao_integrals_erf = .True. - - else if (disk_access_ao_integrals_erf.EQ.'None') then - read_ao_integrals_erf = .False. - write_ao_integrals_erf = .False. - - else - print *, 'bielec_integrals_erf/disk_access_ao_integrals_erf has a wrong type' - stop 1 - - endif - - if (disk_access_mo_integrals_erf.EQ.'Read') then - read_mo_integrals_erf = .True. - write_mo_integrals_erf = .False. - - else if (disk_access_mo_integrals_erf.EQ.'Write') then - read_mo_integrals_erf = .False. - write_mo_integrals_erf = .True. - - else if (disk_access_mo_integrals_erf.EQ.'None') then - read_mo_integrals_erf = .False. - write_mo_integrals_erf = .False. - - else - print *, 'bielec_integrals_erf/disk_access_mo_integrals_erf has a wrong type' - stop 1 - - endif - -END_PROVIDER diff --git a/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES b/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 08317b5e..00000000 --- a/plugins/Integrals_restart_DFT/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Monoelec Integrals_erf Determinants DFT_Utils diff --git a/plugins/Integrals_restart_DFT/README.rst b/plugins/Integrals_restart_DFT/README.rst deleted file mode 100644 index 589e0a00..00000000 --- a/plugins/Integrals_restart_DFT/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -============== -core_integrals -============== - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f b/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f deleted file mode 100644 index aeb2589c..00000000 --- a/plugins/Integrals_restart_DFT/short_range_coulomb.irp.f +++ /dev/null @@ -1,79 +0,0 @@ -BEGIN_PROVIDER [double precision, density_matrix_read, (mo_tot_num, mo_tot_num)] - implicit none - integer :: i,j,k,l - logical :: exists - call ezfio_has_determinants_density_matrix_mo_disk(exists) - if(exists)then - print*, 'reading the density matrix from input' - call ezfio_get_determinants_density_matrix_mo_disk(exists) - print*, 'reading done' - else - print*, 'no density matrix found in EZFIO file ...' - print*, 'stopping ..' - stop - endif - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, effective_short_range_operator, (mo_tot_num,mo_tot_num)] - implicit none - integer :: i,j,k,l,m,n - double precision :: get_mo_bielec_integral,get_mo_bielec_integral_erf - double precision :: integral, integral_erf - effective_short_range_operator = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - if(dabs(one_body_dm_mo(i,j)).le.1.d-10)cycle - do k = 1, mo_tot_num - do l = 1, mo_tot_num - integral = get_mo_bielec_integral(i,k,j,l,mo_integrals_map) -! integral_erf = get_mo_bielec_integral_erf(i,k,j,l,mo_integrals_erf_map) - effective_short_range_operator(l,k) += one_body_dm_mo(i,j) * integral - enddo - enddo - enddo - enddo -END_PROVIDER - - -BEGIN_PROVIDER [double precision, effective_one_e_potential, (mo_tot_num_align, mo_tot_num,N_states)] - implicit none - integer :: i,j,i_state - effective_one_e_potential = 0.d0 - do i_state = 1, N_states - do i = 1, mo_tot_num - do j = 1, mo_tot_num - effective_one_e_potential(i,j,i_state) = effective_short_range_operator(i,j) + mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) & - + 0.5d0 * (lda_ex_potential_alpha_ao(i,j,i_state) + lda_ex_potential_beta_ao(i,j,i_state)) - enddo - enddo - enddo - -END_PROVIDER - -subroutine save_one_e_effective_potential - implicit none - double precision, allocatable :: tmp(:,:) - allocate(tmp(size(effective_one_e_potential,1),size(effective_one_e_potential,2))) - integer :: i,j - do i = 1, mo_tot_num - do j = 1, mo_tot_num - tmp(i,j) = effective_one_e_potential(i,j,1) - enddo - enddo - call write_one_e_integrals('mo_one_integral', tmp, & - size(tmp,1), size(tmp,2)) - call ezfio_set_integrals_monoelec_disk_access_only_mo_one_integrals("Read") - deallocate(tmp) - -end - -subroutine save_erf_bi_elec_integrals - implicit none - integer :: i,j,k,l - PROVIDE mo_bielec_integrals_erf_in_map - call ezfio_set_work_empty(.False.) - call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_erf_map) - call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") -end diff --git a/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f b/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f deleted file mode 100644 index d89b965d..00000000 --- a/plugins/Integrals_restart_DFT/write_integrals_restart_dft.irp.f +++ /dev/null @@ -1,18 +0,0 @@ -program write_integrals - implicit none - read_wf = .true. - touch read_wf - disk_access_only_mo_one_integrals = "None" - touch disk_access_only_mo_one_integrals - disk_access_mo_integrals = "None" - touch disk_access_mo_integrals - call routine - -end - -subroutine routine - implicit none - call save_one_e_effective_potential - call save_erf_bi_elec_integrals - -end diff --git a/plugins/Kohn_Sham/EZFIO.cfg b/plugins/Kohn_Sham/EZFIO.cfg deleted file mode 100644 index 33d3a793..00000000 --- a/plugins/Kohn_Sham/EZFIO.cfg +++ /dev/null @@ -1,54 +0,0 @@ -[thresh_scf] -type: Threshold -doc: Threshold on the convergence of the Hartree Fock energy -interface: ezfio,provider,ocaml -default: 1.e-10 - -[exchange_functional] -type: character*(256) -doc: name of the exchange functional -interface: ezfio, provider, ocaml -default: "LDA" - - -[correlation_functional] -type: character*(256) -doc: name of the correlation functional -interface: ezfio, provider, ocaml -default: "LDA" - -[HF_exchange] -type: double precision -doc: Percentage of HF exchange in the DFT model -interface: ezfio,provider,ocaml -default: 0. - -[n_it_scf_max] -type: Strictly_positive_int -doc: Maximum number of SCF iterations -interface: ezfio,provider,ocaml -default: 200 - -[level_shift] -type: Positive_float -doc: Energy shift on the virtual MOs to improve SCF convergence -interface: ezfio,provider,ocaml -default: 0.5 - -[mo_guess_type] -type: MO_guess -doc: Initial MO guess. Can be [ Huckel | HCore ] -interface: ezfio,provider,ocaml -default: Huckel - -[energy] -type: double precision -doc: Calculated HF energy -interface: ezfio - -[no_oa_or_av_opt] -type: logical -doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure -interface: ezfio,provider,ocaml -default: False - diff --git a/plugins/Kohn_Sham/Fock_matrix.irp.f b/plugins/Kohn_Sham/Fock_matrix.irp.f deleted file mode 100644 index 9c91ddc9..00000000 --- a/plugins/Kohn_Sham/Fock_matrix.irp.f +++ /dev/null @@ -1,468 +0,0 @@ - BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis. - ! For open shells, the ROHF Fock Matrix is - ! - ! | F-K | F + K/2 | F | - ! |---------------------------------| - ! | F + K/2 | F | F - K/2 | - ! |---------------------------------| - ! | F | F - K/2 | F + K | - ! - ! F = 1/2 (Fa + Fb) - ! - ! K = Fb - Fa - ! - END_DOC - integer :: i,j,n - if (elec_alpha_num == elec_beta_num) then - Fock_matrix_mo = Fock_matrix_alpha_mo - else - - do j=1,elec_beta_num - ! F-K - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - enddo - - do j=elec_beta_num+1,elec_alpha_num - ! F+K/2 - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - do j=elec_alpha_num+1, mo_tot_num - ! F - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K - do i=elec_alpha_num+1,mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & - + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - endif - - do i = 1, mo_tot_num - Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) - enddo -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_ao(i,j) = Fock_matrix_alpha_no_xc_ao(i,j) + ao_potential_alpha_xc(i,j) - Fock_matrix_beta_ao (i,j) = Fock_matrix_beta_no_xc_ao(i,j) + ao_potential_beta_xc(i,j) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_no_xc_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_no_xc_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Mono electronic an Coulomb matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) - Fock_matrix_beta_no_xc_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) - enddo - enddo - -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] - use map_module - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j,k,l,k1,r,s - integer :: i0,j0,k0,l0 - integer*8 :: p,q - double precision :: integral, c0, c1, c2 - double precision :: ao_bielec_integral, local_threshold - double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) - double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp - - ao_bi_elec_integral_alpha = 0.d0 - ao_bi_elec_integral_beta = 0.d0 - if (do_direct_integrals) then - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & - !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & - !$OMP local_threshold)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & - !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - allocate(keys(1), values(1)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - q = ao_num*ao_num*ao_num*ao_num - !$OMP DO SCHEDULE(dynamic) - do p=1_8,q - call bielec_integrals_index_reverse(kk,ii,ll,jj,p) - if ( (kk(1)>ao_num).or. & - (ii(1)>ao_num).or. & - (jj(1)>ao_num).or. & - (ll(1)>ao_num) ) then - cycle - endif - k = kk(1) - i = ii(1) - l = ll(1) - j = jj(1) - - if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & - < ao_integrals_threshold) then - cycle - endif - local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) - if (local_threshold < ao_integrals_threshold) then - cycle - endif - i0 = i - j0 = j - k0 = k - l0 = l - values(1) = 0.d0 - local_threshold = ao_integrals_threshold/local_threshold - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) - c1 = HF_density_matrix_ao_alpha(k,i) - c2 = HF_density_matrix_ao_beta(k,i) - if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then - cycle - endif - if (values(1) == 0.d0) then - values(1) = ao_bielec_integral(k0,l0,i0,j0) - endif - integral = c0 * values(1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(1) - ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral - ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - else - PROVIDE ao_bielec_integrals_in_map - - integer(omp_lock_kind) :: lck(ao_num) - integer*8 :: i8 - integer :: ii(8), jj(8), kk(8), ll(8), k2 - integer(cache_map_size_kind) :: n_elements_max, n_elements - integer(key_kind), allocatable :: keys(:) - double precision, allocatable :: values(:) - -! !$OMP PARALLEL DEFAULT(NONE) & -! !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & -! !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& -! !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& -! !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta,HF_exchange) - - call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) - allocate(keys(n_elements_max), values(n_elements_max)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - -! !OMP DO SCHEDULE(dynamic) -! !DIR$ NOVECTOR - do i8=0_8,ao_integrals_map%map_size - n_elements = n_elements_max - call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) - do k1=1,n_elements - call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) - - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(k1) - ao_bi_elec_integral_alpha_tmp(l,j) -= HF_exchange * (HF_density_matrix_ao_alpha(k,i) * integral) - ao_bi_elec_integral_beta_tmp (l,j) -= HF_exchange * (HF_density_matrix_ao_beta (k,i) * integral) - enddo - enddo - enddo -! !$OMP END DO NOWAIT -! !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp -! !$OMP END CRITICAL -! !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp -! !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) -! !$OMP END PARALLEL - - endif - -END_PROVIDER - - - - - - -BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - BEGIN_PROVIDER [ double precision, HF_energy ] -&BEGIN_PROVIDER [ double precision, two_electron_energy] -&BEGIN_PROVIDER [ double precision, one_electron_energy] - implicit none - BEGIN_DOC - ! Hartree-Fock energy - END_DOC - HF_energy = nuclear_repulsion - - integer :: i,j - double precision :: accu_mono,accu_fock - one_electron_energy = 0.d0 - two_electron_energy = 0.d0 - do j=1,ao_num - do i=1,ao_num - two_electron_energy += 0.5d0 * ( ao_bi_elec_integral_alpha(i,j) * HF_density_matrix_ao_alpha(i,j) & - +ao_bi_elec_integral_beta(i,j) * HF_density_matrix_ao_beta(i,j) ) - one_electron_energy += ao_mono_elec_integral(i,j) * (HF_density_matrix_ao_alpha(i,j) + HF_density_matrix_ao_beta (i,j) ) - enddo - enddo - print*, 'one_electron_energy = ',one_electron_energy - print*, 'two_electron_energy = ',two_electron_energy - print*, 'e_exchange_dft = ',(1.d0 - HF_exchange) * e_exchange_dft -!print*, 'accu_cor = ',e_correlation_dft - HF_energy += (1.d0 - HF_exchange) * e_exchange_dft + e_correlation_dft + one_electron_energy + two_electron_energy -!print*, 'HF_energy ' - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Fock matrix in AO basis set - END_DOC - - if ( (elec_alpha_num == elec_beta_num).and. & - (level_shift == 0.) ) & - then - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num_align - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) - enddo - enddo - else - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - Fock_matrix_mo, size(Fock_matrix_mo,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - Fock_matrix_ao, size(Fock_matrix_ao,1)) - - - deallocate(T) - endif -END_PROVIDER - -subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) - implicit none - integer, intent(in) :: LDFMO ! size(FMO,1) - integer, intent(in) :: LDFAO ! size(FAO,1) - double precision, intent(in) :: FMO(LDFMO,*) - double precision, intent(out) :: FAO(LDFAO,*) - - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - FMO, size(FMO,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - FAO, size(FAO,1)) - deallocate(T,M) -end - diff --git a/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f b/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f deleted file mode 100644 index e8585f59..00000000 --- a/plugins/Kohn_Sham/HF_density_matrix_ao.irp.f +++ /dev/null @@ -1,41 +0,0 @@ -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 x Alpha density matrix in the AO basis x S^-1 - END_DOC - - call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & - mo_coef, size(mo_coef,1), & - mo_coef, size(mo_coef,1), 0.d0, & - HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Beta density matrix in the AO basis x S^-1 - END_DOC - - call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & - mo_coef, size(mo_coef,1), & - mo_coef, size(mo_coef,1), 0.d0, & - HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Density matrix in the AO basis S^-1 - END_DOC - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) - if (elec_alpha_num== elec_beta_num) then - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha - else - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta - endif - -END_PROVIDER - diff --git a/plugins/Kohn_Sham/KS_SCF.irp.f b/plugins/Kohn_Sham/KS_SCF.irp.f deleted file mode 100644 index dead61ee..00000000 --- a/plugins/Kohn_Sham/KS_SCF.irp.f +++ /dev/null @@ -1,54 +0,0 @@ -program scf - BEGIN_DOC -! Produce `Hartree_Fock` MO orbital -! output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ -! output: hartree_fock.energy -! optional: mo_basis.mo_coef - END_DOC - call create_guess - call orthonormalize_mos - call run -end - -subroutine create_guess - implicit none - BEGIN_DOC -! Create an MO guess if no MOs are present in the EZFIO directory - END_DOC - logical :: exists - PROVIDE ezfio_filename - call ezfio_has_mo_basis_mo_coef(exists) - if (.not.exists) then - if (mo_guess_type == "HCore") then - mo_coef = ao_ortho_lowdin_coef - TOUCH mo_coef - mo_label = 'Guess' - call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral,size(mo_mono_elec_integral,1),size(mo_mono_elec_integral,2),mo_label) - SOFT_TOUCH mo_coef mo_label - else if (mo_guess_type == "Huckel") then - call huckel_guess - else - print *, 'Unrecognized MO guess type : '//mo_guess_type - stop 1 - endif - endif -end - - -subroutine run - - use bitmasks - implicit none - BEGIN_DOC -! Run SCF calculation - END_DOC - double precision :: SCF_energy_before,SCF_energy_after,diag_H_mat_elem - double precision :: E0 - integer :: i_it, i, j, k - - E0 = HF_energy - - mo_label = "Canonical" - call damping_SCF - -end diff --git a/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES b/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES deleted file mode 100644 index d8c28b56..00000000 --- a/plugins/Kohn_Sham/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Bielec MOGuess Bitmask DFT_Utils diff --git a/plugins/Kohn_Sham/damping_SCF.irp.f b/plugins/Kohn_Sham/damping_SCF.irp.f deleted file mode 100644 index aa6f02b0..00000000 --- a/plugins/Kohn_Sham/damping_SCF.irp.f +++ /dev/null @@ -1,132 +0,0 @@ -subroutine damping_SCF - implicit none - double precision :: E - double precision, allocatable :: D_alpha(:,:), D_beta(:,:) - double precision :: E_new - double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) - double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) - double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min - - integer :: i,j,k - logical :: saving - character :: save_char - - allocate( & - D_alpha( ao_num_align, ao_num ), & - D_beta( ao_num_align, ao_num ), & - F_new( ao_num_align, ao_num ), & - D_new_alpha( ao_num_align, ao_num ), & - D_new_beta( ao_num_align, ao_num ), & - delta_alpha( ao_num_align, ao_num ), & - delta_beta( ao_num_align, ao_num )) - - do j=1,ao_num - do i=1,ao_num - D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) - D_beta (i,j) = HF_density_matrix_ao_beta (i,j) - enddo - enddo - - - call write_time(output_hartree_fock) - - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - - E = HF_energy + 1.d0 - E_min = HF_energy - delta_D = 0.d0 - do k=1,n_it_scf_max - - delta_E = HF_energy - E - E = HF_energy - - if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then - exit - endif - - saving = E < E_min - if (saving) then - call save_mos - save_char = 'X' - E_min = E - else - save_char = ' ' - endif - - write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & - k, E, delta_E, delta_D, save_char - - D_alpha = HF_density_matrix_ao_alpha - D_beta = HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - D_new_alpha = HF_density_matrix_ao_alpha - D_new_beta = HF_density_matrix_ao_beta - F_new = Fock_matrix_ao - E_new = HF_energy - - delta_alpha = D_new_alpha - D_alpha - delta_beta = D_new_beta - D_beta - - lambda = .5d0 - E_half = 0.d0 - do while (E_half > E) - HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha - HF_density_matrix_ao_beta = D_beta + lambda * delta_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - E_half = HF_energy - if ((E_half > E).and.(E_new < E)) then - lambda = 1.d0 - exit - else if ((E_half > E).and.(lambda > 5.d-4)) then - lambda = 0.5d0 * lambda - E_new = E_half - else - exit - endif - enddo - - a = (E_new + E - 2.d0*E_half)*2.d0 - b = -E_new - 3.d0*E + 4.d0*E_half - lambda = -lambda*b/(a+1.d-16) - D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha - D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta - delta_E = HF_energy - E - do j=1,ao_num - do i=1,ao_num - delta_D = delta_D + & - (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & - (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) - enddo - enddo - delta_D = dsqrt(delta_D/dble(ao_num)**2) - HF_density_matrix_ao_alpha = D_alpha - HF_density_matrix_ao_beta = D_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - - enddo - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' - write(output_hartree_fock,*) - - if(.not.no_oa_or_av_opt)then - call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) - endif - - call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') - call ezfio_set_hartree_fock_energy(E_min) - - call write_time(output_hartree_fock) - - deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) -end diff --git a/plugins/Kohn_Sham/diagonalize_fock.irp.f b/plugins/Kohn_Sham/diagonalize_fock.irp.f deleted file mode 100644 index c80077b3..00000000 --- a/plugins/Kohn_Sham/diagonalize_fock.irp.f +++ /dev/null @@ -1,119 +0,0 @@ - BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] -&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Diagonal Fock matrix in the MO basis - END_DOC - - integer :: i,j - integer :: liwork, lwork, n, info - integer, allocatable :: iwork(:) - double precision, allocatable :: work(:), F(:,:), S(:,:) - - - allocate( F(mo_tot_num_align,mo_tot_num) ) - do j=1,mo_tot_num - do i=1,mo_tot_num - F(i,j) = Fock_matrix_mo(i,j) - enddo - enddo - if(no_oa_or_av_opt)then - integer :: iorb,jorb - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_virt_orb - jorb = list_virt(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_core_orb - jorb = list_core(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - enddo - endif - - - - - ! Insert level shift here - do i = elec_beta_num+1, elec_alpha_num - F(i,i) += 0.5d0*level_shift - enddo - - do i = elec_alpha_num+1, mo_tot_num - F(i,i) += level_shift - enddo - - n = mo_tot_num - lwork = 1+6*n + 2*n*n - liwork = 3 + 5*n - - allocate(work(lwork), iwork(liwork) ) - - lwork = -1 - liwork = -1 - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - lwork = int(work(1)) - liwork = iwork(1) - deallocate(work,iwork) - allocate(work(lwork), iwork(liwork) ) - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - - call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & - mo_coef, size(mo_coef,1), F, size(F,1), & - 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) - deallocate(work, iwork, F) - - -! endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] - implicit none - BEGIN_DOC - ! diagonal element of the fock matrix calculated as the sum over all the interactions - ! with all the electrons in the RHF determinant - ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - END_DOC - integer :: i,j - double precision :: accu - do j = 1,elec_alpha_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - do j = elec_alpha_num+1,mo_tot_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - -END_PROVIDER diff --git a/plugins/Kohn_Sham/potential_functional.irp.f b/plugins/Kohn_Sham/potential_functional.irp.f deleted file mode 100644 index 3502581b..00000000 --- a/plugins/Kohn_Sham/potential_functional.irp.f +++ /dev/null @@ -1,31 +0,0 @@ - BEGIN_PROVIDER [double precision, ao_potential_alpha_xc, (ao_num_align, ao_num)] -&BEGIN_PROVIDER [double precision, ao_potential_beta_xc, (ao_num_align, ao_num)] - implicit none - integer :: i,j,k,l - ao_potential_alpha_xc = 0.d0 - ao_potential_beta_xc = 0.d0 -!if(exchange_functional == "LDA")then - do i = 1, ao_num - do j = 1, ao_num - ao_potential_alpha_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_alpha_ao(i,j,1) - ao_potential_beta_xc(i,j) = (1.d0 - HF_exchange) * lda_ex_potential_beta_ao(i,j,1) - enddo - enddo -!endif -END_PROVIDER - -BEGIN_PROVIDER [double precision, e_exchange_dft] - implicit none -!if(exchange_functional == "LDA")then - e_exchange_dft = lda_exchange(1) -!endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, e_correlation_dft] - implicit none -!if(correlation_functional == "LDA")then - e_correlation_dft = 0.d0 -!endif - -END_PROVIDER diff --git a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES index 3dc21fd0..801d2f51 100644 --- a/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES +++ b/plugins/MRCC_Utils/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS MRPT_Utils +Perturbation Selectors_full Generators_full Psiref_Utils Psiref_CAS diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index ccbe700d..1dcf2a2b 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -121,8 +121,7 @@ END_PROVIDER double precision :: phase logical :: ok integer, external :: searchDet - - PROVIDE psi_non_ref_sorted_idx psi_ref_coef + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& @@ -159,7 +158,6 @@ END_PROVIDER wk += 1 do s=1,N_states active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) - enddo active_excitation_to_determinants_idx(wk, ppp) = i else if(lref(i) < 0) then @@ -192,7 +190,7 @@ END_PROVIDER double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref active_excitation_to_determinants_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -200,6 +198,7 @@ END_PROVIDER mrcc_N_col(:) = 0 AtA_size = 0 + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 7ba210ca..41435688 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -678,53 +678,6 @@ END_PROVIDER call sort_det(psi_non_ref_sorted, psi_non_ref_sorted_idx, N_det_non_ref, N_int) END_PROVIDER - BEGIN_PROVIDER [ double precision, rho_mrpt, (N_det_non_ref, N_states) ] - implicit none - integer :: i, j, k - double precision :: coef_mrpt(N_States),coef_array(N_states),hij,delta_e(N_states) - double precision :: hij_array(N_det_Ref),delta_e_array(N_det_ref,N_states) - integer :: number_of_holes, number_of_particles,nh,np - do i = 1, N_det_non_ref - print*,'i',i - nh = number_of_holes(psi_non_ref(1,1,i)) - np = number_of_particles(psi_non_ref(1,1,i)) - do j = 1, N_det_ref - do k = 1, N_States - coef_array(k) = psi_ref_coef(j,k) - enddo - call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,i), N_int, Hij_array(j)) - call get_delta_e_dyall(psi_ref(1,1,j),psi_non_ref(1,1,i),coef_array,hij_array(j),delta_e) -! write(*,'(A7,x,100(F16.10,x))')'delta_e',delta_e(:) - do k = 1, N_states - delta_e_Array(j,k) = delta_e(k) - enddo - enddo - coef_mrpt = 0.d0 - do k = 1, N_states - do j = 1, N_det_Ref - coef_mrpt(k) += psi_ref_coef(j,k) * hij_array(j) / delta_e_array(j,k) - enddo - enddo - - write(*,'(A7,X,100(F16.10,x))')'coef ',psi_non_ref_coef(i,1) , coef_mrpt(1),psi_non_ref_coef(i,2) , coef_mrpt(2) - print*, nh,np - do k = 1, N_States - if(dabs(coef_mrpt(k)) .le.1.d-10)then - rho_mrpt(i,k) = 0.d0 - exit - endif - if(psi_non_ref_coef(i,k) / coef_mrpt(k) .lt.0d0)then - rho_mrpt(i,k) = 1.d0 - else - rho_mrpt(i,k) = psi_non_ref_coef(i,k) / coef_mrpt(k) - endif - enddo - print*,'rho',rho_mrpt(i,:) - write(33,*)i,rho_mrpt(i,:) - enddo - - END_PROVIDER - BEGIN_PROVIDER [ double precision, dIj_unique, (hh_nex, N_states) ] &BEGIN_PROVIDER [ double precision, rho_mrcc, (N_det_non_ref, N_states) ] @@ -1004,7 +957,7 @@ END_PROVIDER double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint double precision, external :: get_dij - double precision :: HIi, phase,delta_e_final(N_states) + double precision :: HIi, phase if(lambda_type == 0) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) @@ -1016,11 +969,7 @@ double precision function get_dij_index(II, i, s, Nint) else if(lambda_type == 2) then call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase - get_dij_index = get_dij_index - else if(lambda_type == 3) then - call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) - call get_delta_e_dyall(psi_ref(1,1,II),psi_non_ref(1,1,i),delta_e_final) - get_dij_index = HIi * rho_mrpt(i, s) / delta_e_final(s) + get_dij_index = get_dij_index * rho_mrcc(i,s) end if end function diff --git a/plugins/MRPT/MRPT_Utils.main.irp.f b/plugins/MRPT/MRPT_Utils.main.irp.f index 1b6efb4f..13c8228a 100644 --- a/plugins/MRPT/MRPT_Utils.main.irp.f +++ b/plugins/MRPT/MRPT_Utils.main.irp.f @@ -10,42 +10,34 @@ end subroutine routine_3 implicit none - integer :: i,j !provide fock_virt_total_spin_trace provide delta_ij print *, 'N_det = ', N_det print *, 'N_states = ', N_states - do i = 1, N_States - print*,'State',i - write(*,'(A12,X,I3,A3,XX,F20.16)') ' PT2 ', i,' = ', second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E ', i,' = ', psi_ref_average_value(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E+PT2 ', i,' = ', psi_ref_average_value(i)+second_order_pt_new(i) - write(*,'(A12,X,I3,A3,XX,F22.16)') ' E dressed ', i,' = ', CI_dressed_pt2_new_energy(i) - write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) - print*,'coef before and after' - do j = 1, N_det_ref - print*,psi_ref_coef(j,i),CI_dressed_pt2_new_eigenvectors(j,i) - enddo - enddo - if(save_heff_eigenvectors)then - call save_wavefunction_general(N_det_ref,N_states,psi_ref,N_det_ref,CI_dressed_pt2_new_eigenvectors) - endif - if(N_states.gt.1)then - print*, 'Energy differences : E(i) - E(0)' - do i = 2, N_States - print*,'State',i - write(*,'(A12,X,I3,A3,XX,F20.16)') ' S^2 ', i,' = ', CI_dressed_pt2_new_eigenvectors_s2(i) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Variational ', i,' = ', -(psi_ref_average_value(1) - psi_ref_average_value(i)) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Perturbative', i,' = ', -(psi_ref_average_value(1)+second_order_pt_new(1) - (psi_ref_average_value(i)+second_order_pt_new(i))) - write(*,'(A12,X,I3,A3,XX,F20.16)') 'Dressed ', i,' = ', -( CI_dressed_pt2_new_energy(1) - CI_dressed_pt2_new_energy(i) ) - enddo - endif + print *, 'PT2 = ', second_order_pt_new(1) + print *, 'E = ', CI_energy(1) + print *, 'E+PT2 = ', CI_energy(1)+second_order_pt_new(1) + print *,'****** DIAGONALIZATION OF DRESSED MATRIX ******' + print *, 'E dressed= ', CI_dressed_pt2_new_energy(1) end subroutine routine_2 implicit none - provide electronic_psi_ref_average_value + integer :: i + do i = 1, n_core_inact_orb + print*,fock_core_inactive_total(i,1,1),fock_core_inactive(i) + enddo + double precision :: accu + accu = 0.d0 + do i = 1, n_act_orb + integer :: j_act_orb + j_act_orb = list_act(i) + accu += one_body_dm_mo_alpha(j_act_orb,j_act_orb,1) + print*,one_body_dm_mo_alpha(j_act_orb,j_act_orb,1),one_body_dm_mo_beta(j_act_orb,j_act_orb,1) + enddo + print*,'accu = ',accu + end diff --git a/plugins/MRPT/NEEDED_CHILDREN_MODULES b/plugins/MRPT/NEEDED_CHILDREN_MODULES index 041b0136..7340c609 100644 --- a/plugins/MRPT/NEEDED_CHILDREN_MODULES +++ b/plugins/MRPT/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MRPT_Utils Selectors_full Psiref_CAS Generators_CAS +MRPT_Utils Selectors_full Generators_full diff --git a/plugins/MRPT/print_1h2p.irp.f b/plugins/MRPT/print_1h2p.irp.f index f20f12b6..d10e1fb5 100644 --- a/plugins/MRPT/print_1h2p.irp.f +++ b/plugins/MRPT/print_1h2p.irp.f @@ -6,53 +6,46 @@ program print_1h2p end subroutine routine - implicit none - provide one_anhil_one_creat_inact_virt - -end - -subroutine routine_2 - implicit none - integer :: i,j,degree - double precision :: hij - do i =1, n_core_inact_orb - write(*,'(I3,x,100(F16.10,X))')list_core_inact(i),fock_core_inactive_total_spin_trace(list_core_inact(i),1) - enddo - print*,'' - do i =1, n_virt_orb - write(*,'(I3,x,100(F16.10,X))')list_virt(i),fock_virt_total_spin_trace(list_virt(i),1) - enddo - stop - do i = 1, n_virt_orb - do j = 1, n_inact_orb - if(dabs(one_anhil_one_creat_inact_virt(j,i,1)) .lt. 1.d-10)cycle - write(*,'(I3,x,I3,X,100(F16.10,X))')list_virt(i),list_inact(j),one_anhil_one_creat_inact_virt(j,i,1) - enddo - enddo - - -end - -subroutine routine_3 implicit none double precision,allocatable :: matrix_1h2p(:,:,:) - double precision :: accu(2) - allocate (matrix_1h2p(N_det_ref,N_det_ref,N_states)) + allocate (matrix_1h2p(N_det,N_det,N_states)) integer :: i,j,istate - accu = 0.d0 - matrix_1h2p = 0.d0 -!call H_apply_mrpt_1h2p(matrix_1h2p,N_det_ref) - call give_1h2p_contrib(matrix_1h2p) - do istate = 1, N_states - do i = 1, N_det - do j = 1, N_det - accu(istate) += matrix_1h2p(i,j,istate) * psi_coef(i,istate) * psi_coef(j,istate) + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 enddo enddo - print*,accu(istate) enddo - call contrib_1h2p_dm_based(accu) - print*,accu(:) + if(.False.)then + call give_1h2p_contrib(matrix_1h2p) + double precision :: accu + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + print*, 'second order ', accu + endif + + if(.True.)then + do i = 1, N_det + do j = 1, N_det + do istate = 1, N_states + matrix_1h2p(i,j,istate) = 0.d0 + enddo + enddo + enddo + call give_1h2p_new(matrix_1h2p) + accu = 0.d0 + do i = 1, N_det + do j = 1, N_det + accu += matrix_1h2p(i,j,1) * psi_coef(i,1) * psi_coef(j,1) + enddo + enddo + endif + print*, 'third order ', accu deallocate (matrix_1h2p) end diff --git a/plugins/MRPT_Utils/EZFIO.cfg b/plugins/MRPT_Utils/EZFIO.cfg index cb16fcea..2fcc26ad 100644 --- a/plugins/MRPT_Utils/EZFIO.cfg +++ b/plugins/MRPT_Utils/EZFIO.cfg @@ -5,10 +5,3 @@ interface: ezfio,provider,ocaml default: True -[save_heff_eigenvectors] -type: logical -doc: If true, save the eigenvectors of the dressed matrix at the end of the MRPT calculation -interface: ezfio,provider,ocaml -default: False - - diff --git a/plugins/MRPT_Utils/H_apply.irp.f b/plugins/MRPT_Utils/H_apply.irp.f index a7adc480..6f17ab05 100644 --- a/plugins/MRPT_Utils/H_apply.irp.f +++ b/plugins/MRPT_Utils/H_apply.irp.f @@ -23,7 +23,6 @@ print s s = H_apply("mrpt_1h") s.filter_only_1h() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -44,7 +43,6 @@ print s s = H_apply("mrpt_1p") s.filter_only_1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -65,7 +63,6 @@ print s s = H_apply("mrpt_1h1p") s.filter_only_1h1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -86,7 +83,6 @@ print s s = H_apply("mrpt_2p") s.filter_only_2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -107,7 +103,6 @@ print s s = H_apply("mrpt_2h") s.filter_only_2h() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -129,7 +124,6 @@ print s s = H_apply("mrpt_1h2p") s.filter_only_1h2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -150,7 +144,6 @@ print s s = H_apply("mrpt_2h1p") s.filter_only_2h1p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet @@ -171,7 +164,6 @@ print s s = H_apply("mrpt_2h2p") s.filter_only_2h2p() -s.unset_skip() s.data["parameters"] = ", delta_ij_, Ndet" s.data["declarations"] += """ integer, intent(in) :: Ndet diff --git a/plugins/MRPT_Utils/MRMP2_density.irp.f b/plugins/MRPT_Utils/MRMP2_density.irp.f deleted file mode 100644 index 1051edf9..00000000 --- a/plugins/MRPT_Utils/MRMP2_density.irp.f +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN_PROVIDER [double precision, MRMP2_density, (mo_tot_num_align, mo_tot_num)] - implicit none - integer :: i,j,k,l - double precision :: accu, mp2_dm(mo_tot_num) - MRMP2_density = one_body_dm_mo - call give_2h2p_density(mp2_dm) - accu = 0.d0 - do i = 1, n_virt_orb - j = list_virt(i) - accu += mp2_dm(j) - MRMP2_density(j,j)+= mp2_dm(j) - enddo - -END_PROVIDER - -subroutine give_2h2p_density(mp2_density_diag_alpha_beta) - implicit none - double precision, intent(out) :: mp2_density_diag_alpha_beta(mo_tot_num) - integer :: i,j,k,l,m - integer :: iorb,jorb,korb,lorb - - double precision :: get_mo_bielec_integral - double precision :: direct_int - double precision :: coef_double - - mp2_density_diag_alpha_beta = 0.d0 - do k = 1, n_virt_orb - korb = list_virt(k) - do i = 1, n_inact_orb - iorb = list_inact(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - do l = 1, n_virt_orb - lorb = list_virt(l) - direct_int = get_mo_bielec_integral(iorb,jorb,korb,lorb ,mo_integrals_map) - coef_double = direct_int/(fock_core_inactive_total_spin_trace(iorb,1) + fock_core_inactive_total_spin_trace(jorb,1) & - -fock_virt_total_spin_trace(korb,1) - fock_virt_total_spin_trace(lorb,1)) - mp2_density_diag_alpha_beta(korb) += coef_double * coef_double - enddo - enddo - enddo - print*, mp2_density_diag_alpha_beta(korb) - enddo - -end - diff --git a/plugins/MRPT_Utils/density_matrix_based.irp.f b/plugins/MRPT_Utils/density_matrix_based.irp.f deleted file mode 100644 index ac135807..00000000 --- a/plugins/MRPT_Utils/density_matrix_based.irp.f +++ /dev/null @@ -1,193 +0,0 @@ -subroutine contrib_1h2p_dm_based(accu) - implicit none - integer :: i_i,i_r,i_v,i_a,i_b - integer :: i,r,v,a,b - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,2) - double precision :: delta_e(n_act_orb,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 -!do i_i = 1, 1 - do i_i = 1, n_inact_orb - i = list_inact(i_i) -! do i_r = 1, 1 - do i_r = 1, n_virt_orb - r = list_virt(i_r) -! do i_v = 1, 1 - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - active_int(i_a,1) = get_mo_bielec_integral(i,a,r,v,mo_integrals_map) ! direct - active_int(i_a,2) = get_mo_bielec_integral(i,a,v,r,mo_integrals_map) ! exchange - do istate = 1, N_states - do jspin=1, 2 - delta_e(i_a,jspin,istate) = one_anhil(i_a,jspin,istate) & - - fock_virt_total_spin_trace(r,istate) & - - fock_virt_total_spin_trace(v,istate) & - + fock_core_inactive_total_spin_trace(i,istate) - delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) - enddo - enddo - enddo - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb -! do i_b = i_a, i_a - b = list_act(i_b) - do ispin = 1, 2 ! spin of (i --> r) - do jspin = 1, 2 ! spin of (a --> v) - if(ispin == jspin .and. r.le.v)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_mo_spin_index(a,b,istate,ispin) & - * (active_int(i_b,1) - active_int(i_b,2)) & - * delta_e(i_a,jspin,istate) - else - accu(istate) += active_int(i_a,1) * one_body_dm_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & - * active_int(i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - -subroutine contrib_2h1p_dm_based(accu) - implicit none - integer :: i_i,i_j,i_v,i_a,i_b - integer :: i,j,v,a,b - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,2) - double precision :: delta_e(n_act_orb,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 - do i_i = 1, n_inact_orb - i = list_inact(i_i) - do i_j = 1, n_inact_orb - j = list_inact(i_j) - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - active_int(i_a,1) = get_mo_bielec_integral(i,j,v,a,mo_integrals_map) ! direct - active_int(i_a,2) = get_mo_bielec_integral(i,j,a,v,mo_integrals_map) ! exchange - do istate = 1, N_states - do jspin=1, 2 -! delta_e(i_a,jspin,istate) = -! - delta_e(i_a,jspin,istate) = one_creat(i_a,jspin,istate) - fock_virt_total_spin_trace(v,istate) & - + fock_core_inactive_total_spin_trace(i,istate) & - + fock_core_inactive_total_spin_trace(j,istate) - delta_e(i_a,jspin,istate) = 1.d0/delta_e(i_a,jspin,istate) - enddo - enddo - enddo - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb -! do i_b = i_a, i_a - b = list_act(i_b) - do ispin = 1, 2 ! spin of (i --> v) - do jspin = 1, 2 ! spin of (j --> a) - if(ispin == jspin .and. i.le.j)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - accu(istate) += (active_int(i_a,1) - active_int(i_a,2)) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) & - * (active_int(i_b,1) - active_int(i_b,2)) & - * delta_e(i_a,jspin,istate) - else - accu(istate) += active_int(i_a,1) * one_body_dm_dagger_mo_spin_index(a,b,istate,ispin) * delta_e(i_a,ispin,istate) & - * active_int(i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - - -subroutine contrib_2p_dm_based(accu) - implicit none - integer :: i_r,i_v,i_a,i_b,i_c,i_d - integer :: r,v,a,b,c,d - integer :: ispin,jspin - integer :: istate - double precision, intent(out) :: accu(N_states) - double precision :: active_int(n_act_orb,n_act_orb,2) - double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) - double precision :: get_mo_bielec_integral - accu = 0.d0 - do i_r = 1, n_virt_orb - r = list_virt(i_r) - do i_v = 1, n_virt_orb - v = list_virt(i_v) - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb - b = list_act(i_b) - active_int(i_a,i_b,1) = get_mo_bielec_integral(a,b,r,v,mo_integrals_map) ! direct - active_int(i_a,i_b,2) = get_mo_bielec_integral(a,b,v,r,mo_integrals_map) ! direct - do istate = 1, N_states - do jspin=1, 2 ! spin of i_a - do ispin = 1, 2 ! spin of i_b - delta_e(i_a,i_b,jspin,ispin,istate) = two_anhil(i_a,i_b,jspin,ispin,istate) & - - fock_virt_total_spin_trace(r,istate) & - - fock_virt_total_spin_trace(v,istate) - delta_e(i_a,i_b,jspin,ispin,istate) = 1.d0/delta_e(i_a,i_b,jspin,ispin,istate) - enddo - enddo - enddo - enddo - enddo - ! diagonal terms - do i_a = 1, n_act_orb - a = list_act(i_a) - do i_b = 1, n_act_orb - b = list_act(i_b) - do ispin = 1, 2 ! spin of (a --> r) - do jspin = 1, 2 ! spin of (b --> v) - if(ispin == jspin .and. r.le.v)cycle ! condition not to double count - if(ispin == jspin .and. a.le.b)cycle ! condition not to double count - do istate = 1, N_states - if(ispin == jspin)then - double precision :: contrib_spin - if(ispin == 1)then - contrib_spin = two_body_dm_aa_diag_act(i_a,i_b) - else - contrib_spin = two_body_dm_bb_diag_act(i_a,i_b) - endif - accu(istate) += (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) * contrib_spin & - * (active_int(i_a,i_b,1) - active_int(i_a,i_b,2)) & - * delta_e(i_a,i_b,ispin,jspin,istate) - else - accu(istate) += 0.5d0 * active_int(i_a,i_b,1) * two_body_dm_ab_diag_act(i_a,i_b) * delta_e(i_a,i_b,ispin,jspin,istate) & - * active_int(i_a,i_b,1) - endif - enddo - enddo - enddo - enddo - enddo - enddo - enddo - - -end - diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index e8d19166..dd79edbe 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -1,9 +1,9 @@ BEGIN_PROVIDER [ double precision, energy_cas_dyall, (N_states)] implicit none integer :: i - double precision :: energies(N_states) + double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall(i) = energies(i) print*, 'energy_cas_dyall(i)', energy_cas_dyall(i) enddo @@ -13,72 +13,38 @@ END_PROVIDER BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange, (N_states)] implicit none integer :: i - double precision :: energies(N_states) + double precision :: energies(N_states_diag) do i = 1, N_states - call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_ref_coef,n_det_ref,psi_det_size,psi_det_size,N_states,i) + call u0_H_dyall_u0_no_exchange(energies,psi_active,psi_coef,n_det,psi_det_size,psi_det_size,N_states_diag,i) energy_cas_dyall_no_exchange(i) = energies(i) print*, 'energy_cas_dyall(i)_no_exchange', energy_cas_dyall_no_exchange(i) enddo END_PROVIDER -BEGIN_PROVIDER [ double precision, energy_cas_dyall_no_exchange_bis, (N_states)] - implicit none - integer :: i,j - double precision :: energies(N_states) - integer(bit_kind), allocatable :: psi_in_ref(:,:,:) - allocate (psi_in_ref(N_int,2,n_det_ref)) - integer(bit_kind), allocatable :: psi_in_active(:,:,:) - allocate (psi_in_active(N_int,2,n_det_ref)) - double precision, allocatable :: psi_ref_coef_in(:, :) - allocate(psi_ref_coef_in(N_det_ref, N_states)) - - do i = 1, N_det_ref - do j = 1, N_int - psi_in_ref(j,1,i) = psi_ref(j,1,i) - psi_in_ref(j,2,i) = psi_ref(j,2,i) - - psi_in_active(j,1,i) = psi_active(j,1,i) - psi_in_active(j,2,i) = psi_active(j,2,i) - enddo - do j = 1, N_states - psi_ref_coef_in(i,j) = psi_ref_coef(i,j) - enddo - enddo - do i = 1, N_states - call u0_H_dyall_u0_no_exchange_bis(energies,psi_in_ref,psi_ref_coef_in,n_det_ref,n_det_ref,n_det_ref,N_states,i) - energy_cas_dyall_no_exchange_bis(i) = energies(i) - print*, 'energy_cas_dyall(i)_no_exchange_bis', energy_cas_dyall_no_exchange_bis(i) - enddo - deallocate (psi_in_ref) - deallocate (psi_in_active) - deallocate(psi_ref_coef_in) -END_PROVIDER - - BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] implicit none integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) use bitmasks integer :: iorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = 1 spin_exc = ispin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -87,9 +53,9 @@ BEGIN_PROVIDER [ double precision, one_creat, (n_act_orb,2,N_states)] enddo do state_target = 1,N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_creat(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_creat(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -102,23 +68,23 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] integer :: i,j integer :: ispin integer :: orb, hole_particle,spin_exc - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb = list_act(iorb) hole_particle = -1 spin_exc = ispin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -127,9 +93,9 @@ BEGIN_PROVIDER [ double precision, one_anhil, (n_act_orb,2,N_states)] enddo do state_target = 1, N_states call apply_exc_to_psi(orb,hole_particle,spin_exc, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - one_anhil(iorb,ispin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil(iorb,ispin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -143,15 +109,15 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -162,9 +128,9 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = 1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -173,11 +139,11 @@ BEGIN_PROVIDER [ double precision, two_creat, (n_act_orb,n_act_orb,2,2,N_states) enddo do state_target = 1 , N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -193,16 +159,16 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target state_target = 1 - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -213,23 +179,21 @@ BEGIN_PROVIDER [ double precision, two_anhil, (n_act_orb,n_act_orb,2,2,N_states) orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - do state_target = 1 , N_states - call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - enddo + call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhil(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -244,15 +208,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 integer :: ispin,jspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -263,9 +227,9 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 orb_j = list_act(jorb) hole_particle_j = -1 spin_exc_j = jspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -274,16 +238,16 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - !if(orb_i == orb_j .and. ispin .ne. jspin)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + if(orb_i == orb_j .and. ispin .ne. jspin)then + call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - !else - ! call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - ! one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) - !endif + else + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + one_anhil_one_creat(iorb,jorb,ispin,jspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) + endif enddo enddo enddo @@ -293,24 +257,23 @@ BEGIN_PROVIDER [ double precision, one_anhil_one_creat, (n_act_orb,n_act_orb,2,2 END_PROVIDER - BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -&BEGIN_PROVIDER [ double precision, two_anhil_one_creat_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] +BEGIN_PROVIDER [ double precision, two_anhil_one_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -326,9 +289,9 @@ END_PROVIDER orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -338,14 +301,13 @@ END_PROVIDER do state_target = 1, N_states call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -357,70 +319,23 @@ END_PROVIDER END_PROVIDER - - BEGIN_PROVIDER [ double precision, two_anhil_one_creat_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] +BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j integer :: ispin,jspin,kspin integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) - double precision :: accu - do iorb = 1,n_act_orb - orb_i = list_act(iorb) - do jorb = 1, n_act_orb - orb_j = list_act(jorb) - do korb = 1, n_act_orb - orb_k = list_act(korb) - do state_target = 1, N_states - accu = 0.d0 - do ispin = 1,2 - do jspin = 1,2 - do kspin = 1,2 - two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) += two_anhil_one_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target)* & - two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - accu += two_anhil_one_creat_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - enddo - enddo - enddo - two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) = two_anhil_one_creat_spin_average(iorb,jorb,korb,state_target) /accu - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -&BEGIN_PROVIDER [ double precision, two_creat_one_anhil_norm, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] -implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -436,27 +351,24 @@ implicit none orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo - - do state_target = 1, N_states - call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + do state_target = 1, N_states call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) - two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) = norm_out(state_target) -! print*, norm_out(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -468,136 +380,6 @@ implicit none END_PROVIDER - - BEGIN_PROVIDER [ double precision, two_creat_one_anhil_spin_average, (n_act_orb,n_act_orb,n_act_orb,N_states)] -implicit none - integer :: i,j - integer :: ispin,jspin,kspin - integer :: orb_i, hole_particle_i,spin_exc_i - integer :: orb_j, hole_particle_j,spin_exc_j - integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) - integer(bit_kind), allocatable :: psi_in_out(:,:,:) - double precision, allocatable :: psi_in_out_coef(:,:) - use bitmasks - allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det_ref,N_states)) - - integer :: iorb,jorb - integer :: korb - integer :: state_target - double precision :: energies(n_states),accu - do iorb = 1,n_act_orb - orb_i = list_act(iorb) - do jorb = 1, n_act_orb - orb_j = list_act(jorb) - do korb = 1, n_act_orb - orb_k = list_act(korb) - do state_target = 1, N_states - accu = 0.d0 - do ispin = 1,2 - do jspin = 1,2 - do kspin = 1,2 - two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) += two_creat_one_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) * & - two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - accu += two_creat_one_anhil_norm(iorb,jorb,korb,ispin,jspin,kspin,state_target) - print*, accu - enddo - enddo - enddo - two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) = two_creat_one_anhil_spin_average(iorb,jorb,korb,state_target) / accu - enddo - enddo - enddo - enddo - deallocate(psi_in_out,psi_in_out_coef) - -END_PROVIDER - -!BEGIN_PROVIDER [ double precision, two_creat_one_anhil, (n_act_orb,n_act_orb,n_act_orb,N_states)] -!implicit none -!integer :: i,j -!integer :: ispin,jspin,kspin -!integer :: orb_i, hole_particle_i,spin_exc_i -!integer :: orb_j, hole_particle_j,spin_exc_j -!integer :: orb_k, hole_particle_k,spin_exc_k -!double precision :: norm_out(N_states) -!integer(bit_kind), allocatable :: psi_in_out(:,:,:) -!double precision, allocatable :: psi_in_out_coef(:,:) -!use bitmasks -!allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) - -!integer :: iorb,jorb -!integer :: korb -!integer :: state_target -!double precision :: energies(n_states) -!double precision :: norm_spins(2,2,N_states), energies_spins(2,2,N_states) -!double precision :: thresh_norm -!thresh_norm = 1.d-10 -!do iorb = 1,n_act_orb -! orb_i = list_act(iorb) -! hole_particle_i = 1 -! do jorb = 1, n_act_orb -! orb_j = list_act(jorb) -! hole_particle_j = 1 -! do korb = 1, n_act_orb -! orb_k = list_act(korb) -! hole_particle_k = -1 - -! ! loop on the spins -! ! By definition, orb_i is the particle of spin ispin -! ! a^+_{ispin , orb_i} -! do ispin = 1, 2 -! do jspin = 1, 2 -! ! By definition, orb_j and orb_k are the couple of particle/hole of spin jspin -! ! a^+_{jspin , orb_j} a_{jspin , orb_k} -! ! norm_spins(ispin,jspin) :: norm of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > -! ! energies_spins(ispin,jspin) :: Dyall energu of the wave function a^+_{ispin , orb_i} a^+_{jspin , orb_j} a_{jspin , orb_k} | Psi > -! do i = 1, n_det_ref -! do j = 1, n_states -! psi_in_out_coef(i,j) = psi_ref_coef(i,j) -! enddo -! do j = 1, N_int -! psi_in_out(j,1,i) = psi_active(j,1,i) -! psi_in_out(j,2,i) = psi_active(j,2,i) -! enddo -! enddo -! do state_target = 1, N_states -! ! hole :: hole_particle_k, jspin -! call apply_exc_to_psi(orb_k,hole_particle_k,jspin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! call apply_exc_to_psi(orb_j,hole_particle_j,jspin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! call apply_exc_to_psi(orb_i,hole_particle_i,ispin, & -! norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) -! if(dabs(norm_out(state_target)).lt.thresh_norm)then -! norm_spins(ispin,jspin,state_target) = 0.d0 -! else -! norm_spins(ispin,jspin,state_target) = 1.d0 -! endif -! call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) -! energies_spins(ispin,jspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) -! enddo -! enddo -! enddo -! integer :: icount -! ! averaging over all possible spin permutations with Heaviside norm -! do state_target = 1, N_states -! icount = 0 -! do jspin = 1, 2 -! do ispin = 1, 2 -! icount += 1 -! two_creat_one_anhil(iorb,jorb,korb,state_target) = energies_spins(ispin,jspin,state_target) * norm_spins(ispin,jspin,state_target) -! enddo -! enddo -! two_creat_one_anhil(iorb,jorb,korb,state_target) = two_creat_one_anhil(iorb,jorb,korb,state_target) / dble(icount) -! enddo -! enddo -! enddo -!enddo -!deallocate(psi_in_out,psi_in_out_coef) - -!END_PROVIDER - BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2,2,2,N_states)] implicit none integer :: i,j @@ -605,16 +387,16 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -630,9 +412,9 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = 1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -641,13 +423,13 @@ BEGIN_PROVIDER [ double precision, three_creat, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_creat(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -666,16 +448,16 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 integer :: orb_i, hole_particle_i,spin_exc_i integer :: orb_j, hole_particle_j,spin_exc_j integer :: orb_k, hole_particle_k,spin_exc_k - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb integer :: korb integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) do iorb = 1,n_act_orb do ispin = 1,2 orb_i = list_act(iorb) @@ -691,9 +473,9 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 orb_k = list_act(korb) hole_particle_k = -1 spin_exc_k = kspin - do i = 1, n_det_ref - do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j) + do i = 1, n_det + do j = 1, n_states_diag + psi_in_out_coef(i,j) = psi_coef(i,j) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -702,13 +484,13 @@ BEGIN_PROVIDER [ double precision, three_anhil, (n_act_orb,n_act_orb,n_act_orb,2 enddo do state_target = 1, N_states call apply_exc_to_psi(orb_i,hole_particle_i,spin_exc_i, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_j,hole_particle_j,spin_exc_j, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) call apply_exc_to_psi(orb_k,hole_particle_k,spin_exc_k, & - norm_out,psi_in_out,psi_in_out_coef, n_det_ref,n_det_ref,n_det_ref,N_states) - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) - three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall_no_exchange(state_target) - energies(state_target) + norm_out,psi_in_out,psi_in_out_coef, n_det,n_det,n_det,N_states_diag) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) + three_anhil(iorb,jorb,korb,ispin,jspin,kspin,state_target) = energy_cas_dyall(state_target) - energies(state_target) enddo enddo enddo @@ -729,32 +511,24 @@ END_PROVIDER integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) - integer(bit_kind), allocatable :: psi_in_active(:,:,:) - allocate (psi_in_active(N_int,2,n_det_ref)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states) - double precision :: hij,hij_test + double precision :: energies(n_states_diag) + double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2),norm_bis(N_states,2) double precision :: energies_alpha_beta(N_states,2) double precision :: thresh_norm - integer :: other_spin(2) - other_spin(1) = 2 - other_spin(2) = 1 - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 -!do i = 1, N_det_ref -! print*, psi_ref_coef(i,1) -!enddo do vorb = 1,n_virt_orb @@ -767,10 +541,10 @@ END_PROVIDER do state_target =1 , N_states one_anhil_one_creat_inact_virt_norm(iorb,vorb,state_target,ispin) = 0.d0 enddo - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -778,12 +552,11 @@ END_PROVIDER call debug_det(psi_in_out,N_int) print*, 'pb, i_ok ne 0 !!!' endif - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) - integer :: exc(0:2,2,2) - double precision :: phase - call get_mono_excitation(psi_in_out(1,1,i),psi_ref(1,1,i),exc,phase,N_int) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states - psi_in_out_coef(i,j) = psi_ref_coef(i,j)* hij * phase + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo enddo @@ -794,36 +567,38 @@ END_PROVIDER one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 0.d0 else norm_no_inv(j,ispin) = norm(j,ispin) + one_anhil_one_creat_inact_virt_norm(iorb,vorb,j,ispin) = 1.d0 / norm(j,ispin) norm(j,ispin) = 1.d0/dsqrt(norm(j,ispin)) endif enddo - integer :: iorb_annil,hole_particle,spin_exc,orb - double precision :: norm_out_bis(N_states) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo - enddo - - do i = 1, N_det_ref do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) psi_in_out(j,2,i) = psi_active(j,2,i) enddo enddo do state_target = 1, N_states - energies_alpha_beta(state_target, ispin) = 0.d0 + energies_alpha_beta(state_target, ispin) = - mo_bielec_integral_jj_exchange(orb_i,orb_v) +! energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & - ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & +! one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.5d0 * & +! ( energy_cas_dyall(state_target) - energies_alpha_beta(state_target,1) + & +! energy_cas_dyall(state_target) - energies_alpha_beta(state_target,2) ) +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) + one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = energy_cas_dyall(state_target) - & + ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_one_creat_inact_virt(iorb,vorb,state_target) = 0.d0 @@ -841,15 +616,15 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta integer :: i,iorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -857,7 +632,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta double precision :: thresh_norm - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -870,10 +645,10 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_a,ispin,i_ok) if(i_ok.ne.1)then @@ -881,11 +656,11 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states double precision :: coef,contrib - coef = psi_ref_coef(i,j) !* psi_ref_coef(i,j) - psi_in_out_coef(i,j) = sign(coef,psi_ref_coef(i,j)) * hij + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) enddo endif @@ -900,7 +675,7 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -913,20 +688,24 @@ BEGIN_PROVIDER [ double precision, one_anhil_inact, (n_inact_orb,n_act_orb,N_Sta do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then -! one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & - one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & + one_anhil_inact(iorb,aorb,state_target) = energy_cas_dyall(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else one_anhil_inact(iorb,aorb,state_target) = 0.d0 endif +! print*, '********' +! print*, energies_alpha_beta(state_target,1) , energies_alpha_beta(state_target,2) +! print*, norm_bis(state_target,1) , norm_bis(state_target,2) +! print*, one_anhil_inact(iorb,aorb,state_target) +! print*, one_creat(aorb,1,state_target) enddo enddo enddo @@ -940,15 +719,15 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states) + double precision :: norm_out(N_states_diag) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag)) integer :: iorb,jorb,i_ok,aorb,orb_a integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: norm(N_states,2),norm_no_inv(N_states,2) double precision :: energies_alpha_beta(N_states,2) @@ -956,7 +735,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State double precision :: thresh_norm - thresh_norm = 1.d-20 + thresh_norm = 1.d-10 do aorb = 1,n_act_orb orb_a = list_act(aorb) @@ -969,10 +748,10 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State norm = 0.d0 norm_bis = 0.d0 do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_a,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -980,21 +759,16 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State psi_in_out_coef(i,j) = 0.d0 enddo else - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,i),N_int,hij) + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,i),N_int,hij) do j = 1, n_states - double precision :: contrib - psi_in_out_coef(i,j) = psi_ref_coef(i,j) * hij + double precision :: coef,contrib + coef = psi_coef(i,j) !* psi_coef(i,j) + psi_in_out_coef(i,j) = sign(coef,psi_coef(i,j)) * hij norm(j,ispin) += psi_in_out_coef(i,j) * psi_in_out_coef(i,j) - !if(orb_a == 6 .and. orb_v == 12)then - ! print*, j,psi_ref_coef(i,j),psi_in_out_coef(i,j) - !endif enddo endif enddo do j = 1, N_states -! if(orb_a == 6 .and. orb_v == 12)then -! print*, 'norm',norm(j,ispin) -! endif if (dabs(norm(j,ispin)) .le. thresh_norm)then norm(j,ispin) = 0.d0 norm_no_inv(j,ispin) = norm(j,ispin) @@ -1004,7 +778,7 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State endif enddo double precision :: norm_bis(N_states,2) - do i = 1, N_det_ref + do i = 1, N_det do j = 1, N_states psi_in_out_coef(i,j) = psi_in_out_coef(i,j) * norm(j,ispin) norm_bis(j,ispin) += psi_in_out_coef(i,j)* psi_in_out_coef(i,j) @@ -1017,18 +791,18 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State do state_target = 1, N_states energies_alpha_beta(state_target, ispin) = 0.d0 if(norm(state_target,ispin) .ne. 0.d0 .and. dabs(norm_no_inv(state_target,ispin)) .gt. thresh_norm)then - call u0_H_dyall_u0_no_exchange(energies,psi_in_out,psi_in_out_coef,n_det_ref,n_det_ref,n_det_ref,N_states,state_target) + call u0_H_dyall_u0(energies,psi_in_out,psi_in_out_coef,n_det,n_det,n_det,N_states_diag,state_target) +! print*, energies(state_target) energies_alpha_beta(state_target, ispin) += energies(state_target) endif enddo enddo ! ispin do state_target = 1, N_states if((norm_no_inv(state_target,1) + norm_no_inv(state_target,2)) .ne. 0.d0)then - one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall_no_exchange(state_target) - & + one_creat_virt(aorb,vorb,state_target) = energy_cas_dyall(state_target) - & ( energies_alpha_beta(state_target,1) + energies_alpha_beta(state_target,2) ) & /( norm_bis(state_target,1) + norm_bis(state_target,2) ) else -! one_creat_virt(aorb,vorb,state_target) = 0.5d0 * (one_anhil(aorb, 1,state_target) + one_anhil(aorb, 2,state_target) ) one_creat_virt(aorb,vorb,state_target) = 0.d0 endif ! print*, '********' @@ -1043,54 +817,50 @@ BEGIN_PROVIDER [ double precision, one_creat_virt, (n_act_orb,n_virt_orb,N_State END_PROVIDER -subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) + + BEGIN_PROVIDER [ double precision, one_anhil_one_creat_inact_virt_bis, (n_inact_orb,n_virt_orb,N_det,N_States)] +&BEGIN_PROVIDER [ double precision, corr_e_from_1h1p, (N_States)] implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,N_states) - double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) integer :: i,vorb,j integer :: ispin,jspin integer :: orb_i, hole_particle_i integer :: orb_v - double precision :: norm_out(N_states),diag_elem(N_det_ref),interact_psi0(N_det_ref) + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) double precision :: delta_e_inact_virt(N_states) integer(bit_kind), allocatable :: psi_in_out(:,:,:) double precision, allocatable :: psi_in_out_coef(:,:) - double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) - double precision, allocatable :: delta_e_det(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:) use bitmasks - allocate (psi_in_out(N_int,2,n_det_ref),psi_in_out_coef(n_det_ref,N_states),H_matrix(N_det_ref+1,N_det_ref+1)) - allocate (eigenvectors(size(H_matrix,1),N_det_ref+1)) - allocate (eigenvalues(N_det_ref+1),interact_cas(N_det_ref,N_det_ref)) - allocate (delta_e_det(N_det_ref,N_det_ref)) + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1)) integer :: iorb,jorb,i_ok integer :: state_target - double precision :: energies(n_states) + double precision :: energies(n_states_diag) double precision :: hij double precision :: energies_alpha_beta(N_states,2) - double precision :: lamda_pt2(N_det_ref) double precision :: accu(N_states),norm - double precision :: amplitudes_alpha_beta(N_det_ref,2) - double precision :: delta_e_alpha_beta(N_det_ref,2) - double precision :: coef_array(N_states) - double precision :: coef_perturb(N_det_ref) - double precision :: coef_perturb_bis(N_det_ref) + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + corr_e_from_1h1p = 0.d0 do vorb = 1,n_virt_orb orb_v = list_virt(vorb) do iorb = 1, n_inact_orb orb_i = list_inact(iorb) +! print*, '---------------------------------------------------------------------------' do j = 1, N_states delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & - fock_virt_total_spin_trace(orb_v,j) enddo do ispin = 1,2 - do i = 1, n_det_ref + do i = 1, n_det do j = 1, N_int - psi_in_out(j,1,i) = psi_ref(j,1,i) - psi_in_out(j,2,i) = psi_ref(j,2,i) + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) enddo call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) if(i_ok.ne.1)then @@ -1099,11 +869,9 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'pb, i_ok ne 0 !!!' endif interact_psi0(i) = 0.d0 - do j = 1 , N_det_ref - call i_H_j(psi_in_out(1,1,i),psi_ref(1,1,j),N_int,hij) - call get_delta_e_dyall(psi_ref(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) - interact_cas(i,j) = hij - interact_psi0(i) += hij * psi_ref_coef(j,1) + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + interact_psi0(i) += hij * psi_coef(j,1) enddo do j = 1, N_int psi_in_out(j,1,i) = psi_active(j,1,i) @@ -1115,27 +883,181 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from do state_target = 1, N_states ! Building the Hamiltonian matrix H_matrix(1,1) = energy_cas_dyall(state_target) - do i = 1, N_det_ref + do i = 1, N_det ! interaction with psi0 - H_matrix(1,i+1) = interact_psi0(i)!* psi_ref_coef(i,state_target) - H_matrix(i+1,1) = interact_psi0(i)!* psi_ref_coef(i,state_target) + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) ! diagonal elements H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) ! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) - do j = i+1, N_det_ref + do j = i+1, N_det call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) H_matrix(i+1,j+1) = hij !0.d0 ! H_matrix(j+1,i+1) = hij !0.d0 ! enddo enddo - call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det_ref+1) + print*, '***' + do i = 1, N_det+1 + write(*,'(100(F16.10,1X))')H_matrix(i,:) + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) + corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) + norm = 0.d0 + do i = 1, N_det + psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) +!! if(dabs(psi_coef(i,state_target)*) .gt. 1.d-8)then + if(dabs(psi_in_out_coef(i,state_target)) .gt. 1.d-8)then +! if(dabs(interact_psi0(i)) .gt. 1.d-8)then + delta_e_alpha_beta(i,ispin) = H_matrix(1,i+1) / psi_in_out_coef(i,state_target) +! delta_e_alpha_beta(i,ispin) = interact_psi0(i) / psi_in_out_coef(i,state_target) + amplitudes_alpha_beta(i,ispin) = psi_in_out_coef(i,state_target) / psi_coef(i,state_target) + else + amplitudes_alpha_beta(i,ispin) = 0.d0 + delta_e_alpha_beta(i,ispin) = delta_e_inact_virt(state_target) + endif +!! one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,ispin,state_target) = amplitudes_alpha_beta(i,ispin) + norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) + enddo + print*, 'Coef ' + write(*,'(100(1X,F16.10))')psi_coef(1:N_det,state_target) + write(*,'(100(1X,F16.10))')psi_in_out_coef(:,state_target) + double precision :: coef_tmp(N_det) + do i = 1, N_det + coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) + enddo + write(*,'(100(1X,F16.10))')coef_tmp(:) + print*, 'naked interactions' + write(*,'(100(1X,F16.10))')interact_psi0(:) + print*, '' + + print*, 'norm ',norm + norm = 1.d0/(norm) + accu(state_target) = 0.d0 + do i = 1, N_det + accu(state_target) += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) * H_matrix(i+1,i+1) + do j = i+1, N_det + accu(state_target) += 2.d0 * psi_in_out_coef(i,state_target) * psi_in_out_coef(j,state_target) * H_matrix(i+1,j+1) + enddo + enddo + accu(state_target) = accu(state_target) * norm + print*, delta_e_inact_virt(state_target) + print*, eigenvalues(1),accu(state_target),eigenvectors(1,1) + print*, energy_cas_dyall(state_target) - accu(state_target), one_anhil_one_creat_inact_virt(iorb,vorb,state_target) + delta_e_inact_virt(state_target) + + enddo + enddo ! ispin + do state_target = 1, N_states + do i = 1, N_det + one_anhil_one_creat_inact_virt_bis(iorb,vorb,i,state_target) = 0.5d0 * & + ( delta_e_alpha_beta(i,1) + delta_e_alpha_beta(i,1)) + enddo + enddo + print*, '***' + write(*,'(100(1X,F16.10))') + write(*,'(100(1X,F16.10))')delta_e_alpha_beta(:,2) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) + print*, '---------------------------------------------------------------------------' + enddo + enddo + deallocate(psi_in_out,psi_in_out_coef,H_matrix,eigenvectors,eigenvalues) + print*, 'corr_e_from_1h1p,',corr_e_from_1h1p(:) + +END_PROVIDER + +subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from_1h1p_singles) + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,N_states) + double precision , intent(out) :: e_corr_from_1h1p_singles(N_states) + integer :: i,vorb,j + integer :: ispin,jspin + integer :: orb_i, hole_particle_i + integer :: orb_v + double precision :: norm_out(N_states_diag),diag_elem(N_det),interact_psi0(N_det) + double precision :: delta_e_inact_virt(N_states) + integer(bit_kind), allocatable :: psi_in_out(:,:,:) + double precision, allocatable :: psi_in_out_coef(:,:) + double precision, allocatable :: H_matrix(:,:),eigenvectors(:,:),eigenvalues(:),interact_cas(:,:) + double precision, allocatable :: delta_e_det(:,:) + use bitmasks + allocate (psi_in_out(N_int,2,n_det),psi_in_out_coef(n_det,N_states_diag),H_matrix(N_det+1,N_det+1)) + allocate (eigenvectors(size(H_matrix,1),N_det+1)) + allocate (eigenvalues(N_det+1),interact_cas(N_det,N_det)) + allocate (delta_e_det(N_det,N_det)) + + integer :: iorb,jorb,i_ok + integer :: state_target + double precision :: energies(n_states_diag) + double precision :: hij + double precision :: energies_alpha_beta(N_states,2) + double precision :: lamda_pt2(N_det) + + + double precision :: accu(N_states),norm + double precision :: amplitudes_alpha_beta(N_det,2) + double precision :: delta_e_alpha_beta(N_det,2) + double precision :: coef_array(N_states) + double precision :: coef_perturb(N_det) + double precision :: coef_perturb_bis(N_det) + + do vorb = 1,n_virt_orb + orb_v = list_virt(vorb) + do iorb = 1, n_inact_orb + orb_i = list_inact(iorb) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(orb_i,j) & + - fock_virt_total_spin_trace(orb_v,j) + enddo + do ispin = 1,2 + do i = 1, n_det + do j = 1, N_int + psi_in_out(j,1,i) = psi_det(j,1,i) + psi_in_out(j,2,i) = psi_det(j,2,i) + enddo + call do_mono_excitation(psi_in_out(1,1,i),orb_i,orb_v,ispin,i_ok) + if(i_ok.ne.1)then + print*, orb_i,orb_v + call debug_det(psi_in_out,N_int) + print*, 'pb, i_ok ne 0 !!!' + endif + interact_psi0(i) = 0.d0 + do j = 1 , N_det + call i_H_j(psi_in_out(1,1,i),psi_det(1,1,j),N_int,hij) + call get_delta_e_dyall(psi_det(1,1,j),psi_in_out(1,1,i),coef_array,hij,delta_e_det(i,j)) + interact_cas(i,j) = hij + interact_psi0(i) += hij * psi_coef(j,1) + enddo + do j = 1, N_int + psi_in_out(j,1,i) = psi_active(j,1,i) + psi_in_out(j,2,i) = psi_active(j,2,i) + enddo + call i_H_j_dyall(psi_active(1,1,i),psi_active(1,1,i),N_int,hij) + diag_elem(i) = hij + enddo + do state_target = 1, N_states + ! Building the Hamiltonian matrix + H_matrix(1,1) = energy_cas_dyall(state_target) + do i = 1, N_det + ! interaction with psi0 + H_matrix(1,i+1) = interact_psi0(i)!* psi_coef(i,state_target) + H_matrix(i+1,1) = interact_psi0(i)!* psi_coef(i,state_target) + ! diagonal elements + H_matrix(i+1,i+1) = diag_elem(i) - delta_e_inact_virt(state_target) +! print*, 'H_matrix(i+1,i+1)',H_matrix(i+1,i+1) + do j = i+1, N_det + call i_H_j_dyall(psi_in_out(1,1,i),psi_in_out(1,1,j),N_int,hij) + H_matrix(i+1,j+1) = hij !0.d0 ! + H_matrix(j+1,i+1) = hij !0.d0 ! + enddo + enddo + call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) e_corr_from_1h1p_singles(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) - do i = 1, N_det_ref + do i = 1, N_det psi_in_out_coef(i,state_target) = eigenvectors(i+1,1)/eigenvectors(1,1) coef_perturb(i) = 0.d0 - do j = 1, N_det_ref - coef_perturb(i) += psi_ref_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) + do j = 1, N_det + coef_perturb(i) += psi_coef(j,state_target) * interact_cas(i,j) *1.d0/delta_e_det(i,j) enddo coef_perturb_bis(i) = interact_psi0(i) / (eigenvalues(1) - H_matrix(i+1,i+1)) if(dabs(interact_psi0(i)) .gt. 1.d-12)then @@ -1146,22 +1068,22 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from enddo if(dabs(eigenvalues(1) - energy_cas_dyall(state_target)).gt.1.d-10)then print*, '' - do i = 1, N_det_ref+1 + do i = 1, N_det+1 write(*,'(100(F16.10))') H_matrix(i,:) enddo accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += psi_in_out_coef(i,state_target) * interact_psi0(i) enddo print*, '' print*, 'e corr diagonal ',accu(state_target) accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += coef_perturb(i) * interact_psi0(i) enddo print*, 'e corr perturb ',accu(state_target) accu = 0.d0 - do i = 1, N_det_ref + do i = 1, N_det accu(state_target) += coef_perturb_bis(i) * interact_psi0(i) enddo print*, 'e corr perturb EN',accu(state_target) @@ -1174,10 +1096,10 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from write(*,'(100(F16.10,1X))')coef_perturb_bis(:) endif integer :: k - do k = 1, N_det_ref - do i = 1, N_det_ref + do k = 1, N_det + do i = 1, N_det matrix_1h1p(i,i,state_target) += interact_cas(k,i) * interact_cas(k,i) * lamda_pt2(k) - do j = i+1, N_det_ref + do j = i+1, N_det matrix_1h1p(i,j,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) matrix_1h1p(j,i,state_target) += interact_cas(k,i) * interact_cas(k,j) * lamda_pt2(k) enddo diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 9376e0cc..491cda58 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -25,7 +25,6 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor -! print*, orb,hole_particle,spin_exc elec_num_tab_local = 0 do i = 1, ndet @@ -37,7 +36,6 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & exit endif enddo -! print*, elec_num_tab_local(1),elec_num_tab_local(2) if(hole_particle == 1)then do i = 1, ndet call set_bit_to_integer(orb,psi_in_out(1,spin_exc,i),N_int) @@ -214,97 +212,52 @@ double precision function diag_H_mat_elem_no_elec_check(det_in,Nint) core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo - -end +! print*,'core_act = ',core_act +! print*,'alpha_alpha = ',alpha_alpha +! print*,'alpha_beta = ',alpha_beta +! print*,'beta_beta = ',beta_beta +! print*,'mono_elec = ',mono_elec + +! do i = 1, n_core_inact_orb +! iorb = list_core_inact(i) +! diag_H_mat_elem_no_elec_check += 2.d0 * fock_core_inactive_total_spin_trace(iorb,1) +! enddo +!!!!!!!!!!!! +return +!!!!!!!!!!!! -double precision function diag_H_mat_elem_no_elec_check_no_spin(det_in,Nint) - implicit none - BEGIN_DOC - ! Computes - END_DOC - integer,intent(in) :: Nint - integer(bit_kind),intent(in) :: det_in(Nint,2) - - integer :: i, j, iorb, jorb - integer :: occ(Nint*bit_kind_size,2) - integer :: elec_num_tab_local(2) - - double precision :: core_act - double precision :: alpha_alpha - double precision :: alpha_beta - double precision :: beta_beta - double precision :: mono_elec - core_act = 0.d0 - alpha_alpha = 0.d0 - alpha_beta = 0.d0 - beta_beta = 0.d0 - mono_elec = 0.d0 - - diag_H_mat_elem_no_elec_check_no_spin = 0.d0 - call bitstring_to_list(det_in(1,1), occ(1,1), elec_num_tab_local(1), N_int) - call bitstring_to_list(det_in(1,2), occ(1,2), elec_num_tab_local(2), N_int) - ! alpha - alpha - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - alpha_alpha += mo_bielec_integral_jj(jorb,iorb) + ! alpha - alpha + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) enddo - enddo + enddo - ! beta - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_spin += mo_mono_elec_integral(iorb,iorb) - mono_elec += mo_mono_elec_integral(iorb,iorb) - do j = i+1, elec_num_tab_local(2) - jorb = occ(j,2) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - beta_beta += mo_bielec_integral_jj(jorb,iorb) + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_mono_elec_integral(iorb,iorb) + do j = i+1, n_core_inact_orb + jorb = list_core_inact(j) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) - 1.d0 * mo_bielec_integral_jj_exchange(jorb,iorb) enddo - enddo - + enddo - ! alpha - beta - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, elec_num_tab_local(1) - jorb = occ(j,1) - diag_H_mat_elem_no_elec_check_no_spin += mo_bielec_integral_jj(jorb,iorb) - alpha_beta += mo_bielec_integral_jj(jorb,iorb) - enddo - enddo - - - ! alpha - core-act - do i = 1, elec_num_tab_local(1) - iorb = occ(i,1) + do i = 1, n_core_inact_orb + iorb = list_core_inact(i) do j = 1, n_core_inact_orb jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) + diag_H_mat_elem_no_elec_check += 1.d0 * mo_bielec_integral_jj(jorb,iorb) enddo - enddo - - ! beta - core-act - do i = 1, elec_num_tab_local(2) - iorb = occ(i,2) - do j = 1, n_core_inact_orb - jorb = list_core_inact(j) - diag_H_mat_elem_no_elec_check_no_spin += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - core_act += 2.d0 * mo_bielec_integral_jj(jorb,iorb) - enddo - enddo + enddo end - subroutine i_H_j_dyall(key_i,key_j,Nint,hij) use bitmasks implicit none @@ -436,133 +389,6 @@ subroutine i_H_j_dyall(key_i,key_j,Nint,hij) end -subroutine i_H_j_dyall_no_spin(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_no_elec_check, phase,phase_2 - integer :: n_occ_ab(2) - logical :: has_mipi(Nint*bit_kind_size) - double precision :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size) - PROVIDE mo_bielec_integrals_in_map mo_integrals_map - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,1,2) .and. exc(1,1,2) == exc(1,2,1) )then - hij = 0.d0 - else - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*get_mo_bielec_integral( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_map) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*get_mo_bielec_integral( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_map) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - has_mipi = .False. - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - do k = 1, n_occ_ab(1) - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, n_occ_ab(2) - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) !- miip(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) - enddo - - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - do k = 1, n_occ_ab(2) - i = occ(k,2) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - miip(i) = get_mo_bielec_integral(m,i,i,p,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - do k = 1, n_occ_ab(1) - i = occ(k,1) - if (.not.has_mipi(i)) then - mipi(i) = get_mo_bielec_integral(m,i,p,i,mo_integrals_map) - has_mipi(i) = .True. - endif - enddo - - do k = 1, n_occ_ab(1) - hij = hij + mipi(occ(k,1)) - enddo - do k = 1, n_occ_ab(2) - hij = hij + mipi(occ(k,2)) !- miip(occ(k,2)) - enddo - - endif - hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) - - case (0) - double precision :: diag_H_mat_elem_no_elec_check_no_spin - hij = diag_H_mat_elem_no_elec_check_no_spin(key_i,Nint) - end select -end - - - subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) use bitmasks implicit none @@ -588,7 +414,6 @@ subroutine u0_H_dyall_u0(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coe do j = 1, ndet if(psi_coef_tmp(j)==0.d0)cycle call i_H_j_dyall(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) -! call i_H_j_dyall_no_spin(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) accu += psi_coef_tmp(i) * psi_coef_tmp(j) * hij enddo enddo @@ -677,7 +502,6 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) integer :: n_occ_ab(2) logical :: has_mipi(Nint*bit_kind_size) double precision :: mipi(Nint*bit_kind_size) - double precision :: diag_H_mat_elem PROVIDE mo_bielec_integrals_in_map mo_integrals_map ASSERT (Nint > 0) @@ -774,12 +598,9 @@ subroutine i_H_j_dyall_no_exchange(key_i,key_j,Nint,hij) endif hij = phase*(hij + mo_mono_elec_integral(m,p) + fock_operator_active_from_core_inact(m,p) ) -! hij = phase*(hij + mo_mono_elec_integral(m,p) ) case (0) hij = diag_H_mat_elem_no_elec_check_no_exchange(key_i,Nint) -! hij = diag_H_mat_elem(key_i,Nint) -! hij = 0.d0 end select end @@ -804,7 +625,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! alpha - alpha do i = 1, elec_num_tab_local(1) iorb = occ(i,1) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(1) jorb = occ(j,1) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -814,7 +635,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) ! beta - beta do i = 1, elec_num_tab_local(2) iorb = occ(i,2) - diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) !+ fock_operator_active_from_core_inact(iorb,iorb) + diag_H_mat_elem_no_elec_check_no_exchange += mo_mono_elec_integral(iorb,iorb) do j = i+1, elec_num_tab_local(2) jorb = occ(j,2) diag_H_mat_elem_no_elec_check_no_exchange += mo_bielec_integral_jj(jorb,iorb) @@ -832,16 +653,13 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) enddo -! return - ! alpha - core-act do i = 1, elec_num_tab_local(1) iorb = occ(i,1) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) -! core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) -! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(1) + core_act_exchange(1) += - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo @@ -851,8 +669,7 @@ double precision function diag_H_mat_elem_no_elec_check_no_exchange(det_in,Nint) do j = 1, n_core_inact_orb jorb = list_core_inact(j) diag_H_mat_elem_no_elec_check_no_exchange += 2.d0 * mo_bielec_integral_jj(jorb,iorb) -! core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) -! diag_H_mat_elem_no_elec_check_no_exchange += core_act_exchange(2) + core_act_exchange(2) += - mo_bielec_integral_jj_exchange(jorb,iorb) enddo enddo @@ -889,45 +706,3 @@ subroutine u0_H_dyall_u0_no_exchange(energies,psi_in,psi_in_coef,ndet,dim_psi_in energies(state_target) = accu deallocate(psi_coef_tmp) end - - - -!subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_active,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) -subroutine u0_H_dyall_u0_no_exchange_bis(energies,psi_in,psi_in_coef,ndet,dim_psi_in,dim_psi_coef,N_states_in,state_target) - use bitmasks - implicit none - integer, intent(in) :: N_states_in,ndet,dim_psi_in,dim_psi_coef,state_target -!integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in),psi_in_active(N_int,2,dim_psi_in) - integer(bit_kind), intent(in) :: psi_in(N_int,2,dim_psi_in) - double precision, intent(in) :: psi_in_coef(dim_psi_coef,N_states_in) - double precision, intent(out) :: energies(N_states_in) - - integer :: i,j - double precision :: hij,accu - energies = 0.d0 - accu = 0.d0 - double precision, allocatable :: psi_coef_tmp(:) - allocate(psi_coef_tmp(ndet)) - - do i = 1, ndet - psi_coef_tmp(i) = psi_in_coef(i,state_target) - enddo - - double precision :: hij_bis,diag_H_mat_elem - do i = 1, ndet - if(psi_coef_tmp(i)==0.d0)cycle - do j = i+1, ndet - if(psi_coef_tmp(j)==0.d0)cycle -! call i_H_j_dyall_no_exchange(psi_in_active(1,1,i),psi_in_active(1,1,j),N_int,hij) - call i_H_j(psi_in(1,1,i),psi_in(1,1,j),N_int,hij) - accu += 2.d0 * psi_coef_tmp(i) * psi_coef_tmp(j) * hij - enddo - enddo - do i = 1, N_det - if(psi_coef_tmp(i)==0.d0)cycle - accu += psi_coef_tmp(i) * psi_coef_tmp(i) * diag_H_mat_elem(psi_in(1,1,i),N_int) - enddo - energies(state_target) = accu - deallocate(psi_coef_tmp) -end - diff --git a/plugins/MRPT_Utils/fock_like_operators.irp.f b/plugins/MRPT_Utils/fock_like_operators.irp.f index f16aba26..d4ce0661 100644 --- a/plugins/MRPT_Utils/fock_like_operators.irp.f +++ b/plugins/MRPT_Utils/fock_like_operators.irp.f @@ -197,7 +197,7 @@ k_inact_core_orb = list_core_inact(k) coulomb = get_mo_bielec_integral(k_inact_core_orb,iorb,k_inact_core_orb,jorb,mo_integrals_map) exchange = get_mo_bielec_integral(k_inact_core_orb,jorb,iorb,k_inact_core_orb,mo_integrals_map) - accu += 2.d0 * coulomb - exchange + accu += 2.d0 * coulomb - exchange enddo fock_operator_active_from_core_inact(iorb,jorb) = accu enddo diff --git a/plugins/MRPT_Utils/mrpt_dress.irp.f b/plugins/MRPT_Utils/mrpt_dress.irp.f index a08b6108..275af0e4 100644 --- a/plugins/MRPT_Utils/mrpt_dress.irp.f +++ b/plugins/MRPT_Utils/mrpt_dress.irp.f @@ -44,11 +44,11 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip integer :: N_miniList, leng double precision :: delta_e(N_states),hij_tmp integer :: index_i,index_j - double precision :: phase_array(N_det_ref),phase + double precision :: phase_array(N_det),phase integer :: exc(0:2,2,2),degree - leng = max(N_det_generators, N_det_generators) + leng = max(N_det_generators, N_det) allocate(miniList(Nint, 2, leng), idx_miniList(leng)) !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) @@ -59,81 +59,35 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip end if - call find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) + call find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) if(N_tq > 0) then - call create_minilist(key_mask, psi_ref, miniList, idx_miniList, N_det_ref, N_minilist, Nint) + call create_minilist(key_mask, psi_det, miniList, idx_miniList, N_det, N_minilist, Nint) end if - double precision :: coef_array(N_states) do i_alpha=1,N_tq -! do i = 1, N_det_ref -! do i_state = 1, N_states -! coef_array(i_state) = psi_ref_coef(i,i_state) -! enddo -! call i_H_j(psi_ref(1,1,i),tq(1,1,i_alpha),n_int,hialpha) -! if(dabs(hialpha).le.1.d-20)then -! do i_state = 1, N_states -! delta_e(i_state) = 1.d+20 -! enddo -! else -! call get_delta_e_dyall(psi_ref(1,1,i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) -! endif -! hij_array(i) = hialpha -! do i_state = 1,N_states -! delta_e_inv_array(i,i_state) = 1.d0/delta_e(i_state) -! enddo -! enddo -! do i = 1, N_det_ref -! do j = 1, N_det_ref -! do i_state = 1, N_states -! delta_ij_(i,j,i_state) += hij_array(i) * hij_array(j)* delta_e_inv_array(j,i_state) -! enddo -! enddo -! enddo -! cycle - - - - ! call get_excitation_degree_vector(psi_ref,tq(1,1,i_alpha),degree_alpha,Nint,N_det_ref,idx_alpha) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) do j=1,idx_alpha(0) idx_alpha(j) = idx_miniList(idx_alpha(j)) enddo +! double precision :: ihpsi0,coef_pert +! ihpsi0 = 0.d0 +! coef_pert = 0.d0 phase_array =0.d0 do i = 1,idx_alpha(0) index_i = idx_alpha(i) - call i_h_j(tq(1,1,i_alpha),psi_ref(1,1,index_i),Nint,hialpha) + call i_h_j(tq(1,1,i_alpha),psi_det(1,1,index_i),Nint,hialpha) + double precision :: coef_array(N_states) do i_state = 1, N_states - coef_array(i_state) = psi_ref_coef(index_i,i_state) + coef_array(i_state) = psi_coef(index_i,i_state) enddo - integer :: degree_scalar - - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,index_i),degree_scalar,N_int) -! if(degree_scalar == 2)then -! hialpha = 0.d0 -! endif - if(dabs(hialpha).le.1.d-20)then - do i_state = 1, N_states - delta_e(i_state) = 1.d+20 - enddo - else - call get_delta_e_dyall(psi_ref(1,1,index_i),tq(1,1,i_alpha),delta_e) - if(degree_scalar.eq.1)then - delta_e = 1.d+20 - endif -! print*, 'delta_e',delta_e - !!!!!!!!!!!!! SHIFTED BK -! double precision :: hjj -! call i_h_j(tq(1,1,i_alpha),tq(1,1,i_alpha),Nint,hjj) -! delta_e(1) = electronic_psi_ref_average_value(1) - hjj -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - endif + call get_delta_e_dyall(psi_det(1,1,index_i),tq(1,1,i_alpha),coef_array,hialpha,delta_e) hij_array(index_i) = hialpha -! print*, 'hialpha ',hialpha + call get_excitation(psi_det(1,1,index_i),tq(1,1,i_alpha),exc,degree,phase,N_int) +! phase_array(index_i) = phase do i_state = 1,N_states delta_e_inv_array(index_i,i_state) = 1.d0/delta_e(i_state) enddo @@ -145,14 +99,18 @@ subroutine mrpt_dress(delta_ij_, Ndet,i_generator,n_selected,det_buffer,Nint,ip call omp_set_lock( psi_ref_bis_lock(index_i) ) do j = 1, idx_alpha(0) index_j = idx_alpha(j) - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST -! if(index_j .ne. index_i)cycle - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST - !!!!!!!!!!!!!!!!!! WARNING TEST +! call get_excitation(psi_det(1,1,index_i),psi_det(1,1,index_i),exc,degree,phase,N_int) +! if(index_j.ne.index_i)then +! if(phase_array(index_j) * phase_array(index_i) .ne. phase)then +! print*, phase_array(index_j) , phase_array(index_i) ,phase +! call debug_det(psi_det(1,1,index_i),N_int) +! call debug_det(psi_det(1,1,index_j),N_int) +! call debug_det(tq(1,1,i_alpha),N_int) +! stop +! endif +! endif do i_state=1,N_states - ! standard dressing first order +! standard dressing first order delta_ij_(index_i,index_j,i_state) += hij_array(index_j) * hij_tmp * delta_e_inv_array(index_j,i_state) enddo enddo @@ -164,23 +122,23 @@ end - BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_ref,2) ] -&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_ref,2) ] - gen_det_sorted(:,:,:,1) = psi_ref(:,:,:N_det_ref) - gen_det_sorted(:,:,:,2) = psi_ref(:,:,:N_det_ref) - call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_ref, N_int) - call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_ref, N_int) + BEGIN_PROVIDER [ integer(bit_kind), gen_det_sorted, (N_int,2,N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_shortcut, (0:N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_version, (N_int, N_det_generators,2) ] +&BEGIN_PROVIDER [ integer, gen_det_idx, (N_det_generators,2) ] + gen_det_sorted(:,:,:,1) = psi_det_generators(:,:,:N_det_generators) + gen_det_sorted(:,:,:,2) = psi_det_generators(:,:,:N_det_generators) + call sort_dets_ab_v(gen_det_sorted(:,:,:,1), gen_det_idx(:,1), gen_det_shortcut(0:,1), gen_det_version(:,:,1), N_det_generators, N_int) + call sort_dets_ba_v(gen_det_sorted(:,:,:,2), gen_det_idx(:,2), gen_det_shortcut(0:,2), gen_det_version(:,:,2), N_det_generators, N_int) END_PROVIDER -subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) +subroutine find_connections_previous(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) use bitmasks implicit none - integer, intent(in) :: n_selected, Nint + integer, intent(in) :: i_generator,n_selected, Nint integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) integer :: i,j,k,m @@ -197,7 +155,7 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList logical, external :: is_connected_to - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_ref) + integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) integer,intent(in) :: N_miniList @@ -210,7 +168,7 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList cycle end if - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det_ref)) then + if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint,N_det)) then N_tq += 1 do k=1,N_int tq(k,1,N_tq) = det_buffer(k,1,i) @@ -221,3 +179,8 @@ subroutine find_connections_previous(n_selected,det_buffer,Nint,tq,N_tq,miniList end + + + + + diff --git a/plugins/MRPT_Utils/mrpt_utils.irp.f b/plugins/MRPT_Utils/mrpt_utils.irp.f index 79aa624f..d7b1f0f6 100644 --- a/plugins/MRPT_Utils/mrpt_utils.irp.f +++ b/plugins/MRPT_Utils/mrpt_utils.irp.f @@ -34,44 +34,43 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo - write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h(i_state) = accu(i_state) enddo print*, '1h = ',accu -!! 1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1p(i_state) = accu(i_state) -!enddo -!print*, '1p = ',accu + ! 1p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1p(i_state) = accu(i_state) + enddo + print*, '1p = ',accu ! 1h1p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) -!double precision :: e_corr_from_1h1p_singles(N_states) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1h1p(i_state) = accu(i_state) -!enddo -!print*, '1h1p = ',accu + delta_ij_tmp = 0.d0 + call H_apply_mrpt_1h1p(delta_ij_tmp,N_det) + double precision :: e_corr_from_1h1p_singles(N_states) +!call give_singles_and_partial_doubles_1h1p_contrib(delta_ij_tmp,e_corr_from_1h1p_singles) +!call give_1h1p_only_doubles_spin_cross(delta_ij_tmp) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h1p(i_state) = accu(i_state) + enddo + print*, '1h1p = ',accu ! 1h1p third order if(do_third_order_1h1p)then @@ -84,80 +83,75 @@ accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) enddo - write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) enddo second_order_pt_new_1h1p(i_state) = accu(i_state) enddo print*, '1h1p(3)',accu endif -!! 2h -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2h(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2h(i_state) = accu(i_state) -!enddo -!print*, '2h = ',accu + ! 2h + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2h(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h(i_state) = accu(i_state) + enddo + print*, '2h = ',accu -!! 2p -!delta_ij_tmp = 0.d0 -!call H_apply_mrpt_2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2p(i_state) = accu(i_state) -!enddo -!print*, '2p = ',accu + ! 2p + delta_ij_tmp = 0.d0 + call H_apply_mrpt_2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2p(i_state) = accu(i_state) + enddo + print*, '2p = ',accu ! 1h2p delta_ij_tmp = 0.d0 !call give_1h2p_contrib(delta_ij_tmp) -!call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_1h2p(i_state) = accu(i_state) -!enddo -!print*, '1h2p = ',accu + call H_apply_mrpt_1h2p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_1h2p(i_state) = accu(i_state) + enddo + print*, '1h2p = ',accu -!! 2h1p -!delta_ij_tmp = 0.d0 + ! 2h1p + delta_ij_tmp = 0.d0 !call give_2h1p_contrib(delta_ij_tmp) -!call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) -!accu = 0.d0 -!do i_state = 1, N_states -!do i = 1, N_det -! do j = 1, N_det -! accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) -! delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) -! enddo -! write(*,'(1000(F16.10,x))')delta_ij_tmp(i,:,:) -!enddo -!second_order_pt_new_2h1p(i_state) = accu(i_state) -!enddo -!print*, '2h1p = ',accu + call H_apply_mrpt_2h1p(delta_ij_tmp,N_det) + accu = 0.d0 + do i_state = 1, N_states + do i = 1, N_det + do j = 1, N_det + accu(i_state) += delta_ij_tmp(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) + delta_ij(j,i,i_state) += delta_ij_tmp(j,i,i_state) + enddo + enddo + second_order_pt_new_2h1p(i_state) = accu(i_state) + enddo + print*, '2h1p = ',accu -!! 2h2p + ! 2h2p !delta_ij_tmp = 0.d0 !call H_apply_mrpt_2h2p(delta_ij_tmp,N_det) !accu = 0.d0 @@ -184,13 +178,10 @@ ! total - print*, '' - print*, 'total dressing' - print*, '' accu = 0.d0 do i_state = 1, N_states do i = 1, N_det - write(*,'(1000(F16.10,x))')delta_ij(i,:,:) +! write(*,'(1000(F16.10,x))')delta_ij(i,:,:) do j = i_state, N_det accu(i_state) += delta_ij(j,i,i_state) * psi_coef(i,i_state) * psi_coef(j,i_state) enddo @@ -232,7 +223,7 @@ END_PROVIDER enddo END_PROVIDER - BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_electronic_energy, (N_states_diag) ] + BEGIN_PROVIDER [ double precision, CI_electronic_dressed_pt2_new_energy, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_eigenvectors_s2, (N_states_diag) ] BEGIN_DOC @@ -254,7 +245,7 @@ END_PROVIDER integer, allocatable :: iorder(:) ! Guess values for the "N_states_diag" states of the CI_dressed_pt2_new_eigenvectors - do j=1,min(N_states,N_det) + do j=1,min(N_states_diag,N_det) do i=1,N_det CI_dressed_pt2_new_eigenvectors(i,j) = psi_coef(i,j) enddo @@ -276,7 +267,7 @@ END_PROVIDER allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) allocate (eigenvalues(N_det)) call lapack_diag(eigenvalues,eigenvectors, & - Hmatrix_dressed_pt2_new_symmetrized,size(H_matrix_all_dets,1),N_det) + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) CI_electronic_energy(:) = 0.d0 if (s2_eig) then i_state = 0 @@ -285,10 +276,8 @@ END_PROVIDER good_state_array = .False. call u_0_S2_u_0(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,& N_det,size(eigenvectors,1)) - print*,'N_det',N_det do j=1,N_det ! Select at least n_states states with S^2 values closed to "expected_s2" - print*, s2_eigvalues(j),expected_s2 if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then i_state +=1 index_good_state_array(i_state) = j @@ -302,10 +291,10 @@ END_PROVIDER ! Fill the first "i_state" states that have a correct S^2 value do j = 1, i_state do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) + CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j)) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(index_good_state_array(j)) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) + CI_electronic_energy(j) = eigenvalues(index_good_state_array(j)) + CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j)) enddo i_other_state = 0 do j = 1, N_det @@ -315,10 +304,10 @@ END_PROVIDER exit endif do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) + CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(i_state+i_other_state) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) + CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) + CI_eigenvectors_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state) enddo else @@ -333,10 +322,10 @@ END_PROVIDER print*,'' do j=1,min(N_states_diag,N_det) do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + CI_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) - CI_dressed_pt2_new_eigenvectors_s2(j) = s2_eigvalues(j) + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2_eigvalues(j) enddo endif deallocate(index_good_state_array,good_state_array) @@ -347,9 +336,9 @@ END_PROVIDER ! Select the "N_states_diag" states of lowest energy do j=1,min(N_det,N_states_diag) do i=1,N_det - CI_dressed_pt2_new_eigenvectors(i,j) = eigenvectors(i,j) + CI_eigenvectors(i,j) = eigenvectors(i,j) enddo - CI_dressed_pt2_new_electronic_energy(j) = eigenvalues(j) + CI_electronic_energy(j) = eigenvalues(j) enddo endif deallocate(eigenvectors,eigenvalues) @@ -369,7 +358,7 @@ BEGIN_PROVIDER [ double precision, CI_dressed_pt2_new_energy, (N_states_diag) ] character*(8) :: st call write_time(output_determinants) do j=1,N_states_diag - CI_dressed_pt2_new_energy(j) = CI_dressed_pt2_new_electronic_energy(j) + nuclear_repulsion + CI_dressed_pt2_new_energy(j) = CI_electronic_dressed_pt2_new_energy(j) + nuclear_repulsion write(st,'(I4)') j call write_double(output_determinants,CI_dressed_pt2_new_energy(j),'Energy of state '//trim(st)) call write_double(output_determinants,CI_eigenvectors_s2(j),'S^2 of state '//trim(st)) diff --git a/plugins/MRPT_Utils/new_way.irp.f b/plugins/MRPT_Utils/new_way.irp.f index a007e761..fa5812e1 100644 --- a/plugins/MRPT_Utils/new_way.irp.f +++ b/plugins/MRPT_Utils/new_way.irp.f @@ -1,7 +1,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_2h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_2h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -22,8 +22,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -38,14 +38,14 @@ subroutine give_2h1p_contrib(matrix_2h1p) active_int(a,2) = get_mo_bielec_integral(iorb,jorb,aorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det_ref,3) + integer :: index_orb_act_mono(N_det,3) - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) do jspin = 1, 2 ! spin of the couple z-a^dagger (j,a) @@ -53,8 +53,8 @@ subroutine give_2h1p_contrib(matrix_2h1p) do a = 1, n_act_orb ! First active aorb = list_act(a) do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -64,7 +64,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) call clear_bit_to_integer(jorb,det_tmp(1,jspin),N_int) ! hole in "jorb" of spin Jspin call set_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! particle in "aorb" of spin Jspin - ! Check if the excitation is possible or not on psi_ref(idet) + ! Check if the excitation is possible or not on psi_det(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -81,7 +81,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) perturb_dets(inint,1,a,jspin,ispin) = det_tmp(inint,1) perturb_dets(inint,2,a,jspin,ispin) = det_tmp(inint,2) enddo - call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_creat(a,jspin,istate) & @@ -109,7 +109,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,2,1)) !!! a^{\dagger}_a @@ -129,7 +129,6 @@ subroutine give_2h1p_contrib(matrix_2h1p) integer :: kspin do jdet = 1, idx(0) if(idx(jdet).ne.idet)then -! cycle ! two determinants | Idet > and | Jdet > which are connected throw a mono excitation operator ! are connected by the presence of the perturbers determinants |det_tmp> aorb = index_orb_act_mono(idx(jdet),1) ! a^{\dagger}_{aorb} @@ -151,7 +150,7 @@ subroutine give_2h1p_contrib(matrix_2h1p) ! you determine the interaction between the excited determinant and the other parent | Jdet > ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{borb,kspin} a_{jorb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,2) - active_int(borb,1) ) else @@ -196,7 +195,7 @@ end subroutine give_1h2p_contrib(matrix_1h2p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h2p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h2p(N_det,N_det,*) integer :: i,v,r,a,b integer :: iorb, vorb, rorb, aorb, borb integer :: ispin,jspin @@ -214,18 +213,16 @@ subroutine give_1h2p_contrib(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase !matrix_1h2p = 0.d0 + elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo -!do i = 1, 1 ! First inactive do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) -! do v = 1, 1 do v = 1, n_virt_orb ! First virtual vorb = list_virt(v) -! do r = 1, 1 do r = 1, n_virt_orb ! Second virtual rorb = list_virt(r) ! take all the integral you will need for i,j,r fixed @@ -235,14 +232,14 @@ subroutine give_1h2p_contrib(matrix_1h2p) active_int(a,2) = get_mo_bielec_integral(iorb,aorb,vorb,rorb,mo_integrals_map) ! exchange enddo - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate - integer :: index_orb_act_mono(N_det_ref,3) + integer :: index_orb_act_mono(N_det,3) - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements do ispin = 1, 2 ! spin of the couple a-a^dagger (iorb,rorb) do jspin = 1, 2 ! spin of the couple a-a^dagger (aorb,vorb) @@ -250,8 +247,8 @@ subroutine give_1h2p_contrib(matrix_1h2p) aorb = list_act(a) if(ispin == jspin .and. vorb.le.rorb)cycle ! condition not to double count do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin @@ -261,7 +258,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) call clear_bit_to_integer(aorb,det_tmp(1,jspin),N_int) ! hole in "aorb" of spin Jspin call set_bit_to_integer(vorb,det_tmp(1,jspin),N_int) ! particle in "vorb" of spin Jspin - ! Check if the excitation is possible or not on psi_ref(idet) + ! Check if the excitation is possible or not on psi_det(idet) accu_elec= 0 do inint = 1, N_int accu_elec+= popcnt(det_tmp(inint,jspin)) @@ -283,7 +280,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) det_tmp(inint,2) = perturb_dets(inint,2,a,jspin,ispin) enddo - call get_double_excitation(psi_ref(1,1,idet),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),det_tmp,exc,phase,N_int) perturb_dets_phase(a,jspin,ispin) = phase do istate = 1, N_states delta_e(a,jspin,istate) = one_anhil(a,jspin,istate) & @@ -311,7 +308,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) !!!!!!!!!!!!!!!!!!!!!!!!!!!! do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) if (exc(0,1,1) == 1) then ! Mono alpha index_orb_act_mono(idx(jdet),1) = list_act_reverse(exc(1,1,1)) !!! a_a @@ -353,7 +350,7 @@ subroutine give_1h2p_contrib(matrix_1h2p) ! | det_tmp > = a^{\dagger}_{rorb,ispin} a^{\dagger}_{vorb,kspin} a_{borb,kspin} a_{iorb,ispin} | Jdet > ! hja = < det_tmp | H | Jdet > - call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) if(kspin == ispin)then hja = phase * (active_int(borb,1) - active_int(borb,2) ) else @@ -396,10 +393,130 @@ subroutine give_1h2p_contrib(matrix_1h2p) end +subroutine give_1h1p_contrib(matrix_1h1p) + use bitmasks + implicit none + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) + integer :: i,j,r,a,b + integer :: iorb, jorb, rorb, aorb, borb + integer :: ispin,jspin + integer :: idet,jdet + integer :: inint + integer :: elec_num_tab_local(2),acu_elec + integer(bit_kind) :: det_tmp(N_int,2) + integer :: exc(0:2,2,2) + integer :: accu_elec + double precision :: get_mo_bielec_integral + double precision :: active_int(n_act_orb,2) + double precision :: hij,phase + integer :: degree(N_det) + integer :: idx(0:N_det) + integer :: istate + double precision :: hja,delta_e_inact_virt(N_states) + integer :: kspin,degree_scalar +!matrix_1h1p = 0.d0 + + elec_num_tab_local = 0 + do inint = 1, N_int + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) + enddo + do i = 1, n_inact_orb ! First inactive + iorb = list_inact(i) + do r = 1, n_virt_orb ! First virtual + rorb = list_virt(r) + do j = 1, N_states + delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & + - fock_virt_total_spin_trace(rorb,j) + enddo + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations + do jdet = 1, idx(0) + do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) + do inint = 1, N_int + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) + enddo + ! Do the excitation inactive -- > virtual + double precision :: himono,delta_e(N_states),coef_mono(N_states) + call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin + call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) + + do state_target = 1, N_states +! delta_e(state_target) = one_anhil_one_creat_inact_virt(i,r,state_target) + delta_e_inact_virt(state_target) + delta_e(state_target) = one_anhil_one_creat_inact_virt_bis(i,r,idet,state_target) + coef_mono(state_target) = himono / delta_e(state_target) + enddo + if(idx(jdet).ne.idet)then + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + ! Mono beta + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + if(ispin == jspin )then + hij = -get_mo_bielec_integral(iorb,aorb,rorb,borb,mo_integrals_map) & + + get_mo_bielec_integral(iorb,aorb,borb,rorb,mo_integrals_map) + else + hij = get_mo_bielec_integral(iorb,borb,rorb,aorb,mo_integrals_map) + endif + hij = hij * phase + double precision :: hij_test + integer :: state_target + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + if(dabs(hij - hij_test).gt.1.d-10)then + print*, 'ahah pb !!' + print*, 'hij .ne. hij_test' + print*, hij,hij_test + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + print*, ispin, jspin + print*,iorb,borb,rorb,aorb + print*, phase + call i_H_j_verbose(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + stop + endif + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij* coef_mono(state_target) + enddo + else + do state_target = 1, N_states + matrix_1h1p(idet,idet,state_target) += himono * coef_mono(state_target) + enddo + endif + enddo + enddo + + + + enddo + enddo + enddo +end + subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -416,8 +533,8 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer :: kspin,degree_scalar @@ -425,13 +542,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) do r = 1, n_virt_orb ! First virtual @@ -446,13 +563,13 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation inactive -- > virtual call clear_bit_to_integer(iorb,det_tmp(1,ispin),N_int) ! hole in "iorb" of spin Ispin call set_bit_to_integer(rorb,det_tmp(1,ispin),N_int) ! particle in "rorb" of spin Ispin - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -502,9 +619,9 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) do r = 1, n_virt_orb ! First virtual rorb = list_virt(r) do ispin = 1, 2 ! spin of the couple a-a^dagger (i,r) - !do state_target = 1, N_states - ! coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) - !enddo + do state_target = 1, N_states + coef_det_pert(i,r,ispin,state_target,1) += coef_det_pert(i,r,ispin,state_target,2) + enddo do inint = 1, N_int det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) @@ -512,37 +629,37 @@ subroutine give_1h1p_sec_order_singles_contrib(matrix_1h1p) enddo do jdet = 1, idx(0) ! - double precision :: hij_test if(idx(jdet).ne.idet)then - ! call get_mono_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) - ! if (exc(0,1,1) == 1) then - ! ! Mono alpha - ! aorb = (exc(1,2,1)) !!! a^{\dagger}_a - ! borb = (exc(1,1,1)) !!! a_{b} - ! jspin = 1 - ! else - ! aorb = (exc(1,2,2)) !!! a^{\dagger}_a - ! borb = (exc(1,1,2)) !!! a_{b} - ! jspin = 2 - ! endif - ! - ! call get_excitation_degree(psi_ref(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) - ! if(degree_scalar .ne. 2)then - ! print*, 'pb !!!' - ! print*, degree_scalar - ! call debug_det(psi_ref(1,1,idx(jdet)),N_int) - ! call debug_det(det_tmp,N_int) - ! stop - ! endif - ! call get_double_excitation(psi_ref(1,1,idx(jdet)),det_tmp,exc,phase,N_int) - ! hij_test = 0.d0 - ! call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hij_test) - ! do state_target = 1, N_states - ! matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) - ! enddo + call get_mono_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + aorb = (exc(1,2,1)) !!! a^{\dagger}_a + borb = (exc(1,1,1)) !!! a_{b} + jspin = 1 + else + aorb = (exc(1,2,2)) !!! a^{\dagger}_a + borb = (exc(1,1,2)) !!! a_{b} + jspin = 2 + endif + + call get_excitation_degree(psi_det(1,1,idx(jdet)),det_tmp,degree_scalar,N_int) + if(degree_scalar .ne. 2)then + print*, 'pb !!!' + print*, degree_scalar + call debug_det(psi_det(1,1,idx(jdet)),N_int) + call debug_det(det_tmp,N_int) + stop + endif + call get_double_excitation(psi_det(1,1,idx(jdet)),det_tmp,exc,phase,N_int) + double precision :: hij_test + hij_test = 0.d0 + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hij_test) + do state_target = 1, N_states + matrix_1h1p(idx(jdet),idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) + enddo else hij_test = 0.d0 - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hij_test) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hij_test) do state_target = 1, N_states matrix_1h1p(idet,idet,state_target) += hij_test* coef_det_pert(i,r,ispin,state_target,2) enddo @@ -559,7 +676,7 @@ end subroutine give_1p_sec_order_singles_contrib(matrix_1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb,s,sorb integer :: ispin,jspin @@ -575,8 +692,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) integer :: accu_elec double precision :: get_mo_bielec_integral double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_act_virt(N_states) integer :: kspin,degree_scalar @@ -584,13 +701,13 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo double precision :: himono,delta_e(N_states),coef_mono(N_states) integer :: state_target - do idet = 1, N_det_ref - call get_excitation_degree_vector_mono(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_mono(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) do i = 1, n_act_orb ! First active iorb = list_act(i) do r = 1, n_virt_orb ! First virtual @@ -604,8 +721,8 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) delta_e_act_virt(j) = - fock_virt_total_spin_trace(rorb,j) enddo do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation active -- > virtual call do_mono_excitation(det_tmp,iorb,rorb,ispin,i_ok) @@ -622,7 +739,7 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) enddo cycle endif - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,himono) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,himono) do inint = 1, N_int det_pert(inint,1,i,r,ispin) = det_tmp(inint,1) det_pert(inint,2,i,r,ispin) = det_tmp(inint,2) @@ -684,10 +801,10 @@ subroutine give_1p_sec_order_singles_contrib(matrix_1p) det_tmp(inint,1) = det_pert(inint,1,i,r,ispin) det_tmp(inint,2) = det_pert(inint,2,i,r,ispin) enddo - do jdet = 1,N_det_ref + do jdet = 1,N_det double precision :: coef_array(N_states),hij_test - call i_H_j(det_tmp,psi_ref(1,1,jdet),N_int,himono) - call get_delta_e_dyall(psi_ref(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) + call i_H_j(det_tmp,psi_det(1,1,jdet),N_int,himono) + call get_delta_e_dyall(psi_det(1,1,jdet),det_tmp,coef_array,hij_test,delta_e) do state_target = 1, N_states ! matrix_1p(idet,jdet,state_target) += himono * coef_det_pert(i,r,ispin,state_target,1) matrix_1p(idet,jdet,state_target) += himono * hij_det_pert(i,r,ispin) / delta_e(state_target) @@ -705,7 +822,7 @@ end subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) use bitmasks implicit none - double precision , intent(inout) :: matrix_1h1p(N_det_ref,N_det_ref,*) + double precision , intent(inout) :: matrix_1h1p(N_det,N_det,*) integer :: i,j,r,a,b integer :: iorb, jorb, rorb, aorb, borb integer :: ispin,jspin @@ -718,8 +835,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) double precision :: get_mo_bielec_integral double precision :: active_int(n_act_orb,2) double precision :: hij,phase - integer :: degree(N_det_ref) - integer :: idx(0:N_det_ref) + integer :: degree(N_det) + integer :: idx(0:N_det) integer :: istate double precision :: hja,delta_e_inact_virt(N_states) integer(bit_kind) :: pert_det(N_int,2,n_act_orb,n_act_orb,2) @@ -733,8 +850,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) elec_num_tab_local = 0 do inint = 1, N_int - elec_num_tab_local(1) += popcnt(psi_ref(inint,1,1)) - elec_num_tab_local(2) += popcnt(psi_ref(inint,2,1)) + elec_num_tab_local(1) += popcnt(psi_det(inint,1,1)) + elec_num_tab_local(2) += popcnt(psi_det(inint,2,1)) enddo do i = 1, n_inact_orb ! First inactive iorb = list_inact(i) @@ -744,8 +861,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) delta_e_inact_virt(j) = fock_core_inactive_total_spin_trace(iorb,j) & - fock_virt_total_spin_trace(rorb,j) enddo - do idet = 1, N_det_ref - call get_excitation_degree_vector_double_alpha_beta(psi_ref,psi_ref(1,1,idet),degree,N_int,N_det_ref,idx) + do idet = 1, N_det + call get_excitation_degree_vector_double_alpha_beta(psi_det,psi_det(1,1,idet),degree,N_int,N_det,idx) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Precomputation of matrix elements !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Case of the mono excitations do ispin = 1, 2 @@ -755,8 +872,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) do b = 1, n_act_orb borb = list_act(b) do inint = 1, N_int - det_tmp(inint,1) = psi_ref(inint,1,idet) - det_tmp(inint,2) = psi_ref(inint,2,idet) + det_tmp(inint,1) = psi_det(inint,1,idet) + det_tmp(inint,2) = psi_det(inint,2,idet) enddo ! Do the excitation (i-->a)(ispin) + (b-->r)(other_spin(ispin)) integer :: i_ok,corb,dorb @@ -787,7 +904,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) pert_det(inint,2,a,b,ispin) = det_tmp(inint,2) enddo - call i_H_j(psi_ref(1,1,idet),det_tmp,N_int,hidouble) + call i_H_j(psi_det(1,1,idet),det_tmp,N_int,hidouble) do state_target = 1, N_states delta_e(state_target) = one_anhil_one_creat(a,b,ispin,jspin,state_target) + delta_e_inact_virt(state_target) pert_det_coef(a,b,ispin,state_target) = hidouble / delta_e(state_target) @@ -798,7 +915,7 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) enddo do jdet = 1, idx(0) if(idx(jdet).ne.idet)then - call get_double_excitation(psi_ref(1,1,idet),psi_ref(1,1,idx(jdet)),exc,phase,N_int) + call get_double_excitation(psi_det(1,1,idet),psi_det(1,1,idx(jdet)),exc,phase,N_int) integer :: c,d,state_target integer(bit_kind) :: det_tmp_bis(N_int,2) ! excitation from I --> J @@ -818,8 +935,8 @@ subroutine give_1h1p_only_doubles_spin_cross(matrix_1h1p) det_tmp_bis(inint,2) = pert_det(inint,2,c,d,2) enddo double precision :: hjdouble_1,hjdouble_2 - call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) - call i_H_j(psi_ref(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp,N_int,hjdouble_1) + call i_H_j(psi_det(1,1,idx(jdet)),det_tmp_bis,N_int,hjdouble_2) do state_target = 1, N_states matrix_1h1p(idx(jdet),idet,state_target) += (pert_det_coef(c,d,1,state_target) * hjdouble_1 + pert_det_coef(c,d,2,state_target) * hjdouble_2 ) enddo diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index b67f7498..781be55b 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -44,8 +44,8 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) perturb_dets_phase(a,2,1) = -1000.d0 enddo - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate @@ -376,8 +376,8 @@ subroutine give_1h2p_contrib_sec_order(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,6) diff --git a/plugins/MRPT_Utils/psi_active_prov.irp.f b/plugins/MRPT_Utils/psi_active_prov.irp.f index f86947d8..794742b4 100644 --- a/plugins/MRPT_Utils/psi_active_prov.irp.f +++ b/plugins/MRPT_Utils/psi_active_prov.irp.f @@ -152,7 +152,7 @@ subroutine give_particles_in_virt_space(det_1,n_particles_spin,n_particles,parti end -subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) +subroutine get_delta_e_dyall(det_1,det_2,coef_array,hij,delta_e_final) BEGIN_DOC ! routine that returns the delta_e with the Moller Plesset and Dyall operators ! @@ -170,6 +170,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) use bitmasks double precision, intent(out) :: delta_e_final(N_states) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: coef_array(N_states),hij integer :: i,j,k,l integer :: i_state @@ -354,8 +355,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) kspin = particle_list_practical(1,1) i_particle_act = particle_list_practical(2,1) do i_state = 1, N_states -! delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) - delta_e_act(i_state) += two_anhil_one_creat_spin_average(i_particle_act,i_hole_act,j_hole_act,i_state) + delta_e_act(i_state) += two_anhil_one_creat(i_particle_act,i_hole_act,j_hole_act,kspin,ispin,jspin,i_state) enddo else if (n_holes_act == 1 .and. n_particles_act == 2) then @@ -370,9 +370,7 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) j_particle_act = particle_list_practical(2,2) do i_state = 1, N_states -! delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) - delta_e_act(i_state) += 0.5d0 * (two_creat_one_anhil_spin_average(i_particle_act,j_particle_act,i_hole_act,i_state) & - +two_creat_one_anhil_spin_average(j_particle_act,i_particle_act,i_hole_act,i_state)) + delta_e_act(i_state) += two_creat_one_anhil(i_particle_act,j_particle_act,i_hole_act,jspin,kspin,ispin,i_state) enddo else if (n_holes_act == 3 .and. n_particles_act == 0) then @@ -435,4 +433,3 @@ subroutine get_delta_e_dyall(det_1,det_2,delta_e_final) end - diff --git a/plugins/MRPT_Utils/second_order_new.irp.f b/plugins/MRPT_Utils/second_order_new.irp.f index 2a61eece..ba3b421b 100644 --- a/plugins/MRPT_Utils/second_order_new.irp.f +++ b/plugins/MRPT_Utils/second_order_new.irp.f @@ -22,8 +22,8 @@ subroutine give_1h2p_new(matrix_1h2p) double precision :: active_int(n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: delta_e_inactive_virt(N_states) @@ -502,8 +502,8 @@ subroutine give_2h1p_new(matrix_2h1p) double precision :: delta_e_inv(n_act_orb,2,N_states) double precision :: fock_operator_local(n_act_orb,n_act_orb,2) double precision :: delta_e_inactive_virt(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,2,N_states) integer :: istate integer :: index_orb_act_mono(N_det,3) diff --git a/plugins/MRPT_Utils/second_order_new_2p.irp.f b/plugins/MRPT_Utils/second_order_new_2p.irp.f index d086b6c5..11ae18da 100644 --- a/plugins/MRPT_Utils/second_order_new_2p.irp.f +++ b/plugins/MRPT_Utils/second_order_new_2p.irp.f @@ -21,8 +21,8 @@ subroutine give_2p_new(matrix_2p) double precision :: active_int(n_act_orb,n_act_orb,2) double precision :: hij,phase double precision :: accu_contrib(N_states) - integer :: degree(N_det_Ref) - integer :: idx(0:N_det_Ref) + integer :: degree(N_det) + integer :: idx(0:N_det) double precision :: delta_e(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inv(n_act_orb,n_act_orb,2,2,N_states) double precision :: delta_e_inactive_virt(N_states) diff --git a/plugins/Perturbation/NEEDED_CHILDREN_MODULES b/plugins/Perturbation/NEEDED_CHILDREN_MODULES index f7999340..25b89c5f 100644 --- a/plugins/Perturbation/NEEDED_CHILDREN_MODULES +++ b/plugins/Perturbation/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Determinants Properties Hartree_Fock Davidson +Determinants Properties Hartree_Fock Davidson MRPT_Utils diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index 5839c20c..b29e130f 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -46,6 +46,36 @@ subroutine pt2_epstein_nesbet ($arguments) end +subroutine pt2_decontracted ($arguments) + use bitmasks + implicit none + $declarations + + BEGIN_DOC + END_DOC + + integer :: i,j + double precision :: diag_H_mat_elem_fock, h + double precision :: i_H_psi_array(N_st) + double precision :: coef_pert + PROVIDE selection_criterion + + ASSERT (Nint == N_int) + ASSERT (Nint > 0) + !call i_H_psi(det_pert,psi_selectors,psi_selectors_coef,Nint,N_det_selectors,psi_selectors_size,N_st,i_H_psi_array) + call i_H_psi_pert_new_minilist(det_pert,minilist,idx_minilist,N_minilist,psi_selectors_coef,Nint,N_minilist,psi_selectors_size,N_st,i_H_psi_array,coef_pert) + H_pert_diag = 0.d0 + + + c_pert(1) = coef_pert + e_2_pert(1) = coef_pert * i_H_psi_array(1) +! print*,coef_pert,i_H_psi_array(1) + +end + + + + subroutine pt2_epstein_nesbet_2x2 ($arguments) use bitmasks implicit none diff --git a/plugins/MRPT_Utils/pt2_new.irp.f b/plugins/Perturbation/pt2_new.irp.f similarity index 100% rename from plugins/MRPT_Utils/pt2_new.irp.f rename to plugins/Perturbation/pt2_new.irp.f diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index 8380d668..87439764 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,27 +67,6 @@ END_PROVIDER END_PROVIDER - - BEGIN_PROVIDER [double precision, electronic_psi_ref_average_value, (N_states)] -&BEGIN_PROVIDER [double precision, psi_ref_average_value, (N_states)] - implicit none - integer :: i,j - electronic_psi_ref_average_value = psi_energy - do i = 1, N_states - psi_ref_average_value(i) = psi_energy(i) + nuclear_repulsion - enddo - double precision :: accu,hij - accu = 0.d0 - do i = 1, N_det_ref - do j = 1, N_det_ref - call i_H_j(psi_ref(1,1,i),psi_ref(1,1,j),N_int,hij) - accu += psi_ref_coef(i,1) * psi_ref_coef(j,1) * hij - enddo - enddo - electronic_psi_ref_average_value(1) = accu - psi_ref_average_value(1) = electronic_psi_ref_average_value(1) + nuclear_repulsion - -END_PROVIDER BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] &BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] implicit none diff --git a/plugins/SCF_density/.gitignore b/plugins/SCF_density/.gitignore deleted file mode 100644 index 9f1c0929..00000000 --- a/plugins/SCF_density/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -Huckel_guess -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -SCF -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/SCF_density/EZFIO.cfg b/plugins/SCF_density/EZFIO.cfg deleted file mode 100644 index 2fa29cf0..00000000 --- a/plugins/SCF_density/EZFIO.cfg +++ /dev/null @@ -1,35 +0,0 @@ -[thresh_scf] -type: Threshold -doc: Threshold on the convergence of the Hartree Fock energy -interface: ezfio,provider,ocaml -default: 1.e-10 - -[n_it_scf_max] -type: Strictly_positive_int -doc: Maximum number of SCF iterations -interface: ezfio,provider,ocaml -default: 200 - -[level_shift] -type: Positive_float -doc: Energy shift on the virtual MOs to improve SCF convergence -interface: ezfio,provider,ocaml -default: 0.5 - -[mo_guess_type] -type: MO_guess -doc: Initial MO guess. Can be [ Huckel | HCore ] -interface: ezfio,provider,ocaml -default: Huckel - -[energy] -type: double precision -doc: Calculated HF energy -interface: ezfio - -[no_oa_or_av_opt] -type: logical -doc: If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure -interface: ezfio,provider,ocaml -default: False - diff --git a/plugins/SCF_density/Fock_matrix.irp.f b/plugins/SCF_density/Fock_matrix.irp.f deleted file mode 100644 index af9255c8..00000000 --- a/plugins/SCF_density/Fock_matrix.irp.f +++ /dev/null @@ -1,437 +0,0 @@ - BEGIN_PROVIDER [ double precision, Fock_matrix_mo, (mo_tot_num_align,mo_tot_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_diag_mo, (mo_tot_num)] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis. - ! For open shells, the ROHF Fock Matrix is - ! - ! | F-K | F + K/2 | F | - ! |---------------------------------| - ! | F + K/2 | F | F - K/2 | - ! |---------------------------------| - ! | F | F - K/2 | F + K | - ! - ! F = 1/2 (Fa + Fb) - ! - ! K = Fb - Fa - ! - END_DOC - integer :: i,j,n - if (elec_alpha_num == elec_beta_num) then - Fock_matrix_mo = Fock_matrix_alpha_mo - else - - do j=1,elec_beta_num - ! F-K - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - enddo - - do j=elec_beta_num+1,elec_alpha_num - ! F+K/2 - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - + 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_alpha_num+1, mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - do j=elec_alpha_num+1, mo_tot_num - ! F - do i=1,elec_beta_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) - enddo - ! F-K/2 - do i=elec_beta_num+1,elec_alpha_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j))& - - 0.5d0*(Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - ! F+K - do i=elec_alpha_num+1,mo_tot_num - Fock_matrix_mo(i,j) = 0.5d0*(Fock_matrix_alpha_mo(i,j)+Fock_matrix_beta_mo(i,j)) & - + (Fock_matrix_beta_mo(i,j) - Fock_matrix_alpha_mo(i,j)) - enddo - enddo - - endif - - do i = 1, mo_tot_num - Fock_matrix_diag_mo(i) = Fock_matrix_mo(i,i) - enddo -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_ao, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, Fock_matrix_beta_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_alpha_ao(i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_alpha(i,j) - Fock_matrix_beta_ao (i,j) = ao_mono_elec_integral(i,j) + ao_bi_elec_integral_beta (i,j) - enddo - enddo - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_alpha, (ao_num_align, ao_num) ] -&BEGIN_PROVIDER [ double precision, ao_bi_elec_integral_beta , (ao_num_align, ao_num) ] - use map_module - implicit none - BEGIN_DOC - ! Alpha Fock matrix in AO basis set - END_DOC - - integer :: i,j,k,l,k1,r,s - integer :: i0,j0,k0,l0 - integer*8 :: p,q - double precision :: integral, c0, c1, c2 - double precision :: ao_bielec_integral, local_threshold - double precision, allocatable :: ao_bi_elec_integral_alpha_tmp(:,:) - double precision, allocatable :: ao_bi_elec_integral_beta_tmp(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_beta_tmp - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: ao_bi_elec_integral_alpha_tmp - - ao_bi_elec_integral_alpha = 0.d0 - ao_bi_elec_integral_beta = 0.d0 - if (do_direct_integrals) then - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,p,q,r,s,i0,j0,k0,l0, & - !$OMP ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp, c0, c1, c2, & - !$OMP local_threshold)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map,ao_integrals_threshold, ao_bielec_integral_schwartz, & - !$OMP ao_overlap_abs, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - allocate(keys(1), values(1)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - q = ao_num*ao_num*ao_num*ao_num - !$OMP DO SCHEDULE(dynamic) - do p=1_8,q - call bielec_integrals_index_reverse(kk,ii,ll,jj,p) - if ( (kk(1)>ao_num).or. & - (ii(1)>ao_num).or. & - (jj(1)>ao_num).or. & - (ll(1)>ao_num) ) then - cycle - endif - k = kk(1) - i = ii(1) - l = ll(1) - j = jj(1) - - if (ao_overlap_abs(k,l)*ao_overlap_abs(i,j) & - < ao_integrals_threshold) then - cycle - endif - local_threshold = ao_bielec_integral_schwartz(k,l)*ao_bielec_integral_schwartz(i,j) - if (local_threshold < ao_integrals_threshold) then - cycle - endif - i0 = i - j0 = j - k0 = k - l0 = l - values(1) = 0.d0 - local_threshold = ao_integrals_threshold/local_threshold - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - c0 = HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l) - c1 = HF_density_matrix_ao_alpha(k,i) - c2 = HF_density_matrix_ao_beta(k,i) - if ( dabs(c0)+dabs(c1)+dabs(c2) < local_threshold) then - cycle - endif - if (values(1) == 0.d0) then - values(1) = ao_bielec_integral(k0,l0,i0,j0) - endif - integral = c0 * values(1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(1) - ao_bi_elec_integral_alpha_tmp(l,j) -= c1 * integral - ao_bi_elec_integral_beta_tmp (l,j) -= c2 * integral - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - else - PROVIDE ao_bielec_integrals_in_map - - integer(omp_lock_kind) :: lck(ao_num) - integer*8 :: i8 - integer :: ii(8), jj(8), kk(8), ll(8), k2 - integer(cache_map_size_kind) :: n_elements_max, n_elements - integer(key_kind), allocatable :: keys(:) - double precision, allocatable :: values(:) - - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(i,j,l,k1,k,integral,ii,jj,kk,ll,i8,keys,values,n_elements_max, & - !$OMP n_elements,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp)& - !$OMP SHARED(ao_num,ao_num_align,HF_density_matrix_ao_alpha,HF_density_matrix_ao_beta,& - !$OMP ao_integrals_map, ao_bi_elec_integral_alpha, ao_bi_elec_integral_beta) - - call get_cache_map_n_elements_max(ao_integrals_map,n_elements_max) - allocate(keys(n_elements_max), values(n_elements_max)) - allocate(ao_bi_elec_integral_alpha_tmp(ao_num_align,ao_num), & - ao_bi_elec_integral_beta_tmp(ao_num_align,ao_num)) - ao_bi_elec_integral_alpha_tmp = 0.d0 - ao_bi_elec_integral_beta_tmp = 0.d0 - - !$OMP DO SCHEDULE(dynamic) - !DIR$ NOVECTOR - do i8=0_8,ao_integrals_map%map_size - n_elements = n_elements_max - call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) - do k1=1,n_elements - call bielec_integrals_index_reverse(kk,ii,ll,jj,keys(k1)) - - do k2=1,8 - if (kk(k2)==0) then - cycle - endif - i = ii(k2) - j = jj(k2) - k = kk(k2) - l = ll(k2) - integral = (HF_density_matrix_ao_alpha(k,l)+HF_density_matrix_ao_beta(k,l)) * values(k1) - ao_bi_elec_integral_alpha_tmp(i,j) += integral - ao_bi_elec_integral_beta_tmp (i,j) += integral - integral = values(k1) - ao_bi_elec_integral_alpha_tmp(l,j) -= HF_density_matrix_ao_alpha(k,i) * integral - ao_bi_elec_integral_beta_tmp (l,j) -= HF_density_matrix_ao_beta (k,i) * integral - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - ao_bi_elec_integral_alpha += ao_bi_elec_integral_alpha_tmp - !$OMP END CRITICAL - !$OMP CRITICAL - ao_bi_elec_integral_beta += ao_bi_elec_integral_beta_tmp - !$OMP END CRITICAL - deallocate(keys,values,ao_bi_elec_integral_alpha_tmp,ao_bi_elec_integral_beta_tmp) - !$OMP END PARALLEL - - endif - -END_PROVIDER - - - - - - -BEGIN_PROVIDER [ double precision, Fock_matrix_alpha_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_alpha_ao,size(Fock_matrix_alpha_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_alpha_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_beta_mo, (mo_tot_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Fock matrix on the MO basis - END_DOC - double precision, allocatable :: T(:,:) - allocate ( T(ao_num_align,mo_tot_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, Fock_matrix_beta_ao,size(Fock_matrix_beta_ao,1), & - mo_coef, size(mo_coef,1), & - 0.d0, T, ao_num_align) - call dgemm('T','N', mo_tot_num, mo_tot_num, ao_num, & - 1.d0, mo_coef,size(mo_coef,1), & - T, size(T,1), & - 0.d0, Fock_matrix_beta_mo, mo_tot_num_align) - deallocate(T) -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_energy ] - implicit none - BEGIN_DOC - ! Hartree-Fock energy - END_DOC - HF_energy = nuclear_repulsion - - integer :: i,j - do j=1,ao_num - do i=1,ao_num - HF_energy += 0.5d0 * ( & - (ao_mono_elec_integral(i,j) + Fock_matrix_alpha_ao(i,j) ) * HF_density_matrix_ao_alpha(i,j) +& - (ao_mono_elec_integral(i,j) + Fock_matrix_beta_ao (i,j) ) * HF_density_matrix_ao_beta (i,j) ) - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [ double precision, Fock_matrix_ao, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Fock matrix in AO basis set - END_DOC - - if ( (elec_alpha_num == elec_beta_num).and. & - (level_shift == 0.) ) & - then - integer :: i,j - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num_align - Fock_matrix_ao(i,j) = Fock_matrix_alpha_ao(i,j) - enddo - enddo - else - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . Fock_matrix_mo (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - Fock_matrix_mo, size(Fock_matrix_mo,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - Fock_matrix_ao, size(Fock_matrix_ao,1)) - - - deallocate(T) - endif -END_PROVIDER - -subroutine Fock_mo_to_ao(FMO,LDFMO,FAO,LDFAO) - implicit none - integer, intent(in) :: LDFMO ! size(FMO,1) - integer, intent(in) :: LDFAO ! size(FAO,1) - double precision, intent(in) :: FMO(LDFMO,*) - double precision, intent(out) :: FAO(LDFAO,*) - - double precision, allocatable :: T(:,:), M(:,:) - integer :: ierr - ! F_ao = S C F_mo C^t S - allocate (T(ao_num_align,ao_num),M(ao_num_align,ao_num),stat=ierr) - if (ierr /=0 ) then - print *, irp_here, ' : allocation failed' - endif - -! ao_overlap (ao_num,ao_num) . mo_coef (ao_num,mo_tot_num) -! -> M(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,ao_num, 1.d0, & - ao_overlap, size(ao_overlap,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,mo_tot_num) . FMO (mo_tot_num,mo_tot_num) -! -> T(ao_num,mo_tot_num) - call dgemm('N','N', ao_num,mo_tot_num,mo_tot_num, 1.d0, & - M, size(M,1), & - FMO, size(FMO,1), & - 0.d0, & - T, size(T,1)) - -! T(ao_num,mo_tot_num) . mo_coef^T (mo_tot_num,ao_num) -! -> M(ao_num,ao_num) - call dgemm('N','T', ao_num,ao_num,mo_tot_num, 1.d0, & - T, size(T,1), & - mo_coef, size(mo_coef,1), & - 0.d0, & - M, size(M,1)) - -! M(ao_num,ao_num) . ao_overlap (ao_num,ao_num) -! -> Fock_matrix_ao(ao_num,ao_num) - call dgemm('N','N', ao_num,ao_num,ao_num, 1.d0, & - M, size(M,1), & - ao_overlap, size(ao_overlap,1), & - 0.d0, & - FAO, size(FAO,1)) - deallocate(T,M) -end - diff --git a/plugins/SCF_density/HF_density_matrix_ao.irp.f b/plugins/SCF_density/HF_density_matrix_ao.irp.f deleted file mode 100644 index a9d601c7..00000000 --- a/plugins/SCF_density/HF_density_matrix_ao.irp.f +++ /dev/null @@ -1,66 +0,0 @@ -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_alpha, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 x Alpha density matrix in the AO basis x S^-1 - END_DOC - -! call dgemm('N','T',ao_num,ao_num,elec_alpha_num,1.d0, & -! mo_coef, size(mo_coef,1), & -! mo_coef, size(mo_coef,1), 0.d0, & -! HF_density_matrix_ao_alpha, size(HF_density_matrix_ao_alpha,1)) - integer :: i,j,k,l - double precision :: test_alpha - HF_density_matrix_ao_alpha = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - if(dabs(mo_general_density_alpha(i,j)).le.1.d-10)cycle - do k = 1, ao_num - do l = 1, ao_num - HF_density_matrix_ao_alpha(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_alpha(i,j) - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao_beta, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Beta density matrix in the AO basis x S^-1 - END_DOC - -! call dgemm('N','T',ao_num,ao_num,elec_beta_num,1.d0, & -! mo_coef, size(mo_coef,1), & -! mo_coef, size(mo_coef,1), 0.d0, & -! HF_density_matrix_ao_beta, size(HF_density_matrix_ao_beta,1)) - integer :: i,j,k,l - double precision :: test_beta - HF_density_matrix_ao_beta = 0.d0 - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do k = 1, ao_num - do l = 1, ao_num - HF_density_matrix_ao_beta(k,l) += mo_coef(k,i) * mo_coef(l,j) * mo_general_density_beta(i,j) - enddo - enddo - enddo - enddo - -END_PROVIDER - -BEGIN_PROVIDER [ double precision, HF_density_matrix_ao, (ao_num_align,ao_num) ] - implicit none - BEGIN_DOC - ! S^-1 Density matrix in the AO basis S^-1 - END_DOC - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_alpha,1)) - if (elec_alpha_num== elec_beta_num) then - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_alpha - else - ASSERT (size(HF_density_matrix_ao,1) == size(HF_density_matrix_ao_beta ,1)) - HF_density_matrix_ao = HF_density_matrix_ao_alpha + HF_density_matrix_ao_beta - endif - -END_PROVIDER - diff --git a/plugins/SCF_density/NEEDED_CHILDREN_MODULES b/plugins/SCF_density/NEEDED_CHILDREN_MODULES deleted file mode 100644 index a52d6e8e..00000000 --- a/plugins/SCF_density/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Bielec MOGuess Bitmask diff --git a/plugins/SCF_density/README.rst b/plugins/SCF_density/README.rst deleted file mode 100644 index 0699bf28..00000000 --- a/plugins/SCF_density/README.rst +++ /dev/null @@ -1,175 +0,0 @@ -=================== -SCF_density Module -=================== - -From the 140 molecules of the G2 set, only LiO, ONa don't converge well. - -Needed Modules -============== - -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Integrals_Bielec `_ -* `MOGuess `_ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -.. image:: tree_dependency.png - -* `Integrals_Bielec `_ -* `MOGuess `_ -* `Bitmask `_ - -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. - - -`ao_bi_elec_integral_alpha `_ - Alpha Fock matrix in AO basis set - - -`ao_bi_elec_integral_beta `_ - Alpha Fock matrix in AO basis set - - -`create_guess `_ - Create an MO guess if no MOs are present in the EZFIO directory - - -`damping_scf `_ - Undocumented - - -`diagonal_fock_matrix_mo `_ - Diagonal Fock matrix in the MO basis - - -`diagonal_fock_matrix_mo_sum `_ - diagonal element of the fock matrix calculated as the sum over all the interactions - with all the electrons in the RHF determinant - diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - - -`eigenvectors_fock_matrix_mo `_ - Diagonal Fock matrix in the MO basis - - -`fock_matrix_alpha_ao `_ - Alpha Fock matrix in AO basis set - - -`fock_matrix_alpha_mo `_ - Fock matrix on the MO basis - - -`fock_matrix_ao `_ - Fock matrix in AO basis set - - -`fock_matrix_beta_ao `_ - Alpha Fock matrix in AO basis set - - -`fock_matrix_beta_mo `_ - Fock matrix on the MO basis - - -`fock_matrix_diag_mo `_ - Fock matrix on the MO basis. - For open shells, the ROHF Fock Matrix is - .br - | F-K | F + K/2 | F | - |---------------------------------| - | F + K/2 | F | F - K/2 | - |---------------------------------| - | F | F - K/2 | F + K | - .br - F = 1/2 (Fa + Fb) - .br - K = Fb - Fa - .br - - -`fock_matrix_mo `_ - Fock matrix on the MO basis. - For open shells, the ROHF Fock Matrix is - .br - | F-K | F + K/2 | F | - |---------------------------------| - | F + K/2 | F | F - K/2 | - |---------------------------------| - | F | F - K/2 | F + K | - .br - F = 1/2 (Fa + Fb) - .br - K = Fb - Fa - .br - - -`fock_mo_to_ao `_ - Undocumented - - -`guess `_ - Undocumented - - -`hf_density_matrix_ao `_ - S^-1 Density matrix in the AO basis S^-1 - - -`hf_density_matrix_ao_alpha `_ - S^-1 x Alpha density matrix in the AO basis x S^-1 - - -`hf_density_matrix_ao_beta `_ - S^-1 Beta density matrix in the AO basis x S^-1 - - -`hf_energy `_ - Hartree-Fock energy - - -`huckel_guess `_ - Build the MOs using the extended Huckel model - - -`level_shift `_ - Energy shift on the virtual MOs to improve SCF convergence - - -`mo_guess_type `_ - Initial MO guess. Can be [ Huckel | HCore ] - - -`n_it_scf_max `_ - Maximum number of SCF iterations - - -`no_oa_or_av_opt `_ - If true, skip the (inactive+core) --> (active) and the (active) --> (virtual) orbital rotations within the SCF procedure - - -`run `_ - Run SCF calculation - - -`scf `_ - Produce `Hartree_Fock` MO orbital - output: mo_basis.mo_tot_num mo_basis.mo_label mo_basis.ao_md5 mo_basis.mo_coef mo_basis.mo_occ - output: hartree_fock.energy - optional: mo_basis.mo_coef - - -`thresh_scf `_ - Threshold on the convergence of the Hartree Fock energy - diff --git a/plugins/SCF_density/damping_SCF.irp.f b/plugins/SCF_density/damping_SCF.irp.f deleted file mode 100644 index aa6f02b0..00000000 --- a/plugins/SCF_density/damping_SCF.irp.f +++ /dev/null @@ -1,132 +0,0 @@ -subroutine damping_SCF - implicit none - double precision :: E - double precision, allocatable :: D_alpha(:,:), D_beta(:,:) - double precision :: E_new - double precision, allocatable :: D_new_alpha(:,:), D_new_beta(:,:), F_new(:,:) - double precision, allocatable :: delta_alpha(:,:), delta_beta(:,:) - double precision :: lambda, E_half, a, b, delta_D, delta_E, E_min - - integer :: i,j,k - logical :: saving - character :: save_char - - allocate( & - D_alpha( ao_num_align, ao_num ), & - D_beta( ao_num_align, ao_num ), & - F_new( ao_num_align, ao_num ), & - D_new_alpha( ao_num_align, ao_num ), & - D_new_beta( ao_num_align, ao_num ), & - delta_alpha( ao_num_align, ao_num ), & - delta_beta( ao_num_align, ao_num )) - - do j=1,ao_num - do i=1,ao_num - D_alpha(i,j) = HF_density_matrix_ao_alpha(i,j) - D_beta (i,j) = HF_density_matrix_ao_beta (i,j) - enddo - enddo - - - call write_time(output_hartree_fock) - - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - ' N ', 'Energy ', 'Energy diff ', 'Density diff ', 'Save' - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') & - '====','================','================','================', '====' - - E = HF_energy + 1.d0 - E_min = HF_energy - delta_D = 0.d0 - do k=1,n_it_scf_max - - delta_E = HF_energy - E - E = HF_energy - - if ( (delta_E < 0.d0).and.(dabs(delta_E) < thresh_scf) ) then - exit - endif - - saving = E < E_min - if (saving) then - call save_mos - save_char = 'X' - E_min = E - else - save_char = ' ' - endif - - write(output_hartree_fock,'(I4,1X,F16.10, 1X, F16.10, 1X, F16.10, 3X, A )') & - k, E, delta_E, delta_D, save_char - - D_alpha = HF_density_matrix_ao_alpha - D_beta = HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - D_new_alpha = HF_density_matrix_ao_alpha - D_new_beta = HF_density_matrix_ao_beta - F_new = Fock_matrix_ao - E_new = HF_energy - - delta_alpha = D_new_alpha - D_alpha - delta_beta = D_new_beta - D_beta - - lambda = .5d0 - E_half = 0.d0 - do while (E_half > E) - HF_density_matrix_ao_alpha = D_alpha + lambda * delta_alpha - HF_density_matrix_ao_beta = D_beta + lambda * delta_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - E_half = HF_energy - if ((E_half > E).and.(E_new < E)) then - lambda = 1.d0 - exit - else if ((E_half > E).and.(lambda > 5.d-4)) then - lambda = 0.5d0 * lambda - E_new = E_half - else - exit - endif - enddo - - a = (E_new + E - 2.d0*E_half)*2.d0 - b = -E_new - 3.d0*E + 4.d0*E_half - lambda = -lambda*b/(a+1.d-16) - D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha - D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta - delta_E = HF_energy - E - do j=1,ao_num - do i=1,ao_num - delta_D = delta_D + & - (D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j))*(D_alpha(i,j) - HF_density_matrix_ao_alpha(i,j)) + & - (D_beta (i,j) - HF_density_matrix_ao_beta (i,j))*(D_beta (i,j) - HF_density_matrix_ao_beta (i,j)) - enddo - enddo - delta_D = dsqrt(delta_D/dble(ao_num)**2) - HF_density_matrix_ao_alpha = D_alpha - HF_density_matrix_ao_beta = D_beta - TOUCH HF_density_matrix_ao_alpha HF_density_matrix_ao_beta - mo_coef = eigenvectors_fock_matrix_mo - TOUCH mo_coef - - - enddo - write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' - write(output_hartree_fock,*) - - if(.not.no_oa_or_av_opt)then - call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) - endif - - call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') - call ezfio_set_hartree_fock_energy(E_min) - - call write_time(output_hartree_fock) - - deallocate(D_alpha,D_beta,F_new,D_new_alpha,D_new_beta,delta_alpha,delta_beta) -end diff --git a/plugins/SCF_density/diagonalize_fock.irp.f b/plugins/SCF_density/diagonalize_fock.irp.f deleted file mode 100644 index 2983abeb..00000000 --- a/plugins/SCF_density/diagonalize_fock.irp.f +++ /dev/null @@ -1,124 +0,0 @@ - BEGIN_PROVIDER [ double precision, diagonal_Fock_matrix_mo, (ao_num) ] -&BEGIN_PROVIDER [ double precision, eigenvectors_Fock_matrix_mo, (ao_num_align,mo_tot_num) ] - implicit none - BEGIN_DOC - ! Diagonal Fock matrix in the MO basis - END_DOC - - integer :: i,j - integer :: liwork, lwork, n, info - integer, allocatable :: iwork(:) - double precision, allocatable :: work(:), F(:,:), S(:,:) - - - allocate( F(mo_tot_num_align,mo_tot_num) ) - do j=1,mo_tot_num - do i=1,mo_tot_num - F(i,j) = Fock_matrix_mo(i,j) - enddo - enddo -! print*, no_oa_or_av_opt - if(no_oa_or_av_opt)then - integer :: iorb,jorb - do i = 1, n_act_orb - iorb = list_act(i) - do j = 1, n_inact_orb - jorb = list_inact(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_virt_orb - jorb = list_virt(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - do j = 1, n_core_orb - jorb = list_core(j) - F(iorb,jorb) = 0.d0 - F(jorb,iorb) = 0.d0 - enddo - enddo -! do i = 1, n_act_orb -! iorb = list_act(i) -! write(*,'(100(F16.10,X))')F(iorb,:) -! enddo - endif - - - - - ! Insert level shift here - do i = elec_beta_num+1, elec_alpha_num - F(i,i) += 0.5d0*level_shift - enddo - - do i = elec_alpha_num+1, mo_tot_num - F(i,i) += level_shift - enddo - - n = mo_tot_num - lwork = 1+6*n + 2*n*n - liwork = 3 + 5*n - - allocate(work(lwork), iwork(liwork) ) - - lwork = -1 - liwork = -1 - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - lwork = int(work(1)) - liwork = iwork(1) - deallocate(work,iwork) - allocate(work(lwork), iwork(liwork) ) - - call dsyevd( 'V', 'U', mo_tot_num, F, & - size(F,1), diagonal_Fock_matrix_mo, & - work, lwork, iwork, liwork, info) - - if (info /= 0) then - print *, irp_here//' failed : ', info - stop 1 - endif - - call dgemm('N','N',ao_num,mo_tot_num,mo_tot_num, 1.d0, & - mo_coef, size(mo_coef,1), F, size(F,1), & - 0.d0, eigenvectors_Fock_matrix_mo, size(eigenvectors_Fock_matrix_mo,1)) - deallocate(work, iwork, F) - - -! endif - -END_PROVIDER - -BEGIN_PROVIDER [double precision, diagonal_Fock_matrix_mo_sum, (mo_tot_num)] - implicit none - BEGIN_DOC - ! diagonal element of the fock matrix calculated as the sum over all the interactions - ! with all the electrons in the RHF determinant - ! diagonal_Fock_matrix_mo_sum(i) = sum_{j=1, N_elec} 2 J_ij -K_ij - END_DOC - integer :: i,j - double precision :: accu - do j = 1,elec_alpha_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - do j = elec_alpha_num+1,mo_tot_num - accu = 0.d0 - do i = 1, elec_alpha_num - accu += 2.d0 * mo_bielec_integral_jj_from_ao(i,j) - mo_bielec_integral_jj_exchange_from_ao(i,j) - enddo - diagonal_Fock_matrix_mo_sum(j) = accu + mo_mono_elec_integral(j,j) - enddo - -END_PROVIDER diff --git a/plugins/SCF_density/huckel.irp.f b/plugins/SCF_density/huckel.irp.f deleted file mode 100644 index 103de83a..00000000 --- a/plugins/SCF_density/huckel.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -subroutine huckel_guess - implicit none - BEGIN_DOC -! Build the MOs using the extended Huckel model - END_DOC - integer :: i,j - double precision :: accu - double precision :: c - character*(64) :: label - - label = "Guess" - call mo_as_eigvectors_of_mo_matrix(mo_mono_elec_integral, & - size(mo_mono_elec_integral,1), & - size(mo_mono_elec_integral,2),label,1) - TOUCH mo_coef - - c = 0.5d0 * 1.75d0 - - do j=1,ao_num - !DIR$ VECTOR ALIGNED - do i=1,ao_num - Fock_matrix_ao(i,j) = c*ao_overlap(i,j)*(ao_mono_elec_integral_diag(i) + & - ao_mono_elec_integral_diag(j)) - enddo - Fock_matrix_ao(j,j) = Fock_matrix_alpha_ao(j,j) - enddo - TOUCH Fock_matrix_ao - mo_coef = eigenvectors_fock_matrix_mo - SOFT_TOUCH mo_coef - call save_mos - -end diff --git a/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES b/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 994f4bf6..00000000 --- a/plugins/Slater_rules_DFT/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants Integrals_restart_DFT Davidson diff --git a/plugins/Slater_rules_DFT/README.rst b/plugins/Slater_rules_DFT/README.rst deleted file mode 100644 index f492095e..00000000 --- a/plugins/Slater_rules_DFT/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -================ -Slater_rules_DFT -================ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f b/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f deleted file mode 100644 index 3d99e376..00000000 --- a/plugins/Slater_rules_DFT/Slater_rules_DFT.main.irp.f +++ /dev/null @@ -1,38 +0,0 @@ -program Slater_rules_DFT - implicit none - BEGIN_DOC -! TODO - END_DOC - print *, ' _/ ' - print *, ' -:\_?, _Jm####La ' - print *, 'J"(:" > _]#AZ#Z#UUZ##, ' - print *, '_,::./ %(|i%12XmX1*1XL _?, ' - print *, ' \..\ _\(vmWQwodY+ia%lnL _",/ ( ' - print *, ' .:< ]J=mQD?WXn|,)nr" ' - print *, ' 4XZ#Xov1v}=)vnXAX1nnv;1n" ' - print *, ' ]XX#ZXoovvvivnnnlvvo2*i7 ' - print *, ' "23Z#1S2oo2XXSnnnoSo2>v" ' - print *, ' miX#L -~`""!!1}oSoe|i7 ' - print *, ' 4cn#m, v221=|v[ ' - print *, ' ]hI3Zma,;..__wXSe=+vo ' - print *, ' ]Zov*XSUXXZXZXSe||vo2 ' - print *, ' ]Z#>=|< ' - print *, ' -ziiiii||||||+||==+> ' - print *, ' -%|+++||=|=+|=|==/ ' - print *, ' -a>====+|====-:- ' - print *, ' "~,- -- /- ' - print *, ' -. )> ' - print *, ' .~ +- ' - print *, ' . .... : . ' - print *, ' -------~ ' - print *, '' -end diff --git a/plugins/Slater_rules_DFT/energy.irp.f b/plugins/Slater_rules_DFT/energy.irp.f deleted file mode 100644 index 7734d73e..00000000 --- a/plugins/Slater_rules_DFT/energy.irp.f +++ /dev/null @@ -1,7 +0,0 @@ -! BEGIN_PROVIDER [double precision, energy_total] -!&BEGIN_PROVIDER [double precision, energy_one_electron] -!&BEGIN_PROVIDER [double precision, energy_hartree] -!&BEGIN_PROVIDER [double precision, energy] -! implicit none -! -!END_PROVIDER diff --git a/plugins/Slater_rules_DFT/slater_rules_erf.irp.f b/plugins/Slater_rules_DFT/slater_rules_erf.irp.f deleted file mode 100644 index 64d5d217..00000000 --- a/plugins/Slater_rules_DFT/slater_rules_erf.irp.f +++ /dev/null @@ -1,445 +0,0 @@ - -subroutine i_H_j_erf(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) - hij = hij * phase - case (0) - hij = diag_H_mat_elem_erf(key_i,Nint) - end select -end - -double precision function diag_H_mat_elem_erf(key_i,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - diag_H_mat_elem_erf = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) - do j = i+1, n_occ_ab(1) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) - do j = i+1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - diag_H_mat_elem_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - -end - - - -subroutine i_H_j_erf_and_short_coulomb(key_i,key_j,Nint,hij) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij = 0.d0 - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij = hij + mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) + effective_short_range_operator(m,p) - hij = hij * phase - case (0) - hij = diag_H_mat_elem_erf(key_i,Nint) - end select -end - -double precision function diag_H_mat_elem_erf_and_short_coulomb(key_i,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - diag_H_mat_elem_erf_and_short_coulomb = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) & - + effective_short_range_operator(occ(i,1),occ(i,1)) - do j = i+1, n_occ_ab(1) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) & - + effective_short_range_operator(occ(i,2),occ(i,2)) - do j = i+1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - diag_H_mat_elem_erf_and_short_coulomb += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - -end - - -subroutine i_H_j_erf_component(key_i,key_j,Nint,hij_core,hij_hartree,hij_erf,hij_total) - use bitmasks - implicit none - BEGIN_DOC - ! Returns where i and j are determinants - END_DOC - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: key_i(Nint,2), key_j(Nint,2) - double precision, intent(out) :: hij_core - double precision, intent(out) :: hij_hartree - double precision, intent(out) :: hij_erf - double precision, intent(out) :: hij_total - - integer :: exc(0:2,2,2) - integer :: degree - double precision :: get_mo_bielec_integral_erf - integer :: m,n,p,q - integer :: i,j,k - integer :: occ(Nint*bit_kind_size,2) - double precision :: diag_H_mat_elem_erf, phase,phase_2 - integer :: n_occ_ab(2) - PROVIDE mo_bielec_integrals_erf_in_map mo_integrals_erf_map big_array_exchange_integrals_erf - - ASSERT (Nint > 0) - ASSERT (Nint == N_int) - ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num) - ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num) - ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num) - - hij_core = 0.d0 - hij_hartree = 0.d0 - hij_erf = 0.d0 - - !DIR$ FORCEINLINE - call get_excitation_degree(key_i,key_j,degree,Nint) - integer :: spin - select case (degree) - case (2) - call get_double_excitation(key_i,key_j,exc,phase,Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha, mono beta - if(exc(1,1,1) == exc(1,2,2) )then - hij_erf = phase * big_array_exchange_integrals(exc(1,1,1),exc(1,1,2),exc(1,2,1)) - else if (exc(1,2,1) ==exc(1,1,2))then - hij_erf = phase * big_array_exchange_integrals(exc(1,2,1),exc(1,1,1),exc(1,2,2)) - else - hij_erf = phase*get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(1,1,2), & - exc(1,2,1), & - exc(1,2,2) ,mo_integrals_erf_map) - endif - else if (exc(0,1,1) == 2) then - ! Double alpha - hij_erf = phase*(get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(1,2,1), & - exc(2,2,1) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,1), & - exc(2,1,1), & - exc(2,2,1), & - exc(1,2,1) ,mo_integrals_erf_map) ) - else if (exc(0,1,2) == 2) then - ! Double beta - hij_erf = phase*(get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(1,2,2), & - exc(2,2,2) ,mo_integrals_erf_map) - & - get_mo_bielec_integral_erf( & - exc(1,1,2), & - exc(2,1,2), & - exc(2,2,2), & - exc(1,2,2) ,mo_integrals_erf_map) ) - endif - case (1) - call get_mono_excitation(key_i,key_j,exc,phase,Nint) - !DIR$ FORCEINLINE - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - if (exc(0,1,1) == 1) then - ! Mono alpha - m = exc(1,1,1) - p = exc(1,2,1) - spin = 1 - do i = 1, n_occ_ab(1) - hij_erf += -big_array_exchange_integrals_erf(occ(i,1),m,p) + big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - do i = 1, n_occ_ab(2) - hij_erf += big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - else - ! Mono beta - m = exc(1,1,2) - p = exc(1,2,2) - spin = 2 - do i = 1, n_occ_ab(2) - hij_erf += -big_array_exchange_integrals_erf(occ(i,2),m,p) + big_array_coulomb_integrals_erf(occ(i,2),m,p) - enddo - do i = 1, n_occ_ab(1) - hij_erf += big_array_coulomb_integrals_erf(occ(i,1),m,p) - enddo - endif - hij_core = mo_nucl_elec_integral(m,p) + mo_kinetic_integral(m,p) - hij_hartree = effective_short_range_operator(m,p) - hij_total = (hij_erf + hij_core + hij_hartree) * phase - case (0) - call diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) - end select -end - -subroutine diag_H_mat_elem_erf_component(key_i,hij_core,hij_hartree,hij_erf,hij_total,Nint) - implicit none - integer(bit_kind), intent(in) :: key_i(N_int,2) - integer, intent(in) :: Nint - double precision, intent(out) :: hij_core - double precision, intent(out) :: hij_hartree - double precision, intent(out) :: hij_erf - double precision, intent(out) :: hij_total - integer :: i,j - integer :: occ(Nint*bit_kind_size,2) - integer :: n_occ_ab(2) - - call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint) - hij_core = 0.d0 - hij_hartree = 0.d0 - hij_erf = 0.d0 - ! alpha - alpha - do i = 1, n_occ_ab(1) - hij_core += mo_nucl_elec_integral(occ(i,1),mo_nucl_elec_integral(i,1)) + mo_kinetic_integral(occ(i,1),mo_nucl_elec_integral(i,1)) - hij_hartree += effective_short_range_operator(occ(i,1),occ(i,1)) - do j = i+1, n_occ_ab(1) - hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,1),occ(j,1)) - enddo - enddo - - ! beta - beta - do i = 1, n_occ_ab(2) - hij_core += mo_nucl_elec_integral(occ(i,2),mo_nucl_elec_integral(i,2)) + mo_kinetic_integral(occ(i,2),mo_nucl_elec_integral(i,2)) - hij_hartree += effective_short_range_operator(occ(i,2),occ(i,2)) - do j = i+1, n_occ_ab(2) - hij_erf += mo_bielec_integral_erf_jj_anti(occ(i,2),occ(j,2)) - enddo - enddo - - ! alpha - beta - do i = 1, n_occ_ab(1) - do j = 1, n_occ_ab(2) - hij_erf += mo_bielec_integral_erf_jj(occ(i,1),occ(j,2)) - enddo - enddo - hij_total = hij_erf + hij_hartree + hij_core - -end - - diff --git a/plugins/core_integrals/.gitignore b/plugins/core_integrals/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/core_integrals/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/core_integrals/NEEDED_CHILDREN_MODULES b/plugins/core_integrals/NEEDED_CHILDREN_MODULES deleted file mode 100644 index 6a4d0040..00000000 --- a/plugins/core_integrals/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Integrals_Monoelec Integrals_Bielec Bitmask diff --git a/plugins/core_integrals/README.rst b/plugins/core_integrals/README.rst deleted file mode 100644 index 589e0a00..00000000 --- a/plugins/core_integrals/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -============== -core_integrals -============== - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/core_integrals/core_integrals.main.irp.f b/plugins/core_integrals/core_integrals.main.irp.f deleted file mode 100644 index f5e9fd1b..00000000 --- a/plugins/core_integrals/core_integrals.main.irp.f +++ /dev/null @@ -1,7 +0,0 @@ -program core_integrals - implicit none - BEGIN_DOC -! TODO - END_DOC - print*,'core energy = ',core_energy -end diff --git a/plugins/core_integrals/core_quantities.irp.f b/plugins/core_integrals/core_quantities.irp.f deleted file mode 100644 index ac547d2f..00000000 --- a/plugins/core_integrals/core_quantities.irp.f +++ /dev/null @@ -1,32 +0,0 @@ -BEGIN_PROVIDER [double precision, core_energy] - implicit none - integer :: i,j,k,l - core_energy = 0.d0 - do i = 1, n_core_orb - j = list_core(i) - core_energy += 2.d0 * mo_mono_elec_integral(j,j) + mo_bielec_integral_jj(j,j) - do k = i+1, n_core_orb - l = list_core(k) - core_energy += 2.d0 * (2.d0 * mo_bielec_integral_jj(j,l) - mo_bielec_integral_jj_exchange(j,l)) - enddo - enddo - core_energy += nuclear_repulsion - -END_PROVIDER - -BEGIN_PROVIDER [double precision, core_fock_operator, (mo_tot_num,mo_tot_num)] - implicit none - integer :: i,j,k,l,m,n - double precision :: get_mo_bielec_integral - core_fock_operator = 0.d0 - do i = 1, n_act_orb - j = list_act(i) - do k = 1, n_act_orb - l = list_act(k) - do m = 1, n_core_orb - n = list_core(m) - core_fock_operator(j,l) += 2.d0 * get_mo_bielec_integral(j,n,l,n,mo_integrals_map) - get_mo_bielec_integral(j,n,n,l,mo_integrals_map) - enddo - enddo - enddo -END_PROVIDER diff --git a/plugins/loc_cele/loc.f b/plugins/loc_cele/loc.f index ed8b9a76..edc3aa7a 100644 --- a/plugins/loc_cele/loc.f +++ b/plugins/loc_cele/loc.f @@ -18,7 +18,7 @@ C zprt=.true. niter=1000000 - conv=1.d-10 + conv=1.d-8 C niter=1000000 C conv=1.d-6 diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index 67e74f08..2d47c633 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -101,29 +101,10 @@ cmoref = 0.d0 irot = 0 - irot(1,1) = 14 - irot(2,1) = 15 -! cmoref(6,1,1) = 1.d0 -! cmoref(26,2,1) = 1.d0 - cmoref(36,1,1) = 1.d0 - cmoref(56,2,1) = 1.d0 - -! !!! H2O -! irot(1,1) = 4 -! irot(2,1) = 5 -! irot(3,1) = 6 -! irot(4,1) = 7 -! ! O pz -! cmoref(5,1,1) = 1.55362d0 -! cmoref(6,1,1) = 1.07578d0 - -! cmoref(5,2,1) = 1.55362d0 -! cmoref(6,2,1) = -1.07578d0 -! ! O px - pz -! ! H1 -! cmoref(16,3,1) = 1.d0 -! ! H1 -! cmoref(21,4,1) = 1.d0 + irot(1,1) = 11 + irot(2,1) = 12 + cmoref(15,1,1) = 1.d0 ! + cmoref(14,2,1) = 1.d0 ! ! ESATRIENE with 3 bonding and anti bonding orbitals ! First bonding orbital for esa @@ -169,19 +150,19 @@ ! ESATRIENE with 1 central bonding and anti bonding orbitals ! AND 4 radical orbitals ! First radical orbital -! cmoref(7,1,1) = 1.d0 ! + cmoref(7,1,1) = 1.d0 ! ! Second radical orbital -! cmoref(26,2,1) = 1.d0 ! + cmoref(26,2,1) = 1.d0 ! ! First bonding orbital -! cmoref(45,3,1) = 1.d0 ! -! cmoref(64,3,1) = 1.d0 ! + cmoref(45,3,1) = 1.d0 ! + cmoref(64,3,1) = 1.d0 ! ! Third radical orbital for esa -! cmoref(83,4,1) = 1.d0 ! + cmoref(83,4,1) = 1.d0 ! ! Fourth radical orbital for esa -! cmoref(102,5,1) = 1.d0 ! + cmoref(102,5,1) = 1.d0 ! ! First anti bonding orbital -! cmoref(45,6,1) = 1.d0 ! -! cmoref(64,6,1) =-1.d0 ! + cmoref(45,6,1) = 1.d0 ! + cmoref(64,6,1) =-1.d0 ! do i = 1, nrot(1) diff --git a/plugins/loc_cele/loc_exchange_int.irp.f b/plugins/loc_cele/loc_exchange_int.irp.f index eabdf35c..8bb47d89 100644 --- a/plugins/loc_cele/loc_exchange_int.irp.f +++ b/plugins/loc_cele/loc_exchange_int.irp.f @@ -18,17 +18,16 @@ program loc_int do j = i+1, n_core_inact_orb jorb = list_core_inact(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -51,17 +50,16 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' @@ -84,17 +82,16 @@ program loc_int do j = i+1, n_virt_orb jorb = list_virt(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/loc_cele/loc_exchange_int_act.irp.f b/plugins/loc_cele/loc_exchange_int_act.irp.f index c4dcf75c..f332dd5d 100644 --- a/plugins/loc_cele/loc_exchange_int_act.irp.f +++ b/plugins/loc_cele/loc_exchange_int_act.irp.f @@ -19,17 +19,16 @@ program loc_int do j = i+1, n_act_orb jorb = list_act(j) iorder(jorb) = jorb - if(list_core_inact_check(jorb) == .False.)then - exchange_int(jorb) = 0.d0 - else - exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) - endif + exchange_int(jorb) = -mo_bielec_integral_jj_exchange(iorb,jorb) enddo n_rot += 1 call dsort(exchange_int,iorder,mo_tot_num) indices(n_rot,1) = iorb indices(n_rot,2) = iorder(1) list_core_inact_check(iorder(1)) = .False. + print*,indices(n_rot,1),indices(n_rot,2) + print*,'' + print*,'' enddo print*,'****************************' print*,'-+++++++++++++++++++++++++' diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/mrcepa0/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES index fe8255d1..8b6c5a18 100644 --- a/plugins/mrcepa0/NEEDED_CHILDREN_MODULES +++ b/plugins/mrcepa0/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ +Perturbation Selectors_full Generators_full Psiref_CAS MRCC_Utils ZMQ diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index d2311676..2820750f 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -684,7 +684,7 @@ subroutine getHP(a,h,p,Nint) end do lh h = deg !isInCassd = .true. -end subroutine +end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] @@ -709,9 +709,6 @@ end subroutine integer :: II, blok integer*8, save :: notf = 0 - - PROVIDE psi_ref_coef psi_non_ref_coef - call wall_time(wall) allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) @@ -835,7 +832,8 @@ END_PROVIDER delta_sub_ij(:,:,:) = 0d0 delta_sub_ii(:,:) = 0d0 - provide mo_bielec_integrals_in_map N_det_non_ref psi_ref_coef psi_non_ref_coef + provide mo_bielec_integrals_in_map + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index 780a7a91..b495019a 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -476,7 +476,7 @@ def ninja_irpf90_make_build(path_module, l_needed_molule, d_irp): # ~#~#~#~#~#~ # l_creation = [join(path_module.abs, i) - for i in ["irpf90_entities", "tags", + for i in ["irpf90.make", "irpf90_entities", "tags", "IRPF90_temp/build.ninja"]] str_creation = " ".join(l_creation) diff --git a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py index 0c5e1b37..946cbe35 100755 --- a/scripts/ezfio_interface/qp_convert_output_to_ezfio.py +++ b/scripts/ezfio_interface/qp_convert_output_to_ezfio.py @@ -20,18 +20,17 @@ from functools import reduce # Add to the path # # ~#~#~#~#~#~#~#~ # + try: QP_ROOT = os.environ["QP_ROOT"] except: print "Error: QP_ROOT environment variable not found." sys.exit(1) else: - sys.path = [ QP_ROOT + "/install/EZFIO/Python", QP_ROOT + "/resultsFile", QP_ROOT + "/scripts"] + sys.path - # ~#~#~#~#~#~ # # I m p o r t # # ~#~#~#~#~#~ # @@ -365,17 +364,20 @@ def write_ezfio(res, filename): pseudo_str = "\n".join(pseudo_str) matrix, array_l_max_block, array_z_remove = parse_str(pseudo_str) + array_z_remove = map(float,array_z_remove) except: ezfio.set_pseudo_do_pseudo(False) else: ezfio.set_pseudo_do_pseudo(True) - + # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # # Z _ e f f , a l p h a / b e t a _ e l e c # # ~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~ # - ezfio.pseudo_charge_remove = array_z_remove - ezfio.nuclei_nucl_charge = [i - j for i, j in zip(ezfio.nuclei_nucl_charge, array_z_remove)] + ezfio.set_pseudo_nucl_charge_remove(array_z_remove) + charge = ezfio.get_nuclei_nucl_charge() + charge = [ i - j for i, j in zip(charge, array_z_remove) ] + ezfio.set_nuclei_nucl_charge (charge) import math num_elec_diff = sum(array_z_remove)/2 diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 5dd1e4f3..c7714e8a 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -343,7 +343,7 @@ class H_apply(object): """ self.data["size_max"] = "8192" self.data["initialization"] = """ -! PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit + PROVIDE psi_selectors_coef psi_selectors E_corr_per_selectors psi_det_sorted_bit """ if self.do_double_exc == True: self.data["keys_work"] = """ @@ -370,7 +370,7 @@ class H_apply(object): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) -! PROVIDE N_det_generators + PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 @@ -478,7 +478,7 @@ class H_apply_zmq(H_apply): double precision, intent(inout):: norm_pert(N_st) double precision, intent(inout):: H_pert_diag(N_st) double precision :: delta_pt2(N_st), norm_psi(N_st), pt2_old(N_st) -! PROVIDE N_det_generators + PROVIDE N_det_generators do k=1,N_st pt2(k) = 0.d0 norm_pert(k) = 0.d0 diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 7c729827..0667c376 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -253,9 +253,6 @@ if __name__ == '__main__': m.create_png(l_module) except RuntimeError: pass - except SyntaxError: - print "Warning: The graphviz API drop support of python 2.6." - pass if arguments["clean"] or arguments["create_git_ignore"]: @@ -301,7 +298,6 @@ if __name__ == '__main__': # Don't update if we are not in the main repository from is_master_repository import is_master_repository if not is_master_repository: - print >> sys.stderr, 'Not in the master repo' sys.exit() path = os.path.join(module_abs, ".gitignore") diff --git a/src/AO_Basis/ao_overlap.irp.f b/src/AO_Basis/ao_overlap.irp.f index 08e57f73..edf48b25 100644 --- a/src/AO_Basis/ao_overlap.irp.f +++ b/src/AO_Basis/ao_overlap.irp.f @@ -129,48 +129,3 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num_align,ao_num) ] !$OMP END PARALLEL DO END_PROVIDER -BEGIN_PROVIDER [ double precision, ao_overlap_inv, (ao_num_align, ao_num) ] - implicit none - BEGIN_DOC - ! Inverse of the overlap matrix - END_DOC - call invert_matrix(ao_overlap, size(ao_overlap,1), ao_num, ao_overlap_inv, size(ao_overlap_inv,1)) -END_PROVIDER - -BEGIN_PROVIDER [double precision, ao_overlap_inv_1_2, (ao_num_align,ao_num)] - implicit none - integer :: i,j,k,l - double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) - call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) - ao_overlap_inv_1_2 = 0.d0 - double precision :: a_n - do i = 1, ao_num - a_n = 1.d0/dsqrt(eigvalues(i)) - if(a_n.le.1.d-10)cycle - do j = 1, ao_num - do k = 1, ao_num - ao_overlap_inv_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n - enddo - enddo - enddo - -END_PROVIDER - - -BEGIN_PROVIDER [double precision, ao_overlap_1_2, (ao_num_align,ao_num)] - implicit none - integer :: i,j,k,l - double precision :: eigvalues(ao_num),eigvectors(ao_num_align, ao_num) - call lapack_diag(eigvalues,eigvectors,ao_overlap,ao_num_align,ao_num) - ao_overlap_1_2 = 0.d0 - double precision :: a_n - do i = 1, ao_num - a_n = dsqrt(eigvalues(i)) - do j = 1, ao_num - do k = 1, ao_num - ao_overlap_1_2(k,j) += eigvectors(k,i) * eigvectors(j,i) * a_n - enddo - enddo - enddo - -END_PROVIDER diff --git a/src/AO_Basis/aos_value.irp.f b/src/AO_Basis/aos_value.irp.f index 4876844c..a531ce50 100644 --- a/src/AO_Basis/aos_value.irp.f +++ b/src/AO_Basis/aos_value.irp.f @@ -26,7 +26,6 @@ double precision function ao_value(i,r) do m=1,ao_prim_num(i) beta = ao_expo_ordered_transp(m,i) accu += ao_coef_normalized_ordered_transp(m,i) * dexp(-beta*r2) -! accu += ao_coef_transp(m,i) * dexp(-beta*r2) enddo ao_value = accu * dx * dy * dz diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 5c170632..87a02d10 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -560,24 +560,3 @@ logical function is_i_in_virtual(i) endif end - -logical function is_i_in_active(i) - implicit none - integer,intent(in) :: i - integer(bit_kind) :: key(N_int) - integer :: k,j - integer :: accu - is_i_in_active = .False. - key= 0_bit_kind - k = ishft(i-1,-bit_kind_shift)+1 - j = i-ishft(k-1,bit_kind_shift)-1 - key(k) = ibset(key(k),j) - accu = 0 - do k = 1, N_int - accu += popcnt(iand(key(k),cas_bitmask(k,1,1))) - enddo - if(accu .ne. 0)then - is_i_in_active= .True. - endif - -end diff --git a/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f b/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f deleted file mode 100644 index 3bdc37c5..00000000 --- a/src/Davidson/diagonalize_restart_and_save_all_nstates_diag.irp.f +++ /dev/null @@ -1,16 +0,0 @@ -program diag_and_save - implicit none - read_wf = .True. - touch read_wf - call routine -end - -subroutine routine - implicit none - call diagonalize_CI - print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) - - - -end diff --git a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f index 393ff63a..3bdc37c5 100644 --- a/src/Davidson/diagonalize_restart_and_save_all_states.irp.f +++ b/src/Davidson/diagonalize_restart_and_save_all_states.irp.f @@ -9,7 +9,7 @@ subroutine routine implicit none call diagonalize_CI print*,'N_det = ',N_det - call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) + call save_wavefunction_general(N_det,N_states_diag,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted) diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index a9ecd806..a68a61a5 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -119,9 +119,3 @@ doc: Maximum number of determinants for which the full H matrix is stored. Be ca interface: ezfio,provider,ocaml default: 90000 -[density_matrix_mo_disk] -type: double precision -doc: coefficient of the ith ao on the jth mo -interface: ezfio -size: (mo_basis.mo_tot_num,mo_basis.mo_tot_num) - diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 561f7e89..a6a7310f 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -195,7 +195,6 @@ subroutine copy_H_apply_buffer_to_wf !call remove_duplicates_in_psi_det(found_duplicates) end - subroutine remove_duplicates_in_psi_det(found_duplicates) implicit none logical, intent(out) :: found_duplicates @@ -271,81 +270,6 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) deallocate (duplicate,bit_tmp) end -subroutine remove_duplicates_in_psi_det_new(found_duplicates) - implicit none - logical, intent(out) :: found_duplicates - BEGIN_DOC -! Removes duplicate determinants in the wave function. - END_DOC - integer :: i,j,k - integer(bit_kind), allocatable :: bit_tmp(:) - logical,allocatable :: duplicate(:) - - allocate (duplicate(N_det), bit_tmp(N_det)) - - do i=1,N_det - integer, external :: det_search_key - !$DIR FORCEINLINE - bit_tmp(i) = det_search_key(psi_det_sorted_bit(1,1,i),N_int) - duplicate(i) = .False. - enddo - - do i=1,N_det-1 - if (duplicate(i)) then - cycle - endif - j = i+1 - do while (bit_tmp(j)==bit_tmp(i)) - if (duplicate(j)) then - j += 1 - if (j > N_det) then - exit - else - cycle - endif - endif - duplicate(j) = .True. - do k=1,N_int - if ( (psi_det_sorted_bit(k,1,i) /= psi_det_sorted_bit(k,1,j) ) & - .or. (psi_det_sorted_bit(k,2,i) /= psi_det_sorted_bit(k,2,j) ) ) then - duplicate(j) = .False. - exit - endif - enddo - j += 1 - if (j > N_det) then - exit - endif - enddo - enddo - - found_duplicates = .False. - do i=1,N_det - if (duplicate(i)) then - found_duplicates = .True. - exit - endif - enddo - - if (found_duplicates) then - k=0 - do i=1,N_det - if (.not.duplicate(i)) then - k += 1 - psi_det(:,:,k) = psi_det_sorted_bit (:,:,i) - psi_coef(k,:) = psi_coef_sorted_bit(i,:) - else - psi_det(:,:,k) = 0_bit_kind - psi_coef(k,:) = 0.d0 - endif - enddo - N_det = k - call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') - SOFT_TOUCH N_det psi_det psi_coef - endif - deallocate (duplicate,bit_tmp) -end - subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc) use bitmasks diff --git a/src/Determinants/H_apply_nozmq.template.f b/src/Determinants/H_apply_nozmq.template.f index 5550d9d1..0c319fe3 100644 --- a/src/Determinants/H_apply_nozmq.template.f +++ b/src/Determinants/H_apply_nozmq.template.f @@ -17,7 +17,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization - PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map !psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators nmax = mod( N_det_generators,nproc ) diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 97f225b4..ddedc5a2 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -20,7 +20,7 @@ subroutine $subroutine($params_main) double precision, allocatable :: fock_diag_tmp(:,:) $initialization -! PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators integer(ZMQ_PTR), external :: new_zmq_pair_socket integer(ZMQ_PTR) :: zmq_socket_pair diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 541cfcb4..923318bc 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -15,72 +15,6 @@ enddo END_PROVIDER - -subroutine save_density_matrix_mo - implicit none - double precision, allocatable :: dm(:,:) - allocate(dm(mo_tot_num,mo_tot_num)) - integer :: i,j - do i = 1, mo_tot_num - do j = 1, mo_tot_num - dm(i,j) = one_body_dm_mo_alpha_average(i,j) - enddo - enddo - call ezfio_set_determinants_density_matrix_mo_disk(dm) - -end - - BEGIN_PROVIDER [ double precision, one_body_dm_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] - implicit none - integer :: i,j,ispin,istate - ispin = 1 - do istate = 1, N_states - do j = 1, mo_tot_num - do i = 1, mo_tot_num - one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_alpha(i,j,istate) - enddo - enddo - enddo - - ispin = 2 - do istate = 1, N_states - do j = 1, mo_tot_num - do i = 1, mo_tot_num - one_body_dm_mo_spin_index(i,j,istate,ispin) = one_body_dm_mo_beta(i,j,istate) - enddo - enddo - enddo - - END_PROVIDER - - - BEGIN_PROVIDER [ double precision, one_body_dm_dagger_mo_spin_index, (mo_tot_num_align,mo_tot_num,N_states,2) ] - implicit none - integer :: i,j,ispin,istate - ispin = 1 - do istate = 1, N_states - do j = 1, mo_tot_num - one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_alpha(j,j,istate) - do i = j+1, mo_tot_num - one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) - one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_alpha(i,j,istate) - enddo - enddo - enddo - - ispin = 2 - do istate = 1, N_states - do j = 1, mo_tot_num - one_body_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_body_dm_mo_beta(j,j,istate) - do i = j+1, mo_tot_num - one_body_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) - one_body_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_body_dm_mo_beta(i,j,istate) - enddo - enddo - enddo - - END_PROVIDER - BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha, (mo_tot_num_align,mo_tot_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta, (mo_tot_num_align,mo_tot_num,N_states) ] implicit none @@ -156,16 +90,39 @@ end lcol = psi_bilinear_matrix_columns(l) enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP END PARALLEL + l = psi_bilinear_matrix_order_reverse(k)+1 + ! Fix alpha determinant, loop over betas + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + do while ( lrow == krow ) + tmp_det2(:) = psi_det_beta_unique (:, lcol) + call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int) + if (degree == 1) then + call get_mono_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_transp_values(l,m) * phase + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + enddo + + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL + END_PROVIDER BEGIN_PROVIDER [ double precision, one_body_single_double_dm_mo_alpha, (mo_tot_num_align,mo_tot_num) ] diff --git a/src/Determinants/diagonalize_restart_and_save_two_states.irp.f b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f new file mode 100644 index 00000000..97fed531 --- /dev/null +++ b/src/Determinants/diagonalize_restart_and_save_two_states.irp.f @@ -0,0 +1,27 @@ +program diag_and_save + implicit none + read_wf = .True. + touch read_wf + call routine +end + +subroutine routine + implicit none + integer :: igood_state_1,igood_state_2 + double precision, allocatable :: psi_coef_tmp(:,:) + integer :: i + print*,'N_det = ',N_det +!call diagonalize_CI + write(*,*)'Which couple of states would you like to save ?' + read(5,*)igood_state_1,igood_state_2 + allocate(psi_coef_tmp(n_det,2)) + do i = 1, N_det + psi_coef_tmp(i,1) = psi_coef(i,igood_state_1) + psi_coef_tmp(i,2) = psi_coef(i,igood_state_2) + enddo + call save_wavefunction_general(N_det,2,psi_det,n_det,psi_coef_tmp) + deallocate(psi_coef_tmp) + + + +end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index 2120a512..737e4d3e 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -32,28 +32,29 @@ subroutine routine call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*,'phase = ',phase - if(degree == 1)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - if(s1 == 1)then - norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) - else - norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) - endif +! if(degree == 1)then +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! if(s1 == 1)then +! norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) +! else +! norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) +! endif ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) - double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) - print*,'hmono = ',hmono - print*,'hdouble = ',hdouble - print*,'hmono+hdouble = ',hmono+hdouble - print*,'hij = ',hij - else if (degree == 2)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - print*,'s2',s2 - print*,'h2,p2 = ',h2,p2 +! double precision :: hmono,hdouble +! call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) +! print*,'hmono = ',hmono +! print*,'hdouble = ',hdouble +! print*,'hmono+hdouble = ',hmono+hdouble +! print*,'hij = ',hij +! else +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! print*,'s2',s2 +! print*,'h2,p2 = ',h2,p2 ! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - endif +! endif + print*,' = ',hij endif print*,'amplitude = ',psi_coef(i,1)/psi_coef(1,1) diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 78a35689..4d5b1bd3 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -2144,27 +2144,9 @@ subroutine H_u_0_stored(v_0,u_0,hmatrix,sze) double precision, intent(in) :: u_0(sze) v_0 = 0.d0 call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) -end -subroutine H_s2_u_0_stored(v_0,u_0,hmatrix,s2matrix,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> - ! - ! n : number of determinants - ! - ! uses the big_matrix_stored array - END_DOC - integer, intent(in) :: sze - double precision, intent(in) :: hmatrix(sze,sze),s2matrix(sze,sze) - double precision, intent(out) :: v_0(sze) - double precision, intent(in) :: u_0(sze) - v_0 = 0.d0 - call matrix_vector_product(u_0,v_0,hmatrix,sze,sze) end - subroutine u_0_H_u_0_stored(e_0,u_0,hmatrix,sze) use bitmasks implicit none diff --git a/src/Determinants/truncate_wf.irp.f b/src/Determinants/truncate_wf.irp.f index 49b5e70a..aba16fa7 100644 --- a/src/Determinants/truncate_wf.irp.f +++ b/src/Determinants/truncate_wf.irp.f @@ -1,52 +1,8 @@ program s2_eig_restart implicit none read_wf = .True. - call routine_2 + call routine end - -subroutine routine_2 - implicit none - integer :: i,j,k,l - use bitmasks - integer :: n_det_restart,degree - integer(bit_kind),allocatable :: psi_det_tmp(:,:,:) - double precision ,allocatable :: psi_coef_tmp(:,:),accu(:) - integer, allocatable :: index_restart(:) - allocate(index_restart(N_det)) - print*, 'How many Slater determinants would ou like ?' - read(5,*)N_det_restart - do i = 1, N_det_restart - index_restart(i) = i - enddo - allocate (psi_det_tmp(N_int,2,N_det_restart),psi_coef_tmp(N_det_restart,N_states),accu(N_states)) - accu = 0.d0 - do i = 1, N_det_restart - do j = 1, N_int - psi_det_tmp(j,1,i) = psi_det(j,1,index_restart(i)) - psi_det_tmp(j,2,i) = psi_det(j,2,index_restart(i)) - enddo - do j = 1,N_states - psi_coef_tmp(i,j) = psi_coef(index_restart(i),j) - accu(j) += psi_coef_tmp(i,j) * psi_coef_tmp(i,j) - enddo - enddo - do j = 1, N_states - accu(j) = 1.d0/dsqrt(accu(j)) - enddo - do j = 1,N_states - do i = 1, N_det_restart - psi_coef_tmp(i,j) = psi_coef_tmp(i,j) * accu(j) - enddo - enddo - call save_wavefunction_general(N_det_restart,N_states,psi_det_tmp,N_det_restart,psi_coef_tmp) - - deallocate (psi_det_tmp,psi_coef_tmp,accu,index_restart) - - - -end - - subroutine routine implicit none call make_s2_eigenfunction diff --git a/src/Determinants/two_body_dm_map.irp.f b/src/Determinants/two_body_dm_map.irp.f index bb1a341e..aa8f630b 100644 --- a/src/Determinants/two_body_dm_map.irp.f +++ b/src/Determinants/two_body_dm_map.irp.f @@ -194,8 +194,6 @@ subroutine add_values_to_two_body_dm_map(mask_ijkl) end BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_act, (n_act_orb, n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_aa_diag_act, (n_act_orb, n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_bb_diag_act, (n_act_orb, n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_inact, (n_inact_orb_allocate, n_inact_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_core, (n_core_orb_allocate, n_core_orb_allocate)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_diag_all, (mo_tot_num, mo_tot_num)] @@ -236,8 +234,6 @@ end two_body_dm_ab_diag_all = 0.d0 two_body_dm_ab_diag_act = 0.d0 - two_body_dm_aa_diag_act = 0.d0 - two_body_dm_bb_diag_act = 0.d0 two_body_dm_ab_diag_core = 0.d0 two_body_dm_ab_diag_inact = 0.d0 two_body_dm_diag_core_a_act_b = 0.d0 @@ -273,20 +269,8 @@ end two_body_dm_ab_diag_act(k,m) += 0.5d0 * contrib two_body_dm_ab_diag_act(m,k) += 0.5d0 * contrib enddo - do l = 1, n_occ_ab_act(2) - m = list_act_reverse(occ_act(l,2)) - two_body_dm_bb_diag_act(k,m) += 0.5d0 * contrib - two_body_dm_bb_diag_act(m,k) += 0.5d0 * contrib - enddo - enddo - do j = 1,n_occ_ab_act(1) - k = list_act_reverse(occ_act(j,1)) - do l = 1, n_occ_ab_act(1) - m = list_act_reverse(occ_act(l,1)) - two_body_dm_aa_diag_act(k,m) += 0.5d0 * contrib - two_body_dm_aa_diag_act(m,k) += 0.5d0 * contrib - enddo enddo + ! CORE PART of the diagonal part of the two body dm do j = 1, N_int key_tmp_core(j,1) = psi_det(j,1,i) @@ -341,8 +325,6 @@ end END_PROVIDER BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_aa_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] -&BEGIN_PROVIDER [double precision, two_body_dm_bb_big_array_act, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] &BEGIN_PROVIDER [double precision, two_body_dm_ab_big_array_core_act, (n_core_orb_allocate,n_act_orb,n_act_orb)] implicit none use bitmasks @@ -412,22 +394,14 @@ END_PROVIDER call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) contrib = 0.5d0 * psi_coef(i,1) * psi_coef(j,1) * phase if(degree==2)then ! case of the DOUBLE EXCITATIONS ************************************ + if(s1==s2)cycle ! Only the alpha/beta two body density matrix ! * c_I * c_J h1 = list_act_reverse(h1) h2 = list_act_reverse(h2) p1 = list_act_reverse(p1) p2 = list_act_reverse(p2) - if(s1==s2)then - if(s1==1)then - call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) -! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) - else - call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) -! call insert_into_two_body_dm_big_array( two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,p2,h2,p1) - endif - else ! alpha/beta two body density matrix - call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) - endif + call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,h2,p2) + else if(degree==1)then! case of the SINGLE EXCITATIONS *************************************************** print*,'h1 = ',h1 h1 = list_act_reverse(h1) @@ -443,12 +417,6 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array( two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo - do k = 1, n_occ_ab(1) - m = list_act_reverse(occ(k,1)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) -! call insert_into_two_body_dm_big_array( two_body_dm_aa_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) - enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(2) @@ -464,12 +432,6 @@ END_PROVIDER ! * c_I * c_J call insert_into_two_body_dm_big_array(two_body_dm_ab_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) enddo - do k = 1, n_occ_ab(2) - m = list_act_reverse(occ(k,2)) - ! * c_I * c_J - call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,contrib,h1,p1,m,m) -! call insert_into_two_body_dm_big_array(two_body_dm_bb_big_array_act,n_act_orb,n_act_orb,n_act_orb,n_act_orb,-contrib,h1,m,p1,m) - enddo ! core <-> active part of the extra diagonal two body dm do k = 1, n_occ_ab_core(1) @@ -502,3 +464,156 @@ subroutine insert_into_two_body_dm_big_array(big_array,dim1,dim2,dim3,dim4,contr end + +double precision function compute_extra_diag_two_body_dm_ab(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the alpha/bet two body density at r1, r2 + END_DOC + double precision :: r1(3), r2(3) + double precision :: compute_extra_diag_two_body_dm_ab_act,compute_extra_diag_two_body_dm_ab_core_act + compute_extra_diag_two_body_dm_ab = compute_extra_diag_two_body_dm_ab_act(r1,r2)+compute_extra_diag_two_body_dm_ab_core_act(r1,r2) +end + +double precision function compute_extra_diag_two_body_dm_ab_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + PROVIDE n_act_orb + double precision, intent(in) :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib + double precision :: contrib_tmp +!print*,'n_act_orb = ',n_act_orb + compute_extra_diag_two_body_dm_ab_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_r1) + call give_all_act_mos_at_r(r2,mos_array_r2) + do l = 1, n_act_orb ! p2 + do k = 1, n_act_orb ! h2 + do j = 1, n_act_orb ! p1 + do i = 1,n_act_orb ! h1 + contrib_tmp = mos_array_r1(i) * mos_array_r1(j) * mos_array_r2(k) * mos_array_r2(l) + compute_extra_diag_two_body_dm_ab_act += two_body_dm_ab_big_array_act(i,j,k,l) * contrib_tmp + enddo + enddo + enddo + enddo + +end + +double precision function compute_extra_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + BEGIN_DOC +! compute the extra diagonal contribution to the two body density at r1, r2 +! involving ONLY THE ACTIVE PART, which means that the four index of the excitations +! involved in the two body density matrix are ACTIVE + END_DOC + double precision, intent(in) :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: mos_array_core_r1(n_core_orb),mos_array_core_r2(n_core_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_extra_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) + do i = 1, n_act_orb ! h1 + do j = 1, n_act_orb ! p1 + contrib_act_1 = mos_array_act_r1(i) * mos_array_act_r1(j) + contrib_act_2 = mos_array_act_r2(i) * mos_array_act_r2(j) + do k = 1,n_core_orb ! h2 + contrib_core_1 = mos_array_core_r1(k) * mos_array_core_r1(k) + contrib_core_2 = mos_array_core_r2(k) * mos_array_core_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_core_2 + contrib_act_2 * contrib_core_1) + compute_extra_diag_two_body_dm_ab_core_act += two_body_dm_ab_big_array_core_act(k,i,j) * contrib_tmp + enddo + enddo + enddo + +end + +double precision function compute_diag_two_body_dm_ab_core(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_core_orb_allocate),mos_array_r2(n_core_orb_allocate) + double precision :: contrib,contrib_tmp + compute_diag_two_body_dm_ab_core = 0.d0 + call give_all_core_mos_at_r(r1,mos_array_r1) + call give_all_core_mos_at_r(r2,mos_array_r2) + do l = 1, n_core_orb ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_core_orb ! + contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + compute_diag_two_body_dm_ab_core += two_body_dm_ab_diag_core(k,l) * contrib_tmp + enddo + enddo + +end + + +double precision function compute_diag_two_body_dm_ab_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_r1(n_act_orb),mos_array_r2(n_act_orb) + double precision :: contrib,contrib_tmp + compute_diag_two_body_dm_ab_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_r1) + call give_all_act_mos_at_r(r2,mos_array_r2) + do l = 1, n_act_orb ! + contrib = mos_array_r2(l)*mos_array_r2(l) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_act_orb ! + contrib_tmp = contrib * mos_array_r1(k)*mos_array_r1(k) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + compute_diag_two_body_dm_ab_act += two_body_dm_ab_diag_act(k,l) * contrib_tmp + enddo + enddo +end + +double precision function compute_diag_two_body_dm_ab_core_act(r1,r2) + implicit none + double precision :: r1(3),r2(3) + integer :: i,j,k,l + double precision :: mos_array_core_r1(n_core_orb_allocate),mos_array_core_r2(n_core_orb_allocate) + double precision :: mos_array_act_r1(n_act_orb),mos_array_act_r2(n_act_orb) + double precision :: contrib_core_1,contrib_core_2 + double precision :: contrib_act_1,contrib_act_2 + double precision :: contrib_tmp + compute_diag_two_body_dm_ab_core_act = 0.d0 + call give_all_act_mos_at_r(r1,mos_array_act_r1) + call give_all_act_mos_at_r(r2,mos_array_act_r2) + call give_all_core_mos_at_r(r1,mos_array_core_r1) + call give_all_core_mos_at_r(r2,mos_array_core_r2) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do k = 1, n_act_orb ! + contrib_act_1 = mos_array_act_r1(k) * mos_array_act_r1(k) + contrib_act_2 = mos_array_act_r2(k) * mos_array_act_r2(k) + contrib_tmp = 0.5d0 * (contrib_act_1 * contrib_act_2 + contrib_act_2 * contrib_act_1) +! if(dabs(contrib).lt.threshld_two_bod_dm)cycle + do l = 1, n_core_orb ! + contrib_core_1 = mos_array_core_r1(l) * mos_array_core_r1(l) + contrib_core_2 = mos_array_core_r2(l) * mos_array_core_r2(l) + compute_diag_two_body_dm_ab_core_act += two_body_dm_diag_core_act(l,k) * contrib_tmp + enddo + enddo +end + +double precision function compute_diag_two_body_dm_ab(r1,r2) + implicit none + double precision,intent(in) :: r1(3),r2(3) + double precision :: compute_diag_two_body_dm_ab_act,compute_diag_two_body_dm_ab_core + double precision :: compute_diag_two_body_dm_ab_core_act + compute_diag_two_body_dm_ab = compute_diag_two_body_dm_ab_act(r1,r2)+compute_diag_two_body_dm_ab_core(r1,r2) & + + compute_diag_two_body_dm_ab_core_act(r1,r2) +end diff --git a/src/Integrals_Bielec/EZFIO.cfg b/src/Integrals_Bielec/EZFIO.cfg index 0576b811..4e7e494f 100644 --- a/src/Integrals_Bielec/EZFIO.cfg +++ b/src/Integrals_Bielec/EZFIO.cfg @@ -51,4 +51,3 @@ doc: If || < ao_integrals_threshold then is zero interface: ezfio,provider,ocaml default: 1.e-15 ezfio_name: threshold_mo - diff --git a/src/Integrals_Monoelec/EZFIO.cfg b/src/Integrals_Monoelec/EZFIO.cfg index c8a8eaef..04e49ec1 100644 --- a/src/Integrals_Monoelec/EZFIO.cfg +++ b/src/Integrals_Monoelec/EZFIO.cfg @@ -4,14 +4,6 @@ doc: Read/Write MO one-electron integrals from/to disk [ Write | Read | None ] interface: ezfio,provider,ocaml default: None - -[disk_access_only_mo_one_integrals] -type: Disk_access -doc: Read/Write MO for only the total one-electron integrals which can be anything [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - - [disk_access_ao_one_integrals] type: Disk_access doc: Read/Write AO one-electron integrals from/to disk [ Write | Read | None ] diff --git a/src/Integrals_Monoelec/mo_mono_ints.irp.f b/src/Integrals_Monoelec/mo_mono_ints.irp.f index 816dd277..50ab7ffa 100644 --- a/src/Integrals_Monoelec/mo_mono_ints.irp.f +++ b/src/Integrals_Monoelec/mo_mono_ints.irp.f @@ -6,24 +6,10 @@ BEGIN_PROVIDER [ double precision, mo_mono_elec_integral,(mo_tot_num_align,mo_to ! sum of the kinetic and nuclear electronic potential END_DOC print*,'Providing the mono electronic integrals' - if (read_only_mo_one_integrals) then - print*, 'Reading the mono electronic integrals from disk' - call read_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & - size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) - print *, 'MO N-e integrals read from disk' - else - do j = 1, mo_tot_num - do i = 1, mo_tot_num - mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & - mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) - enddo - enddo - endif - -! if (write_mo_one_integrals) then -! call write_one_e_integrals('mo_one_integral', mo_mono_elec_integral, & -! size(mo_mono_elec_integral,1), size(mo_mono_elec_integral,2)) -! print *, 'MO N-e integrals written to disk' -! endif - + do j = 1, mo_tot_num + do i = 1, mo_tot_num + mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + & + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) + enddo + enddo END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_ao_ints.irp.f b/src/Integrals_Monoelec/pot_ao_ints.irp.f index aef8a060..7116d2c7 100644 --- a/src/Integrals_Monoelec/pot_ao_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_ints.irp.f @@ -185,7 +185,7 @@ include 'Utils/constants.include.F' enddo const_factor = dist*rho const = p * dist_integral - if(const_factor > 1000.d0)then + if(const_factor > 80.d0)then NAI_pol_mult = 0.d0 return endif diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index bfe10b91..22cceab9 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential integrals END_DOC - + if (read_ao_one_integrals) then call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) @@ -53,6 +53,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) + thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & diff --git a/src/Integrals_Monoelec/read_write.irp.f b/src/Integrals_Monoelec/read_write.irp.f index 0e758740..697bf356 100644 --- a/src/Integrals_Monoelec/read_write.irp.f +++ b/src/Integrals_Monoelec/read_write.irp.f @@ -1,6 +1,5 @@ BEGIN_PROVIDER [ logical, read_ao_one_integrals ] &BEGIN_PROVIDER [ logical, read_mo_one_integrals ] -&BEGIN_PROVIDER [ logical, read_only_mo_one_integrals ] &BEGIN_PROVIDER [ logical, write_ao_one_integrals ] &BEGIN_PROVIDER [ logical, write_mo_one_integrals ] @@ -22,14 +21,10 @@ write_ao_one_integrals = .False. else - print *, 'monoelec_integrals/disk_access_ao_integrals has a wrong type' + print *, 'bielec_integrals/disk_access_ao_integrals has a wrong type' stop 1 endif - - if (disk_access_only_mo_one_integrals.EQ.'Read')then - read_only_mo_one_integrals = .True. - endif if (disk_access_mo_one_integrals.EQ.'Read') then read_mo_one_integrals = .True. @@ -44,7 +39,7 @@ write_mo_one_integrals = .False. else - print *, 'monoelec_integrals/disk_access_mo_integrals has a wrong type' + print *, 'bielec_integrals/disk_access_mo_integrals has a wrong type' stop 1 endif diff --git a/src/MO_Basis/cholesky_mo.irp.f b/src/MO_Basis/cholesky_mo.irp.f index 774198a3..65184c1e 100644 --- a/src/MO_Basis/cholesky_mo.irp.f +++ b/src/MO_Basis/cholesky_mo.irp.f @@ -50,9 +50,9 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) deallocate(W,work) end -!subroutine svd_mo(n,m,P,LDP,C,LDC) -!implicit none -!BEGIN_DOC +subroutine svd_mo(n,m,P,LDP,C,LDC) + implicit none + BEGIN_DOC ! Singular value decomposition of the AO Density matrix ! ! n : Number of AOs @@ -66,36 +66,6 @@ end ! tol_in : tolerance ! ! rank : Nomber of local MOs (output) -! -!END_DOC -!integer, intent(in) :: n,m, LDC, LDP -!double precision, intent(in) :: P(LDP,n) -!double precision, intent(out) :: C(LDC,m) - -!integer :: info -!integer :: i,k -!integer :: ipiv(n) -!double precision:: tol -!double precision, allocatable :: W(:,:), work(:) - -!allocate(W(LDC,n),work(2*n)) -!call svd(P,LDP,C,LDC,W,size(W,1),m,n) - -!deallocate(W,work) -!end - -subroutine svd_mo(n,m,P,LDP,C,LDC) - implicit none - BEGIN_DOC -! Singular value decomposition of the AO Density matrix -! -! n : Number of AOs -! -! m : Number of MOs -! -! P(LDP,n) : Density matrix in AO basis -! -! C(LDC,m) : MOs ! END_DOC integer, intent(in) :: n,m, LDC, LDP @@ -106,64 +76,10 @@ subroutine svd_mo(n,m,P,LDP,C,LDC) integer :: i,k integer :: ipiv(n) double precision:: tol - double precision, allocatable :: W(:,:), work(:), D(:) + double precision, allocatable :: W(:,:), work(:) - allocate(W(LDC,n),work(2*n),D(n)) - print*, '' - do i = 1, n - print*, P(i,i) - enddo - call svd(P,LDP,C,LDC,D,W,size(W,1),m,n) - double precision :: accu - accu = 0.d0 - print*, 'm',m - do i = 1, m - print*, D(i) - accu += D(i) - enddo - print*,'Sum of D',accu - - deallocate(W,work) -end - -subroutine svd_mo_new(n,m,m_physical,P,LDP,C,LDC) - implicit none - BEGIN_DOC -! Singular value decomposition of the AO Density matrix -! -! n : Number of AOs - -! m : Number of MOs -! -! P(LDP,n) : Density matrix in AO basis -! -! C(LDC,m) : MOs -! -! tol_in : tolerance -! -! rank : Nomber of local MOs (output) -! - END_DOC - integer, intent(in) :: n,m,m_physical, LDC, LDP - double precision, intent(in) :: P(LDP,n) - double precision, intent(out) :: C(LDC,m) - - integer :: info - integer :: i,k - integer :: ipiv(n) - double precision:: tol - double precision, allocatable :: W(:,:), work(:), D(:) - - allocate(W(LDC,n),work(2*n),D(n)) - call svd(P,LDP,C,LDC,D,W,size(W,1),m_physical,n) - double precision :: accu - accu = 0.d0 - print*, 'm',m_physical - do i = 1, m_physical - print*, D(i) - accu += D(i) - enddo - print*,'Sum of D',accu + allocate(W(LDC,n),work(2*n)) + call svd(P,LDP,C,LDC,W,size(W,1),m,n) deallocate(W,work) end diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 56ab8d2f..19835395 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -181,146 +181,24 @@ subroutine mo_to_ao(A_mo,LDA_mo,A_ao,LDA_ao) allocate ( T(mo_tot_num_align,ao_num) ) !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T -! SC call dgemm('N','N', ao_num, mo_tot_num, ao_num, & 1.d0, ao_overlap,size(ao_overlap,1), & mo_coef, size(mo_coef,1), & 0.d0, SC, ao_num_align) -! A.CS call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & 1.d0, A_mo,LDA_mo, & SC, size(SC,1), & 0.d0, T, mo_tot_num_align) -! SC.A.CS call dgemm('N','N', ao_num, ao_num, mo_tot_num, & 1.d0, SC,size(SC,1), & T, mo_tot_num_align, & 0.d0, A_ao, LDA_ao) -! C(S.A.S)C -! SC.A.CS deallocate(T,SC) end - -subroutine mo_to_ao_s_inv_1_2(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_inv_1_2(:,:) - - allocate ( SC_inv_1_2(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_inv_1_2 = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_inv_1_2,size(ao_overlap_inv_1_2,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_inv_1_2, ao_num_align) - -! T = A.(SC_inv_1_2)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_inv_1_2, size(SC_inv_1_2,1), & - 0.d0, T, mo_tot_num_align) - -! SC_inv_1_2.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_inv_1_2,size(SC_inv_1_2,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_inv_1_2.A.CS - deallocate(T,SC_inv_1_2) -end - -subroutine mo_to_ao_s_1_2(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_1_2(:,:) - - allocate ( SC_1_2(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_1_2 = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_1_2,size(ao_overlap_1_2,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_1_2, ao_num_align) - -! T = A.(SC_1_2)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_1_2, size(SC_1_2,1), & - 0.d0, T, mo_tot_num_align) - -! SC_1_2.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_1_2,size(SC_1_2,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_1_2.A.CS - deallocate(T,SC_1_2) -end - - -subroutine mo_to_ao_s_inv(A_mo,LDA_mo,A_ao,LDA_ao) - implicit none - BEGIN_DOC - ! Transform A from the MO basis to the AO basis using the S^{-1} matrix - ! S^{-1} C A C^{+} S^{-1} - END_DOC - integer, intent(in) :: LDA_ao,LDA_mo - double precision, intent(in) :: A_mo(LDA_mo) - double precision, intent(out) :: A_ao(LDA_ao) - double precision, allocatable :: T(:,:), SC_inv(:,:) - - allocate ( SC_inv(ao_num_align,mo_tot_num) ) - allocate ( T(mo_tot_num_align,ao_num) ) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T - -! SC_inv = S^{-1}C - call dgemm('N','N', ao_num, mo_tot_num, ao_num, & - 1.d0, ao_overlap_inv,size(ao_overlap_inv,1), & - mo_coef, size(mo_coef,1), & - 0.d0, SC_inv, ao_num_align) - -! T = A.(SC_inv)^{+} - call dgemm('N','T', mo_tot_num, ao_num, mo_tot_num, & - 1.d0, A_mo,LDA_mo, & - SC_inv, size(SC_inv,1), & - 0.d0, T, mo_tot_num_align) - -! SC_inv.A.CS - call dgemm('N','N', ao_num, ao_num, mo_tot_num, & - 1.d0, SC_inv,size(SC_inv,1), & - T, mo_tot_num_align, & - 0.d0, A_ao, LDA_ao) - -! C(S.A.S)C -! SC_inv.A.CS - deallocate(T,SC_inv) -end - - subroutine mo_to_ao_no_overlap(A_mo,LDA_mo,A_ao,LDA_ao) implicit none BEGIN_DOC diff --git a/src/MO_Basis/rotate_mos.irp.f b/src/MO_Basis/rotate_mos.irp.f deleted file mode 100644 index a1c03bcd..00000000 --- a/src/MO_Basis/rotate_mos.irp.f +++ /dev/null @@ -1,8 +0,0 @@ -program rotate - implicit none - integer :: iorb,jorb - print*, 'which mos would you like to rotate' - read(5,*)iorb,jorb - call mix_mo_jk(iorb,jorb) - call save_mos -end diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 8afa8744..750e3420 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -272,13 +272,21 @@ subroutine give_all_mos_at_r(r,mos_array) implicit none double precision, intent(in) :: r(3) double precision, intent(out) :: mos_array(mo_tot_num) + call give_specific_mos_at_r(r,mos_array, mo_coef) +end + +subroutine give_specific_mos_at_r(r,mos_array, mo_coef_specific) + implicit none + double precision, intent(in) :: r(3) + double precision, intent(in) :: mo_coef_specific(ao_num_align, mo_tot_num) + double precision, intent(out) :: mos_array(mo_tot_num) double precision :: aos_array(ao_num),accu integer :: i,j call give_all_aos_at_r(r,aos_array) do i = 1, mo_tot_num accu = 0.d0 do j = 1, ao_num - accu += mo_coef(j,i) * aos_array(j) + accu += mo_coef_specific(j,i) * aos_array(j) enddo mos_array(i) = accu enddo diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index 04eea7c6..fc23b678 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -86,16 +86,4 @@ doc: QMC grid interface: ezfio size: (ao_basis.ao_num,-pseudo.pseudo_lmax:pseudo.pseudo_lmax,0:pseudo.pseudo_lmax,nuclei.nucl_num,pseudo.pseudo_grid_size) -[disk_access_pseudo_local_integrals] -type: Disk_access -doc: Read/Write the local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[disk_access_pseudo_no_local_integrals] -type: Disk_access -doc: Read/Write the no-local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 32090f01..9f94bb62 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -19,10 +19,6 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) double precision,allocatable :: A_tmp(:,:) allocate (A_tmp(LDA,n)) - print*, '' - do i = 1, n - print*, A(i,i) - enddo A_tmp = A ! Find optimal size for temp arrays diff --git a/src/Utils/angular_integration.irp.f b/src/Utils/angular_integration.irp.f index 757508a1..1efd4abc 100644 --- a/src/Utils/angular_integration.irp.f +++ b/src/Utils/angular_integration.irp.f @@ -4,7 +4,7 @@ BEGIN_PROVIDER [integer, degree_max_integration_lebedev] ! needed for the angular integration according to LEBEDEV formulae END_DOC implicit none - degree_max_integration_lebedev= 13 + degree_max_integration_lebedev= 15 END_PROVIDER @@ -644,14 +644,14 @@ END_PROVIDER weights_angular_integration_lebedev(16) = 0.016604069565742d0 weights_angular_integration_lebedev(17) = 0.016604069565742d0 weights_angular_integration_lebedev(18) = 0.016604069565742d0 - weights_angular_integration_lebedev(19) = 0.029586038961039d0 - weights_angular_integration_lebedev(20) = 0.029586038961039d0 - weights_angular_integration_lebedev(21) = 0.029586038961039d0 - weights_angular_integration_lebedev(22) = 0.029586038961039d0 - weights_angular_integration_lebedev(23) = 0.029586038961039d0 - weights_angular_integration_lebedev(24) = 0.029586038961039d0 - weights_angular_integration_lebedev(25) = 0.029586038961039d0 - weights_angular_integration_lebedev(26) = 0.029586038961039d0 + weights_angular_integration_lebedev(19) = -0.029586038961039d0 + weights_angular_integration_lebedev(20) = -0.029586038961039d0 + weights_angular_integration_lebedev(21) = -0.029586038961039d0 + weights_angular_integration_lebedev(22) = -0.029586038961039d0 + weights_angular_integration_lebedev(23) = -0.029586038961039d0 + weights_angular_integration_lebedev(24) = -0.029586038961039d0 + weights_angular_integration_lebedev(25) = -0.029586038961039d0 + weights_angular_integration_lebedev(26) = -0.029586038961039d0 weights_angular_integration_lebedev(27) = 0.026576207082159d0 weights_angular_integration_lebedev(28) = 0.026576207082159d0 weights_angular_integration_lebedev(29) = 0.026576207082159d0 diff --git a/src/Utils/constants.include.F b/src/Utils/constants.include.F index 4655a4fc..4974fd8e 100644 --- a/src/Utils/constants.include.F +++ b/src/Utils/constants.include.F @@ -10,8 +10,3 @@ double precision, parameter :: dtwo_pi = 2.d0*dacos(-1.d0) double precision, parameter :: inv_sq_pi = 1.d0/dsqrt(dacos(-1.d0)) double precision, parameter :: inv_sq_pi_2 = 0.5d0/dsqrt(dacos(-1.d0)) double precision, parameter :: thresh = 1.d-15 -double precision, parameter :: cx_lda = -0.73855876638202234d0 -double precision, parameter :: c_2_4_3 = 2.5198420997897464d0 -double precision, parameter :: cst_lda = -0.93052573634909996d0 -double precision, parameter :: c_4_3 = 1.3333333333333333d0 -double precision, parameter :: c_1_3 = 0.3333333333333333d0 diff --git a/src/Utils/invert.irp.f b/src/Utils/invert.irp.f deleted file mode 100644 index 4c626cca..00000000 --- a/src/Utils/invert.irp.f +++ /dev/null @@ -1,19 +0,0 @@ -subroutine invert_matrix(A,LDA,na,A_inv,LDA_inv) -implicit none -double precision, intent(in) :: A (LDA,na) -integer, intent(in) :: LDA, LDA_inv -integer, intent(in) :: na -double precision, intent(out) :: A_inv (LDA_inv,na) - - double precision :: work(LDA_inv*max(na,64)) -!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: work - integer :: inf - integer :: ipiv(LDA_inv) -!DIR$ ATTRIBUTES ALIGN: $IRP_ALIGN :: ipiv - integer :: lwork - A_inv(1:na,1:na) = A(1:na,1:na) - call dgetrf(na, na, A_inv, LDA_inv, ipiv, inf ) - lwork = SIZE(work) - call dgetri(na, A_inv, LDA_inv, ipiv, work, lwork, inf ) -end - diff --git a/tests/input/h2o.xyz b/tests/input/h2o.xyz index 99268e5d..e8cd039b 100644 --- a/tests/input/h2o.xyz +++ b/tests/input/h2o.xyz @@ -1,6 +1,6 @@ 3 XYZ file: coordinates in Angstrom -O 0.0000000000 -0.3880000000 0.0000000000 H 0.7510000000 0.1940000000 0.0000000000 +O 0.0000000000 -0.3880000000 0.0000000000 H -0.7510000000 0.1940000000 0.0000000000 From a129ab0c73135712e93dfa73d50c7ac93f0d07c3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 17:35:50 +0200 Subject: [PATCH 44/48] Fixes before merge --- ocaml/create_git_sha1.sh | 2 +- plugins/Alavi/.gitignore | 23 - plugins/Alavi/NEEDED_CHILDREN_MODULES | 1 - plugins/Alavi/README.rst | 23 - plugins/Alavi/alavi_graph.irp.f | 28 - plugins/Alavi/tree_dependency.png | Bin 64760 -> 0 bytes plugins/CAS_SD_ZMQ/ezfio_interface.irp.f | 4 - plugins/Full_CI/full_ci.irp.f | 5 + plugins/MRPT_Utils/ezfio_interface.irp.f | 23 - plugins/Psiref_threshold/.gitignore | 29 - .../Psiref_threshold/NEEDED_CHILDREN_MODULES | 1 - plugins/Psiref_threshold/README.rst | 24 - plugins/Psiref_threshold/psi_ref.irp.f | 41 - plugins/Psiref_threshold/tree_dependency.png | Bin 8479 -> 0 bytes plugins/mrcc_selected/dressing.irp.f | 1076 ----------------- plugins/mrcc_selected/dressing_slave.irp.f | 601 --------- plugins/mrcc_selected/ezfio_interface.irp.f | 61 - plugins/mrcc_selected/mrcc_selected.irp.f | 19 - plugins/mrcc_selected/mrcepa0_general.irp.f | 245 ---- 19 files changed, 6 insertions(+), 2200 deletions(-) delete mode 100644 plugins/Alavi/.gitignore delete mode 100644 plugins/Alavi/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Alavi/README.rst delete mode 100644 plugins/Alavi/alavi_graph.irp.f delete mode 100644 plugins/Alavi/tree_dependency.png delete mode 100644 plugins/CAS_SD_ZMQ/ezfio_interface.irp.f delete mode 100644 plugins/MRPT_Utils/ezfio_interface.irp.f delete mode 100644 plugins/Psiref_threshold/.gitignore delete mode 100644 plugins/Psiref_threshold/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Psiref_threshold/README.rst delete mode 100644 plugins/Psiref_threshold/psi_ref.irp.f delete mode 100644 plugins/Psiref_threshold/tree_dependency.png delete mode 100644 plugins/mrcc_selected/dressing.irp.f delete mode 100644 plugins/mrcc_selected/dressing_slave.irp.f delete mode 100644 plugins/mrcc_selected/ezfio_interface.irp.f delete mode 100644 plugins/mrcc_selected/mrcc_selected.irp.f delete mode 100644 plugins/mrcc_selected/mrcepa0_general.irp.f diff --git a/ocaml/create_git_sha1.sh b/ocaml/create_git_sha1.sh index 7b47e96f..f1fb7fa6 100755 --- a/ocaml/create_git_sha1.sh +++ b/ocaml/create_git_sha1.sh @@ -2,7 +2,7 @@ SHA1=$(git log -1 | head -1 | cut -d ' ' -f 2) DATE=$(git log -1 | grep Date | cut -d ':' -f 2-) -MESSAGE=$(git log -1 | tail -1) +MESSAGE=$(git log -1 | tail -1 | sed 's/"/\\"/g') cat << EOF > Git.ml open Core.Std let sha1 = "$SHA1" |> String.strip diff --git a/plugins/Alavi/.gitignore b/plugins/Alavi/.gitignore deleted file mode 100644 index e4e1a2ab..00000000 --- a/plugins/Alavi/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -alavi_graph -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Alavi/NEEDED_CHILDREN_MODULES b/plugins/Alavi/NEEDED_CHILDREN_MODULES deleted file mode 100644 index aae89501..00000000 --- a/plugins/Alavi/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants diff --git a/plugins/Alavi/README.rst b/plugins/Alavi/README.rst deleted file mode 100644 index f2194755..00000000 --- a/plugins/Alavi/README.rst +++ /dev/null @@ -1,23 +0,0 @@ -===== -alavi -===== - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`alavi_graph `_ - Undocumented - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Determinants `_ - diff --git a/plugins/Alavi/alavi_graph.irp.f b/plugins/Alavi/alavi_graph.irp.f deleted file mode 100644 index 4e953add..00000000 --- a/plugins/Alavi/alavi_graph.irp.f +++ /dev/null @@ -1,28 +0,0 @@ -program alavi_graph - implicit none - integer :: exc(0:2,2,2),h1,p1,h2,p2,s1,s2 - double precision :: phase - - read_wf = .True. - touch read_wf - - integer :: k,degree - double precision :: hii - - do k=1,N_det - call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,k),degree,N_int) - call i_H_j(psi_det(1,1,k),psi_det(1,1,k),N_int,hii) - print*, k,abs(psi_coef(k,1)), hii,degree - -! if (degree == 2) then -! call get_excitation(psi_det(1,1,1),psi_det(1,1,k),exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! print*, h1,h2,hii, abs(psi_coef(k,1)) -! endif -! - - - enddo -end - -!plot "test.dat" u (abs($2)):(abs($3)):4 w p palette \ No newline at end of file diff --git a/plugins/Alavi/tree_dependency.png b/plugins/Alavi/tree_dependency.png deleted file mode 100644 index b4f0df8b656dd6b03f85d68638531ed4f085777d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 64760 zcmdSBi943<`#t&)DPu~83ehAP5+Rv~q==}D$xtFggvvZm5lPBWh6Y0+3Q?J-P$6TI zDWoW~kh0g+=kwja{oTj@2lny4$I<)h@!a=)UFUV4>s)J{cbLvGbtd{v^b`t(N#n4p zE`>tXMWIlCTC*BIF?o%THRa3j+730NimDI;;vh(!)rs*q|f8R^&FbbMVWT=(xDhvCgO4#Kc%_ zY;4}Ve;=%zdNplcLPCQ4lCiO|^udEwH8r%yjvX8A$liSS-aWqcVJBuaI4!l*svm@M zd0dW-jSUSAEzi_TU&qaTJuZ$D*H=0dTqY)vqwo+cm3nXkIn4t7%yJDc-6z>ORT=B z-_xg}E-o$!-(tjTH-$3@Szf<&=T6AyS699?r>aQ1erFRD6rB8UR5VpPS$?$r35WZy zpG@b^pSQNou(A$NPA$K_S&H0SMux!MgIAcRrly)(TdRDjR_*m%aC|*gyLs>a{U_^} zxh$K4@!i^6?=(6sOqwr$RamL02%t-S@F0LsCD`oE4L(j87Xd6M&AU5T>>D@M1qKFg zm5^ZD7tgruP(=By-FkanMs;F0denBcI{BT;qFP*BTo?%9%{8xD&Bn%NHuNTX4Ks6X ze?>rQcDAs~>(wVup5zk}Vl4Z+v}gXuCptYny|-~Q=rzM7t5XY=#tce&)BzckS+mt|VA$+*zYFF1Jh$oqTYEDFo(4jnqA ztZte04tvdc!NaG|XGN}b>H8kUhLAxnWuk0FKH~cIpvZY;dV2cY%Rh{=Op4cccXux= ze2EhCm>*~V#Bg5oo}=G6d(#sq*wVBTgAZQ$X*TjU-XPyPy8DMN_O7bz@0@7XnKB;T zOg3Cx>8WW+U}R04(HGWrS??ZaW>)yqGW3s)F@&l57Zpi+{{Hdeg1!k=c~8%lKCfTg zB4R$e|+L#;1E&O(z@Q5_S>FHmjXyXL}$3zJ`yeeR!cN>Wx|Up?G- zN9@wjVe1PQ2H!+)LmY-TM|0}!vA2x5m$woY6{WuN_m8=`xnDSkXyL~}dJ1AmT~m`$ zQ%kF*%*V&1%=`4{;fTzQKP#R|eyP2_d2(hZ;Q4cLW?uQX=~>I#$B(lHGjjPqe7Idz zRaH?imYzFItbp9j+M1dg5`c_MOiqK(@?;PmtD?DC2VY*` z{yIFaV69%7rjnDB*!<7WjWq>S!NI{@FD~*<&&*8Cf4a!P9rEvMGfQxLmVKpO*dGNm zdwXG*yX=h}9qg~JOw^w7`4fcrIXWu+pKr`8xPPC&=;cd`wv6KjFC6ae<$LzrPcPl~ z(+fYf@WA>>#x(8ZNQCb8?b|1FENV?Dzs%x|KINLP!lBFcT)fo&R#Ak`)6=)1A^1$0 zH}}FI!&ZSc3v-=m$v#g_%l&D!x`*`7cm>_Ox!$fjKU3q=xvcB~>c+O)nmen0_4!2o z>h)mRxpU{^_d&BP{gdQf2z zGPAd-N18264itI(5*h#T<_1&m z#dBNa+)s=OL=+gAn8kO?cr8gR{hE0Ck}J!Y?(IDW&BWD*w>K5;krrd+l-sm0w83mp zHN|J8+nW`OsjX!%D28Ug=5L` z**6QhY#ETB3tYdx=PoKP&PFMS_fAP#Kj|JWp%CWl{pHKI2`uUZ|?kT@>hWb-s zJA0>8UzV5sf}`2D58cVUuOIc~nwM|BNNG*)WbalA@IB*Ab?H*V{PRCiiHVyXKEHhQ ze_!K-p3;F9{IzlW$0qs|7AVavHlCvM52Ad77;Jsm!>Po@`ztIYEmxbJ zr?cyt{N=3h=Y&snuIlvi;^vAEAJzv21!X*btozNAQ%@gDVFMoEfpjBSlLf?3EoH(7dXVLuf z$L|;VN8WY2b+Cpd{CzH$;_$Iu_-Jj{a}p^xQJ5t5?~lH7r*roD%9Of2%dL#RmcQq_ z`4_8Lv@d>n%T@l4>BbSi9Y-%*5my+$cZK5RW%k3!tcl00rzmYjNc%=&B7?B7aQnT% z>bQh2)IaR@*yT#LT$o92AP-j7z-f#cl;N`Z+ z$%5Rgv-`R4bypl!Q!9Vb_xF$IXORxNr}Hi=@;9QXR1Z-nN_8GvMfuvaDl^lk?Bcv# zN`C(3&fMFl{w%g{oci#AW5t9i^x8G$C?2^JA0#d9sW=SM3Rg37`s$@0+kZO1=MU}M zA4@ZhlYhI85nR{$z4qnwH%Lk zV!54J;_FN4Df8iNX=zy(UZY%R({gqnm#myzOP;0r7HLOClDaM+_g|PmiBtFVls%O> zUFdYdVz?o;$aRcebWd#p17iORbSyuiD%0i29gaBwGrv3CQfD@@Y z0)dh3<3pDYunQXncAoL!uBfQ!D)Erw(63G4oZz>z@3<{&yw|ovXmXF>b;$&;YS zNBaOQ7N#3T2Y&vHoSwdzUIVkcNIJDYO|?} z1W>wI_GdK*2Zxa1Gn$oOJ}V)kqt-5C9a^K-5t;k(Q14nhI%=PtYjph4y&urbaFfP&fWvzL)^YC^)M@t)!ha_+O`4>e+%UtBzcQp$bwjz~~P)r(Tgi2VmdawGmk zoe->ffA65vw+}lGKho8_E6oZNVcU_VkTC;M=#g_Vz!lnp|+Jfk8n7lLJ*njsw*B1qEUj)oWhQbr=H@T0cK;5z$^pdpqyE zj;^jh$~*a@5EkA;$Br=rw)PJU`1O`}R8>{25)lz`ynH!0FV89F?emO`HBuLQtLMf# zSvPME$5P`6-GBU;o}HbYQ{GcLn1weICx>&>CdqnPE=$o!VACdzRGt3s?N34@BM-T_ zNW4#0h(ees?~I|M0GBpr>h1b}YhFmZc*QNAzcJN%;S14H_)s|5t~R_`bTDhCh1E`Y@VPr%n-EUr?~$&fb1t ze4G(q?ee`XOnqfv$2Gu6&8=VRqUb2&y(Px|+attI_In*gHxoyXzrvps&MTw2Yj`VQ0WZ3T4~2 zZNtv)?(PdSO$sg9#xJaz-f-F)C7{>K5^ip5tHzHud1gO+_^@}v$jIm&YnWJ?1>jPi z6^;b`l`B`Qt!2GqH-xE9PEPuUhaVN+iB+S=swHSRI!5jgQ+M-oD=N zrdVylre9`UwucZJ0dy?EX(N5--`HHZV1W+G#Dq&v92;$Gb+KfQedtp0^p#?h$QQlt zN6S@7WSp*!*#8_$gfsl${(WjnGm`Dl@UW7$ws!y7h`h9FIXqu{QWDRh>zinS0<3Lp z%x6bi$k(diYc~Kly{3xSTph0&EY*8e1*HW6Wy>nw5qK>;{J4?PwGSV3Z{50;lAF7Z zg(qmYfB=Qk*4CDC`qgEM@3Uw7mZ$1?DLNNZVh(Tj2TlQuH#ai_4h?XZT5T3lVCTtr zJFo6deZ7*A(WYn5p4~tfy1eW;G%~`EoaN@`)}Ve`Nmx+u!flh<+S&$xTO>4310$o3 z-z6#`%(;1aenCNM&xih#EebSL1M~AGdS1FRpoclErKNV^g5b~3uR>;LT^>Gql=|%1 zdc_|*7`3#t%r9J^7Z(>FZgP!!$ukmAqNSpug0xWi?*NV#iz8u3cI^?_y<5q~X7|s& zvZtOyU%z(#F8O&g;^oVixdjD5Xg9~l$IZ^4r$Z}_oQr?Ey1V7C9IEa5f==~<*3OuL zrMa;p&&7Q?XUcMfGLQ~*BL@*AfdK)lwrttboM&05&U5?rZEBxuUt|8$u_H43k=G7u zXeeE}v=8an@z>AOxA2h+ZkLn#c8_#-zr6h88lI@Cy}h7!@nuBb`6}Amnb)sfqcR4Oa3u2G0)L>*M&PmMOHx0-(R5 zu1=0>J!iDg(BHYTSh$Zqh?2xWifH;1mVtc$EkyjU8h6tH?~H~$4xw1Lr<2Lze?U7pd#suGm2vQVcm z30T9x9VHfvq(sBIe!aiX%J06=hzM0Yv6y8oqh^A{S~Q@bKLk(c==cJGac!1zs0IVn z|MhD~ll*T+(lvq{sh_I(YxrCS0C8#dTfjh7NEOJ5bnWEY0^82L9`kl0IrhG){1w=- z=o>eDV|HniK+uIFZy6kqJ9reR@S65e? z0lZ=XLYi9)7zT!igOEoDmltOQL`6ehy*db#7>omx`ao=6d4W?%FFr7kCStP`b7p3y zL8<2ftM_-;GBNe0Sw^Mn2oQ`!FmeD6^5uzMCVhSVR7#nxyUcparU(WhTU~{fWpUh8m}uz&websw zpu)n!h7s4<(c?6$S1WH{ue5#r09ZaHa54kHN~tO#7N1|bHW+^>I91|4R|zU9Fp_T# zH#hh4@=VhLXt}U&t?6H0^m%U}R|t%%c(&6Si@UJ6IDm((MsR)qq71)aeD0owA54?lkWtb3b^@-|t4 z*S0f9?d;j@XjXzEs|+3huxKGPQ}GO_tmO!r#JQ_aP%EB4pV^jv<*b#}eVn0YAb$iA z`lil|c>gG1?w=lR^o$kl5S$dT=-4iKu{Q!ds9jfX zY7L_ms!Ju1_KmxDBS8L1UPwTxz-sYJN$J;oGs?ML#E8@+>Ch8OsJTyt_M~MyZd5D9 zXFJ!CZ5*<8!_M-G3Z+qjxd`rq?3*@inmcqK*?aKJ$`VJ~v3vBQqN0qOB-Q|w&{7D| zsidq-jZ04UdQ8ZA{) z5aH%$&(eVCJ?Bk1tf^UzA57KnN;X4dF$zKjJYmnMB+m;*eA&8n>wMM1+0DT$Ha9mb zYG{Nt{GH$#866Ephm~dgBIn~seHQ~?t*MT?y9^Zy{9dII7GET9-rw#a%-nC<+HQr0 zBJtAF(X|3{$3Ff2`*%!G5bef|8~1nh#-!EP*QdUDbNEAh`wq(N@SQUsS{|s|bm!Zk zKU771rt!sD5Rj0#g?gq=$pDWx+pd4+xVbqWupBFee$ASUI|mgM&cv&w>gb@5b8&L6 zqbv=EiwYb#5YNmlqe{sDIoq3-SjGBWE~kGs0==i0nE=E;*W@q(7-eMtIy;u8{X zDyMGczaPC#UH9_k%U}M+B)mb8t)-l^vXUJ0=; z+oPZjRaIR^-f~el_kTen#8lWBXM-zIr7SNmyU&~wV2jE>kI%7O`~)OzUI4k@77YXO-mBcxSlS) zq*i?VgUPe!&(~7!$+|r={My(x1K2hm1Ra2iGCMa%du%!b$?5F*^D2U|)D#N~i{=7b zeVre*=StMg%*+DpC9D!&etDmkmNu7WKPq3yB)n_Gh7I7yWnH^Nl7VOUiiu@jF|6Pc zw=!E^m@;^7#YFPmF7=%2`!9<2cMlx4cRRu-r zYM(s0QU1@Y9$=LP@+id@SmHhq?4DCu8NYgwpR-QCI<@#aK(4g*SgWq)J(-QD49KLb zCVw5G$bI2*V-Z^nYwIcVy%UQpcao6=tO;JdEqYbfp8ooYx{P%Rs@Mm^I!NtBL z3d9RG-1O7q_Oh=TLqkE+3GCVx5_%!(M?zfOji{(5y_Kj0UC=Dn<6U|0WVCCOI8al! zqx`7wM~BXje{9W~A?iWwsz~G@ZPacFG~S!Utr)XUzbZ6kec}uSWYd95+cmbYf0m#B z@JgSTzM*tzXrcWlv>$=sS!Ua8jvPJuEnKuz$0|h?CWV#P$8n4pDK}7og-^e{W%VvW z4VQa}WWVt*OXsh?mA`i&)v2kfN_>*#@?iDcv8&@OlJqsu^vJ0whs?q zU%$TEu77?CA!xe~xrcOrXjMp@TUuJCZWG(DV_*=fZ|X*S?%X+`*nzS=9Tz6I;wvK} zBGv&gq3F#{^zi~KD63m!n*jDAN!*B!55wg|a=f!2`5*{h*Lg3)Z5< z>+aG{QU!qt@&F4Wl7bwFZy1j!RWS#jS;N9YI7Om?dCs-#N8O#S==$>J>^`A0rCSi` z0RS$9W`w3l0LWX=46%E~#Z|x-j=W0@@%cNGOo#|OyR7Cs1BNRDm9&Hf1Asd)(v%#9 z1yjU{;SSIHT8SniqOef%w&P;L#4jbd)oXNhtrS~7bRHz5A<(l9-#&1bw9X;-ga zZBXRMXZ1FY>h$T;xPy+fxC5nIv9abeBkv&5aHBsUX@*EAIQT(Gz0Ff`^e0Z8viSA$ zb61hmw)aVL44_or-aW9PHBBo3y$hkQE`h4=7cqSus+A}?05Xx5)x0@Hi9m5s^Q~vE z_?uS}UMxw@W3rCdr@t%Da$T4z(I02OwSw5%4FG%M8iGjd!-o&KmUYbI-31Kj$&h_3 zAeo6-z2yW#2=zFSt!ik<70G=t7%~$Bs=o@m6%=EUTGN_dhTeseyqE+%ji02X%Wb3576c!0k5H_SJu&42eFu+ zG#bd^9fO~Xo#~+JkOl|D1E@7>ECO&fi@d!2?)1=!H(Hp|Jp@CrA}}n{~s6075pz$ERMI=*4#` zA-oas%zO6iN&WIT==7zh!g`&j zr)NrL=5800S|dg*$H|!bvqdi7*7I-MhHl6Y$Axdt9tNmjHfzzf7QK2!7(qNcQOT3( zr#VqT3ExecQ1nJ11NlWnn30JozQ7MDKo661b80}Y046LV84+?sL%6(8T-<4K`W$X^ zH}8v!eZeLoA&^6$qVdHZ!M_7TLo`sr0n#5JwwgOTIb=$Y!~zKZw{f?y;79m5jdcib z-?@{2|Nf0=-7NArbu&*CI}PIK1MSSnd2@LjG6CJJV`>@+TrU`2AFwj=_3NI#^A;A= zn>TNkmX$pEXlRZCiGfe*Bufdm?zkZ=vjinOf2;RI+hGBSd+3eL(B!trTO zJaqIZ!^p@8l1M;mDj)vR%);XS^2g@pbpS+&W4E6b`l^92MWDt#$j@hc^ym>zgc2~@ zkt0WRjEo)&rLpv7zbP-LaLc&(Ucb&nWZR`#8_oEAw15Bp&3*nnprk|&nsBm5yjX2g zBuh%JWYgQXj8;}w896!R9GP2M2B80~sI5J;m;_z}yvsHzsbA4a7N@872ns5@yDx34 znXIty^7r@OW#yK8UTA&T_l@?eR;}XX;!4GiH1zR~8yXuK3Ho?XN;|{JA-_DS0yN8v z#pD#TP~9LR2a3j#<+d2*(~FCB2Pa+=FG4?hAH7D)JixWeEW_t}9eSkgK0XVg^8iEW zDaGB9#>&brViJnJ!+fAJsO$OpC?j@#N}Rlx3?eBId7g2L^g3u>NZ*>-kZ1}Ffr8^? z-S)wS5aK%4VGi7@tbTzV0aY8yx(!Qp4GIv#RfVYHJBTX28=?HPbV=~oJ((b|yD#D) zqNB7{e0+W$3@}0a<_J}C0bvkK_U|7Zz0;3A7MnrNDCiD+|78$_>XBP2K%t1a&sux_ zUHnRZ;RgzeeFHjXBE`dg@@4$vbNeO!*@T3I1xWvSa8r+n|wfjZw;D{vpU6iBBa))9F1#s)nP(EBJ9)o78Xe!S?j0M5XD zL|>iUV5t@Ek*k@#5jKs{=2X(Opj~`ZGq?6Xf5!lYS<0cu7xarmU+Hyx2l*I&cM6v% z`7{4Xb|EZ}qZ*az5vYRu7yC+Y9NsQ{<>wZnJEv|d*o2!WNS4LhVw{#RZs*bAu359D z{05)OIv$?)Ql>t~{(S{u$e4nZ{SG*fm;pz^alu-6vG0B7Cod(0BvEca@UftM`=_^s z<(&#pXB98dF)@ii8+2F3l^(rd6-ZD%m+b|*AVAQV@yW<+BEf^K9u!$^5MC!|(DD7z z!-wU_26seGS5AGYD=vCWA-DE%>W`V>lgntPp;;X{5C>DwF=cgKW7mM>o}M0}Od(BJ zKyi7!IVrEMpGU~HfCwifDWfVONe&KnYmybaj^`+lasB1Ugo1-zA(RLxOM31nS_2i@ z5ppEKKSpb{RX|`3ps6sL58wT^9g0Hi4EV_49tE-av)I%p(f96Mhu>f$>HsMkFfWL> zJd}*WhR$D=eG^tdkBW5_y*t4quuFk^15)|Jf@jGxhomUn>$i#y3cZ5M&mJx@F)AL>!-6~IuRpu*_3xjr z7G_(u^DeXt5*`8sB&!U&Ee+3dwSh3QeGSOuayWhdmD1jl#EF4!`l~v{d#k>!3OuMldU*Wfsxg54TvWH$FD-hz%b-lxA5bz&@C-3Dc4yD>PRir!@7l| z`?W$_^9T9hZV{0~W@cN-atj+5_Ct9H0cS76uE&Sx=w8n=R813&^xSFc!4w}KFO5#q z)5{A{lMrSgG*Y3RrL~TgbuG7lfiM=66R;aTBB#lIB`mMu=wZ#RXj-ZkroIe7vmWAhg@+&}x%o;o zB>f{J!N95V(?*}=OjMMW9dVzf<9r@jFDtY+OWKu#d=WFRq(KnMPM3mD^@LSRKu~b~ z)*Y7D>priUuLQooPV_Gz89+fGFZ611CN&mfXmy&ijivlzo^_aE+Z;y+) zSpcpA00PQ23~il%&)dJA@3tif4z;uyCI9WcgB+v|{-?rQSXxf~qe5fzR%2sDhvquZ z)FEdc*V9`?0nh^p6{MW1sHjN6x>KRx_~||C5R{VQcv|*XCdaho8WBT3T`W`ktbaQ# zZRbnZv0z|&MU{Z4%Xzm$(B3-W$blxF+}0FcV}TekDZUiskux52QeWS4dZ?acNH%)4 zl1?}UbKPdF(9xbuafy(FWo_OB;vv$-ja#>9icS8$83X5lE=BR`Rp~x~dnGp(7Ou{I zZ)d=hMzI-0AErU~4@efG{o6vAc|za3=^RpHk@MGM0W}*lgv*hkbeXSOjJrW)Aqo!!7>t-@3Z(9uN6FP@^Za-;Pkx#RH=*T3M`bt5-<1Dmj;k;93}!|em# z45ChhcU768JC~gVGLmQ{=xYeRfbNG~f*&I4wf=uF=>kY6n!^nSRaZI0Y$XsCJaX>+ zkOCU0pJZkd6#!J_0DMz*fZb4Xb~);%MWR`E>My6V`&7t;?ZOw%NzQ&>Eer9ZqPkkO z{9#1JqRWO*DyP=cA>fH#6DY^Gt*RfL|H5HAG zH-pZ`y~IgfuXh;Q+f7H}y8yXtEm!xN9X}T%J*0pqW1ecb2mwW}O zL(CPpp3<2!yyza7auPNFIQn@VL#(`MY}At{A|6T|h!uAQ4&cXRfUL**vJCX}fqyyY z+Pn_P8U!Lm5>gQw+4!dyEO^}9++0Oa%jA4^b#;}$d9wzfv4JjmwkaVTo(I%8a_h^; zJsDY9fjE_?vJ9x?Fb96o&57mP;IrsD<%3x~Chx38~&!U62s;Qy)A%LBJ6P_`9hj+v$9 zDv*fs>bK=iLeWKx64Dvu1n6vH7648p*d1O5xQxFuIquuL*SEO%05ZS1g~jxnG8CJ= z`}QfrXK_oRGdq#xZx0&?m*a+pnI_4bmWr{-#bUk9WiXjF%;R(j2??2*n^WP65JoE- z8t5TMjdta20|V9H-(UW!-q=@C&kSqn1loQ(RJ`50*M9rEE?X=(hx$HY*Ll>>iHY|d~`Kp`LgjrfeM z>8Plnf|TeV9?pQRG`o0_CHnC8{&btoZI8>@IXJ!$G1lvM;jg!judcA5b{{@^RL}cBoBcRs+7ui(W6KEwW~KBg|h@FnW#Plt$?v4j|Onw7<*~J zUOD?&`OY0X29V1TlRAGBZ{2z*n+BC>&8}U$hVM)TuoxSEN>9?O3)I)qN$EN4z5obv z|MjGAZ0tsq5yBo1m+|oML@`R3zk7m5;Sez?2g?~71xiL~XN(evQMA!0!&$#pIvyS6 zkUyJZ0b36iaDH3gJ=ndG@cfaR!H9#nh$ZM5CyAcBjs^6f z*V3#XZW=PRo8^mGIJ${KM6`M+(x7d=fU-mJg5x#>w+aGrFS09-&K##dd)Ls=*}$Nn z|Eli@4_$UW*f$oImPlI!b$?J)dA{e`wQG)Z-%qL@Is`POZ0G_>zoo?E3K6BSZE9uS ze-@Uj>oBJv?J+Mzlsh!beBkAg4tslh!GzSnn%MkAU-ak4jAAS_DZ`++h}ge4^A%!0 zQ4*mh^X=Wc4qrI@rD&x!i?$Ha0~WIyqKXr&kHqc>QW1DV1sA+!tm?^fJnaZ55QMPa zd?~ua01y?3cxF&eM6@NIENnLe_emYqK#+nK_@MOF$*q8Oe9?#dCnlo)J1Ouwr_hN2 z=u1Ou;3{;4)Co9nAKet1dYay=Uzipa7V^JYJej6WL|y>HJ3uBGz)Atzl0KRAJYbbZ zKfMtBwJEOu=FOXqkaq$@LcW0WhgT#B#00q+)Qs2D4SVdZXl!AeBoG@WIsO9&xbRF> zwoglfQ&mFlBWE$0GQ{Pf+M~VT+rFLV_pb?Jw3KoEPB^@NxGDn^6BC`GH_# zL&IdFXc-|%i@=70*z-q&N<&LqP%nCDeh`xj(WxL*Mz6lR zUr%ob+VStwnCSA-*i&hzK^hbsvCHEI#7z10_4KuFFTT9OZKzLlEIif31^+-jsuBkX zWQ00Y%O?uGw@}7-eU@24S%DU-!+6HJEn6bMhthLj&y1e=+VlmiX$^R1UXBjlJ5+{W8&jA$Sea~Kdh8XE-nwz zM(QXj`8BsBX@FI`&a03Fg_h_fr*cd*Q2o%6UC2pE@h$zkWc%#Ji(Nns?hsPHfpbx= z(~bWsm`fkzj|O!2)~zreuol01)rvy~8sEMFdgZqmZFxQnh@kqWfMaRJHU~z|siHW~ zf)fGb%?{qJ1+l5IGiEJ!c!Aiy_=w9tdo; zL{h3{p5(EeF)f&msBdVv2615&tFgRx} zxyvflh;xvEJTNpquE`;4$|j_4+hMfAZfyAz3IcEqKLZ1U%%vfiicPyVFxY`21aW^e zCr88!N`}Av^^lN|R4}3+vE~J>J}-_5H^WErc+K&=qI0PP_HeZlH~` z@6Oj4l@=Y!qm`7Bx&u3j63_`7H}~he@jQ*ay-5_=PLUkkLFU$$naqp~>uH5$;z#7@ z2Fu6uyA&t%LT3&)RSL56&O{$Qy_$XN{gqQw5ZX6@i~sbk{5kWS`^*x$5U5*gyFCWx z=BB{ZuBB)^(j9gNN|%5rORf0iRJQxs1lDbbn$cu$mW%2rWfnGk7Ko_+1BG*=OoOv+ zZuzMbCvJdF!wJb#yME2(^5wLz2cDzf4MYEQ^2X?5<{%3%W$s&R2!3tH&Ykkp?f_C) z0NG!c>>RQe8wbpZtt6~w@cfd$r|H_YYagbkt3y)JTYQ}q*x7mhqTbG!<3OcvT3U{u zo3YlCU+7=;p|dj`cAz!f!^PGTE)L_^(g=VEJ`8a|cF}U{wto&dqymNn_%SH*gAgXF z82BsE!t=PoBPeS4$lGX>T6#rEGqSFIbTf!T&8CbW~imv+BPR!GKHY~v=MR8&ElaNm#9f-yj@bd5+qZn1^xtg9y9v_el3nho0 z@}1i@J2NvCb?V+utprt+%j>2)nch9vpQ8e*%t6ejwds5G#gFiOMF8s?wcXLZ7oy(< zMFBZiwd6dAB!TAHCn>p8U%%5m zd3Zn*MREsH_^{Z^{}?>x#f6h!o0fO9ZK$J6umk?v%&^Ao+Nci1cJ!4fi3xVX4lhU#O!WxwdXk6ac50olH%XexT5 z@1`EU2bIsdJr1T1h>6iF`3gUcAq*wx zo~DaK^dn!276l$*e;*b@--b!YlCM607td2GGO!D6y`L^RQJdcyH@q^r&%Ij$d5E7f7ugQ#qZPf)*xcQq zG#vr-QlT(gW!;>oW8_o>nUi#++xyh(Qh6@Q_nu<$9lLhv0qX_@2Y>LGC{c$u1|j^~ zorC(g09#YOyu__n`=6=+0;dC`oor@o`VwuKi}IfR{pT#p8SB$%v(dGK0g1W?AL454 zIc>XxS(^vUThtUn^72=r7Evf*7AO?>FV7v^w5cGxsjV&F^fwMHW~#pAS-smNWL(II z9ws9*({1o88T|NPju%Ee_jMEcxp?>qzqe(g*Q+A4CS6?yXz!Hyqh&8Az{^CrIu!iz z&(ho~%CJ*ay6}HjCO2Kn8MBEL-|Xz{OPipIgSwjwOMX?{F8uUmS$f(jUES#(AE|eK zot;Y<)FM+lm?tF0Qjno_IIVf^bKl+Tnt4qf?CrS`--n!>@=~~x>bB8#pgBdes(jW) z5?UJ>=L6BhO3QvW?mBRwxOc|&1-sq2oX6(Y zW0tp9s*)tN(4108XM4S2_bu3D&YnA$IWEEvYMOM&8lRMH7{jdv4O5dtW#amED9A>{h zNmTz_2BO)|&yUDF$kHvO^Yz%=aJ;iBYmBN*LraTRr)<~c_Ukt3VvQ^2+KIJ|jSPxE zE}alyYv_b!8jIm0A?V?p(YO!R;@JENI9>sVRd&W?KKwIs|L53P3^*NXGAhFJJE<_A z8C>ocK$V7x+oy&HylSy$r0xJQ*-igx5p8(?J`yKaPz$X7TE&tL3kaCCzSCDD(3ivC zcNM z`WXQ5fc{?xUFRQ2Ds3Qfs1=VNKMp6i94O6glr{w2ums_%UTM4;zO+wFjE|Q$`H*NL zV5WMcSCX`oKcyLL_gG11Z7s5#n_Ka8F*X-fd)wyCiSG7qljIVY=6^g{j?gyl{m*(0 zoSV(J*|%@sVgBfK6!+m+eQWIG?8o!TEf~m7oD)2xt&5a9KR++wwd4}}ZrlF-v0y^2 zaef37)h(x%mabxbXnaxh#)QMs7GeyC!^Va$Jwxb!yZ|=sugbMC%uBTu_i#vbgR5Z( zu@b>j_z0h`*eCmRbrW?TT+yKW*qt9A10hZzRr0j>JcfiQbZY3}X*F!vy~b71XH2 zym_YXMe1fLKvuG%(A%2rb0GN}31ex&CWL(KYL=RSB_#${9yc0dWY>7nyH zA2S63E#MhJS8-%Gp3JFX`%_W2W8Z&ux{6AGgL&N1G547kX2A(WfPEAQ{yxC#OZU0Q z(|@o{`N%HAzu|7x0u5_#!F@zSgAd}`5(cPg8z=cyRhcH}4B^T_YZiu; zGq2y5;Z`TcR|*9Td_)A}U0JvF0F^4Hrb*>%4Q-E~K7Ab>^H%iG#4Qiw+6kF52>&o5 zf~#3YaL362_GFHyPrs+9q)-q%0RYahQl&n5vd87&`Ckve|AxU8;_!X=igML@Ef=gf@*2juJGL9Cq58dRM;(DPI9V0x{c$Noo4EYi%Mm{bzpt+C|B~I%P3T zJGGIX_MU=I5?VKPOrWtz^VxpGv9qbaxr21NV2AuoUdscCLrtlNi@4c%By$so!^^HTP!+sOIw4pd%GhX*%a)}Hw{{49I^SbHB?%|}}06TP@OFS5Y zV{@AO^!OqOpAX;#G-YID@}X8L(S>53pan??4MhuyS8h6ej@PA+L$Lb^u1G^{;f`WN94iw`lZVm!1Wc1&@+;=Epxa{Qq{3bn4i zOJM5Z==X1BCwNQW28CX0a5S^>=}4eut{NBJ``&q8-eW@Cd->{1pB4Ge=pkY=gt|5K z^XD;;lKnEwRr!vvA(1qM!ny=iq$sl0!KftR{c|$F0MFe&2^lVEkjwq#T@FBerYmRn zR=Fs_not+T8LsUDs-rZ z6dqJ(@E?S~2D9?&XRNc)%;VVN)Kou|A{CIM)n8|9@J4|A^G!VN%L`5(Je0kf>9hS6 ztCk>T*P}C}p{9b5>^i0rDqOQ9i$U2i!Tq)1DIXLV*o@YrD6%>u4w`N_f!dz($(SDL zN!>s>_`&v!t1)N*n4_$L;vc4_DiOrwJfbP%Jn~kL;U!nvo;|yFr=s+S;hhP}vOG~J zKg4@^AHwDM35zUcp!vSWmgv`-qTQ3WI1)%D=762h`hYl7 zfw>0Oj9P>WncZCMZ9HvgXD37wGNI{;LHGD z8iWpkyzhXmgeuJzy?=T86MZt41e}Q3j|YW?>|nG1xd)?opWb}>4i#&Q?A3KZ^W`wL z!W9t=`j0#t@QHot%k>X7p&epnXAdS1RvE+qHh8o(odwz77d;SUir}%(yQ4R#KiyU3 zSHi4nj!CgUoUw#*#melJlKLOw7*M6?)hiV}z31B=hzX|rcPbX^N%&zh5{p|SBe9r0 zhvaw-ty3l9bu8nazvfOA><@WTK$fjLcF^J|l8>P^4ghAWsHssKW>!3L51&KQ1iu{t z;bQ;@HX}Pb2>G}+k~?NkA2ap>Y>n9;~|I7o8x zMilUy0QFAXu{P>xDZ%}dXCM|q>;(`E+^iOO6$bo}l_<0)3)7c`?s9aM#TSW03Z(dMcz|{*n%px6?X?!ZYw|51B38Ne`SbU6z?gZpcBmb@+2_Lyb7Kk zguo!+J1!ES%I}9;Tb>vg86jip@Eztl7jJozk)a6AT31hxyvzuglOO5_8nEf(sw^xl zL{UJ`iLq-dx+9{gN7=g0XJ%#DwK$`&k}*!?>XuncE{s#Ye}Bx>F;N~c>>!vkDkSho zANn*606O&AHy|b=VZ8~r0Sg5M@%WiDEdBLVvEboB{z32JU$KUYm#Xt-O1nZrA5t6y zc+7Sl?cHz$GBB`#@2&?7SRF?fmq5Hq26CsFtt|s&!}%9>yI_O^k37Aq6)*=h7K#TG z3$Hv4g{(|{eP)dS%fTJLmR`E}dEH)Gawo#DT>>2}tD+_#DGjgW zWMtgnXogFGownfNLmIeQ|H^vG^P-=~=4pn6aUbhMW|ThNQdN`lT$s$HCR#C)Dmbx5 zk5WoXb~Y1Y5EA(t$Zb}5JyZ}3rtrvg3_buS9HLzx@V;9c0_VyMaH?l(A-AkFP*d%|YSZ1E}vkwP-js>60v}iG+LRMFTF(O>~!(Alm z*Zmi)trhY1EXYz29@ed)foC@apT{c)QsGTO${;3yq0nb(X@^XOFk=h6wKe+iHj(6Ju zIgM zp~iRNrAOd|1JbV@X`O}?Qn8udwcx~iFlv6S8!^7(1QSd)b4ZCu z^x;5-zY8RJD}tOx8tpD&!qcE&kWnHatqL^XfEiVWPPAKjPg}?x9dR@8`!R@h>6W!y zeugYTrU1zJKU50!%a;q4yUpXi5}XJ4PTuozSHXt|1P^hKr^g%ko$L1B*d=ld)rwE9 zYbOdT@hD<^hm7IjYz7t7?0whX*=dQMfk>L*?4$4ACG*5NmQ=o;%G*9EMY{2vGJ7Qr zBMqRFg7a!;j{+x{pYSdfGaykoU``qsGp?dwwvN0*1Pr(1Xfq$N>>%z<>TX)f8KepS z_Yo9Tq2TLUAH?4fPc4!O=-K0^PNg-^bGC1fsV6U3BlEXJ$c3z#rWs%9nw6eQ-I!0i zC-*eY6%R$gC9Wt8(I{e4hqreNOfy5zz!w=ZG8bs}fOsUxO_W^z%%#Z8U)oEikrOQ@;FK}NFLttl~>5*2d9S7+eWmyg`e;>Rm%Y$*b;ZE0a zYnWcim;*5M8hjB+PkmJ1pgA$mS+CoUOSIf z%85H{pbHGe6m(EB!wn>ZfEtp~eP#A<5BV&1G;_Jx_;LJUanRgS>^a} zvHc=>XC54hk9Ox!$i;$7WNs;*7tE#X#Zm)F4J5BD?{aZgrp>KD3W&-VExcS2^e^J$q`E9-^?wh z;o0HojWd?T3^SZug&%s*;uOo!8KsM^g@x*6MdS;kF_+hGoGH6n# zD@`^Ar{oAqKO41Qir&2tdk4@KSC<#Wh;sqWVg!#|!q{QWgVsjg&Vb~eQ#Bk5on?O? z?UR%F_se8g{S+x=h?AZD5?&J}%fo_BRSlSje8c>>A%Vvxbrz;7t<#$^YYr0vab%jP zf7kgJM1`8_8mN+6w`~g;<7}$_GWE|nP#L(EQ^8vno)awGYyUFQGLWr0#e?*@d=_c; z27V{kV}Y(t_EU9=B^}+mt{<8fWe>x3yaOWnmE!)!>V#Fc_|=rx!D3 za2MQ5|I}4-dTQviZsP42KW1s!DOg(at^$%p&`6`H-_#i$$6@U~mk7@?AKs1$EqhRg zJspsEPtIG0JnARg@v<9~k(M1IT(jYI&0Pg~CEpz8_(`$KoV(@>_r0Ni32YiEjfI?pc49=P;i&lj{WT!D@m51xqS=I|(6=~uE(jyq;C}cp0RW-HL|vE5Zt-2C<$n*}O?l;`X=Ug>wgSp@!L2P%%Z3 zGe#IpFSFfpQ-@hp>H}}TJG-VM&{87qeDayM9So%UHP!9#OXgH$TVbR z1TKLpW|M9L3Ssfce$TM*`(Y)?_9ukW7|bRNjs!M+ec-e5mlUDS&kV6>^qT3SDfqgs)uz&ITg*x0%e zv33@gHAjqw40r`ln7+_Vw`+NeCwAM)S(|WC5m!rHHOl&|Ra7jjKY0{X$kMB@ewzJXOz=3kY z$mj_67XP=F0@tT5j6j{N2k)Vd>fudm^<7oYUD2nydJs_Bx$2`|d9e zGg(Q}T9gzRUHbZQH*d`;~3Rg2DJoeZd(~Q_t!Xmr|3rV!L|Z@~3C# zH6~E3nSw?v1IuHbUmxBMhK^0&+^YAI-#SB34gZqPrL)i-}6uOqpxTW`-*9Q?9ZB57o+ zYSYhN0pTSU&ct71uKyWsaksRx-}*mmnzqn8(6;FI*hc7J$b>58*l#n`Q#apz4uPLt zL`o&vccYFU!ZWpL10Xd&xXc;&>j3QFrYaA281+uXMC9b?sL@x}Z{51GU-p+2f4d$k1JpiQD{TROX0 z6-VIsMZt;AvP1OL{qr)>Puu!*zfy%G)@aq2fGgKmY<-z}lSU3S(COOhmsHi$tZ=@K z^XRDIwbZ=|RTpN#)*@OeTfFohH+z<5fV^Eh`Q5L(i_^nF}%Du!F1$_p6;t3e(9IxOo|DZl_n&FT}91YnGL z7fnOifaQP#u#mHiCL*<`H%45IW73B+ft-uN;_i!1P=T=7A3uKFtGKKWeJ5J%_}lsw z(Q$E2VOT!xo7$^>^TWx>9k?LqBYlNEIYZK{f)IIkKdlPgB0_%jA(@?g-qe%djt(ltSsO15Cq&PJXA3iK;ZDJEgG%t#Ej(+s_ii7)e-Bv}F^I;&~GryRUqX7%_ z^G4O%w{ImV5K93-36Kn~x32gCL}-sf9hj_L`}Wf8W84K9O}%$d75ORHSj_px9!}yQ2?bQM+A^Gt;a)@ zE}X^#Pnka5A1E83zbmQ>q}&pfMBXM)8~j1z!Gj00&5QSppT2({u&pU7 z{$J1gQV8R69fMZ>)bk$-^|MF!cI>vmx2ylOKI@4MU=FQG4wJIHSKQvv^Y@=j0KCH&u!;6qE z{xJwFDU@SZ2)`1!9DmSPofkBsuEph#Vi!=fG z6%vJO!FgNr&uYsmAThaA&Yx7?w=QZ89aPIp*X(y6yt zMvb{nX|OoCa+6iX69ps1Y7ORqg~3Fm7m|WzXdg=dEt@FU5D* z)0M9@)#{h+-@-N2=?n;r`eIMc>#b#;fR4HAYPWN7Zc|4u|c7)1d> z19_KqwBTv-O3J3&d3n2GT)_ZG+h)AoNhr%}HU>#fDXH{=;2sS*QEaGT5}VR%7(W(H zHJZn}O!LSD(D0t!x^1jw`tgc}l$#$I2LQhI>apJz0%95-M|G~?{o@Vx}}v(t20P?mU?==G)!Lx*C+DdHz-k} zqPh-MTJM7rJr^ZfU`A;+T88l;zF-S-+eVvMvD!3ZN>EG2iXOv;9VqW{sux@%h3JlvoezZ${}BL^cQNGQJQ%)>yn4qen-M+S z^VmOqDYux5(xEIUBw~Z4!zG$y7vfvk#)Z9k`!)v@;;u)BT|5&NI>xz+7LDWedS!TL z3a|VG1aG30$v{^x)26&xI!yDfe zeMelW!t3n4V&Z_M5@pM|^5yHQ@T%N`f&dD9VTh2*zlOM>GqlQooV07DHkhacIFj-) zB=aNCkcqB_Q_Y{>y{6b^W@Zjez6Yo6Nba*7=-n$Wyo@=0^@iXCfTU+iesrLmCsc6i zg7%be?0&waiGXDQ`yP5wHB}>H*n*?JD_5<`p>-RwPy`V5yurE= zkL2;Yb-UC`B9(kVTsQQ<763Ok60~wT1fg~J$wJWo`Tb%21()6V(`cDQ?Z|R|d;G#n za()qI>Z9q5Hz}MlC^qF}n8;Qk5l)bNlv-5v`EwKpXX4M#*3+gnSG;|4`NFTONRHY8 z<%;5>S+m98^ot_t4T;1U`tIJ@L1J|f$rk=O=e7X>V?sKNrP#N;3zo5GZvW>o%h_~Z;LJBJe14i3p=QdO4G*U<` znS)zG)wjj2uH7(JpcY+Q{LOjpT=XZWBTKIA3|V)NR&z2d*f7o9|E$9+`)R>6{xS?f zGJqcXd@ds5hB(~boct?n_5saHAne(uF6Yi==j7agxfj9S{rSHu4SN#^u4q4a2=U2aQ#6K{WAN&Xx;Q@O!7KVHa$5TcSib;So7{ zzV=JyN7PZkQYyTu*EqTz(Kgy#T{8szMaL2Ankaz3Z=f&^1k+6=y%c#BIszrdFC5@t zS)bm)e-$LJTo&|GaflWnV$G*U$SrjjM{!7uJ__6|c^SQ@$KCYrv`)YtvAU}aYY53~ zj0B4UuT@_9XQm^xB(+EL>3g~yaoO@^nI9mYB_3M<9RhXhDg>h7B#4Bw3)1ML^l@(D zPZ~f;-o(-LoE{$j@g{DLtp^W=;34F<(2RDXj5DRf2ug%pt&KyZrb?IO60)L5l(=*4 zPjY_AGu#V}_$%qK=n)Ek=GRj+Y}DvFi{wR(bC~B1kJfvOHvw-<2XWYOSUw zy0cFcz5wY*v`chZ7r|!BVI%MLi!2I>wdxJ)eagU)vi-`HwL!%*<84GB_z>RH&&}c6 z>+G&dDYwrX<8^AeYSE!a(!xdopXbn~FZ}rYx}5&>o0(Hut1d8fE?Q$={h?;}xFgFk zwknN;%UBLPbqDR1LZtYdF2~@(#+jRURt31&9b^W9{xp(i)8$UHEFv#~7a>isTELwToo%_>xJsq6jgDC!(J z?1AlaNE9s#UAWii6J`$1?;|9HOo93$g)HIwpO+U>IY8=HADiHmsX`&ocv`EhVtFWI zQMO+D6PvGNnO{Uf{6=*mP*xn1OdTsy2@~4q?`U!=~VpN6d|)MeTm% zVE9-t6ys)Rt%rGeT0@7n=ZgFhul_2Bpcud=81MS1zvu$sDEFUlwr)n-*hs;r zO!1mUInTaZxtVvT6stm}JKlXk=zkXhe0&1>&dz#A5 zBH;9M0_sLW4zLH-K4<;bl*kC)aphm=`JtSZwYs=^(aRUKTanZc67R$1Wj?FdDySyp{w%elkXm`lV*l>#^+za9a+F7P#a8x%=ZCk8`YPL-I^`X8@7wU|Boz_0QN zm!GL^OMbPA+&$;SXAh?gL#-S1lgq8600(#bF=UQ4=)v6n;mHLa-7xcftX@L|)pD<* zlpPV83IO&w-wR$2yPH1)HHp#cTNm%SM6PgQxdlhE?$ev^IQnqu8StY z#>Z{3?Uo4x4y1OESYyn~t8#5j8HMXYG~6mH-yhwg!<>og#~C;)Zf7|I4N)J7GWF!? z(|aO%&pu;c2WWkdl>J=gr_YYOUpk5evScoylK)Kt>tT$+x3l`#UH04pkcF`S0dFaG znoVHzrtIVOyhWhPiY+TCk(j~7?j5TbW^f3#+GHoEDC2b_*aJG#7SgI%-uiqkfRoR7 zMKhN_-xgopCZGZW6FlaT_}!|1Pgte|E&tE8EG#aZR6V%)JVn3>m zj;1n0iESGbT7M+pU#rl@m^lfF(9Qz~CYVn0tZdY@sScL}Mi<3RN({5zjv134kM)`tFbefOiKvH>8nBrS5r-Y8q&XPN zF+|iGsA&qne#?0bEZ)j??0b}wF|+2+)2C0_vdv*nBe{PM04Y&* zjQ#T+@z~6ZOOO1jlz)X`{sCL$81UMJRbLlrtvcJH;2Kl3ltyyq!JLf&KiiR|QuExm z+41P;jl?0=+=_6aftU8e)D$P17Qa~(lHyFo{$k1}$=3pnow}+~T3Y&sB6jawjSHIE9Eojp*l4ZrY4VKtJ@kDL@; zM3@ww5bP+!F@$iYz+gQ)4;fzbYndzH6(HcQNpBqu{ZZaUfiWVt+dn(qYDWAsox1pZ zewB8rNg=MWrD4=}JHm>&{~xiO_KH<~xt>~Hq$#m;uI$YvZmiR~?_FSKU$iI>yDuoB zOu2!?&)OWLwdAqye8WJxy=}+~j0X?xtcAv0jlL9TbC@y86N*V`=`h?pH{AS~^g!`r z<~DBDuVxtyM$Ur=_UoI~cdWmATM-RiBR}IygfSQwg%5JkAhdVNqD3e9kZG(dF~>3O z z-7%pZpOoZmvB3!Nyz9q3p555z$32@267BI_7c^b}MX{s~3@i6D%BdjhBw z^x)LTpzswtiSK@ZmOFq>oJye8@O`squ$}@)dl}CmBOn8-_=Vy2J1oYPM?vYt4$8{$ zTyUBGxf?RNoQDs^dw%QNifJCStzXzHcc23&d?Xv!cFRjww5KDH9Zd<|jo${#VtvvJQ5nD9ba#WFy!FNMz4}1E*^5_O!jW?to~z24b5!YC9YUgJg?AW=}RQxUt8Z@Y$wvlBS^B|_bUf)o+ zf!C8sv+M{?5sFRuIbxJgL7^+UkrWNKM-!nbDjMuR{czSwToay?X?tgE;ZUBz^mInwJIj^uAk$s$Jk{$LDyU3Egqd_moQ~XY`j>xqk8zt!Y%s*p_ zcE#mc&6*|CgCzV9K3n2u1ZAcyLg;pS%KMuS+rj`yz643CGGm1D5rjP$nAQORMDl}0 z)T?LLws|p_kfb$;ND3`_V?ZHfm+8PR{XE`IZNka^Imn=2R)&gh?tB(;T7yn&ywU4P z*qLoc9R+D&3Q2$yD1{gd>WwAxUnGqf1^K?=$A#V$Nvd58Wa=mFSs}0(<_q?;kp(mq(JZu}W7<1I5^|n;!c$XyHk=^MOH-%Odd&Tpmq^ z#MuBC%fOwXLx)Og83PG696dV!@+-{TL{gb>w^`BKNF_z@Kr0)GeqCWtq|%5HBZL(o zV-Xgu;-E<@uumk}7kW%Z#mYaHtAk*q@gNYc37`Id}3?Sqa}Cmtvi^XfgYb(8_`ZC`SSltE?cC_unv8c!^i2!$cBsmPg3!F0~#3GEM|dj#LB_diYR-@H`f-m_s#6{36O zq9v7wIYIv;r|7*@eqIdUO&z!OZ)7Xidwayova(w>6QLHtxd8<>vVA~55Y5%?S|h(3 z`saCO5=(~gc$gL_*rPa(tdyuke9Pm=gvU z=fH?rbg3&pB%vLE4SPP-@P?2ZhCedq8Kkhcjblj)!Xfi8$T_uqyKIv%r5%T_2|&5C zRMW3mDji99tQAiAy>TpfwDjdJ8H-A7nNDddBC@#Be!(|bSvQ_MIZ)olqV-Ka`A#w; z7sxXtKPBk%k)fN@l~+xjj%j(;KWWKwT<7=4qx1`vo9G^dQ+3xg>ryaeD*f&Qftd1q z=gk>gbTnP>?lKPc#@tipWro`S`>%{*3Mw~mlKT$`2~WHBXUL9}##SVzB!VdpL9MdI zzA#izO-=;k5$YD(V0n+)Ys>wYZnq)#MDz`iw=&lxe_NsI&;~Jk)k(Uho_^_Zrb%vx z)&KRYSVa9O<1#oyLMfI(gf^9%pWbr7ciL=LtLugqpYO<*Kan#hz*I|jW`byi#15Um ztUDp)D_$wH z$6dTCkgI_p2{QABZLDJZtF!#&BA^#VXoeGuY@Vy8Zq#IGc4MTx5`B%Egm+@2+!!4$ z4Dxx8mEElamb&t-pR1~5Xbc&wGP0QXtl+HZRYkeO+$gGtyh~Z)8h`K?sl^LHJ_zLvE&Z> zJB^?}+w3OQ_WVEnC7N$~($CQBwbAztTi8rKG?ym~+WZl4y;OidvJ*tF9_MtMt?;nO zf7)0y*oMPp+&HOn-1s*Klwf_C=NlsKB93=qo0&{?-$Pds+aP9v3d< zf&Z8@&jzlBll;_V<%z zg`$oAOLMQ!gr!z}T!T#i{?#hPLts?Bk(6L2sZU7)SVFRBf=Qusx&1VM#vlE`-IGK%KiC{KnSodlaXsX0HWZrH2v8zY z#*1`|C79|(A%rn%3{{qBZjkN#3V)WN61$WWu5Luly9*<=Zg3Rw({g=Iw3&B9MK_8_ ztL5^yBEF%7PDR6Jk7$!XCbY@VPh_|(Tv*5JY_P9oN9r5C>eRXkJzCx%kbvU$!}F=Z z{n@K5XRue{m~12?2G&$B6*dG4S=9E3>$(7|KFv2qOd>n?-RqamoH0X+A9h9*qbCGTTFj2bZj^kiSG4thwvFAb#@H%xJKjx zhY3Q7>!W&&31^k{tBK&tP^4{;fk_CQDF|hh7G41*HaB$aGQsN9)4nZLDhXs+zNFol zwj3Az)<;3`pzSIatpu63RLEjYc72@G9La-o%$1Hu%d=5E5%3xG6QF~B(T~4bHhY-K zxc}1v?A&ar!-wS@QGUfm>7Bk#t%!JCp%@;~j5sQZABDN^ z(A{Zg9ptSR?PYivN>Kgr$9YzW~zy(;3cLI1g{_YT)g?aRXeTFqYJC^ajxSIfByyyAi3kN_4nSn zVTgL-xP1pDoDALIG!muN|3o;5o6anKF^=NjJ2k;#7B7D!1p@UmP@#S1(lF2ee)MwL zB0XUu*%rD%2RKs+ebz(B==|@3l!OR&cT#sV7vHOyLlJRm z-K5;#Kw%~fI79)}h&LPpxzMf`pemVZNMh@M6JWK!6XETzDV0P*rh?Kf~&;u=OW zV8mj=1U>Zp;`~9Qt+~~DCCq?ag9x3G#6f{|(Fn36FC7vTQS$A^C$$pKKFrSE)_N8g zG7n3f1yq4z1q0II$aI)DufEU72k$Ee%to8tBv+Z#hBSaA@*gX$p6y|t3igR&8tYUV zIT`gQ<2%5c7}gTFA;+^1t-1)YNe-k54*~wEKDDrX9FHD!70^GG5E<%T(d6+Dk`?-2 zjrRT9_p*P#TFo7|q|d4wh$TejWTU%@vjdfeq~kLC1?@^*ud{ZzY-Jwni@{8M6PGA} z{FC+07Wr)csR_cZODZ99wJSN_GUxUuKd~z^9^@DqR7=k*Dz-=hJ$_bkj=j2hU<#!) zQhe#KApcidx-D4XJ+d3M6b(y~|j*^hkb4^5kgf2kr3^LLH zNiiz>t#((;+RAVVBcl$KAZ92aD7Q(FVOnOdYsW9*@1;@^%^DkRT-OWxXbNO@q^P|_ z`sGAbgZTuVa(zlN@*7gKvL;=9H7E+H-@Gt=8D2>CQL6sz5moaD(-Me466i5@F%r}p z<%1ZnAYwla+B;j!=xBJBAdR7272hK-u4r1ZMair;Ff0D+4duu8)A-T#XUIDF>%Hbs z_d&l+9v7#OKOSv7&V?`jRNc+3y$lJEgj(6ea`scLnCI+V3XmXuJl1unc|91JjT<-G z6Up57N}U@3N&S!&u=9;Myf}|HUUCy9JQIvtY}D+%+&ORg7S;C3z`1_spZ&*du@V|= zP8dlcW!8fVE8gOuQCl{0DePtqe>hrpLN}x-;sNKiG~p#KmaCB^gZ>d0voE`=>`L4i zp;TaoR=@u?0ziOepd6avOHD;qq+-R2Z=RXtoO~GlL0-L_oS&tlqv3fAqbc?5LzB^H?#95hdDhU4HQ@ft^F??*t5q>*u5?725n}G zg*eP1)9y7;{vp=%g&)Hp7Q3R^Qou;40d0vm2wZPY?@Umt1=XKk2plXxJh^Ey`r3@9 z^7Pkai*gLmCU$Eo>r>G+R|u+wvepu!G(S5`pVHl-PzKu6^QN^Ka*xpCv847zN)yG? zX;d3uC%JQmph*be)tYC6>yAaxp}4h}|DRWmZlU`zH5@ zhW?-rvW>}Vg-njJxSlsA`|(VE*Zh^+udkJz-6X(>V{@*o+J-=jNI1^B=K1kq^9#l~ zZ(3NFABd^*!q5H(YB_fCNTNvSyMK`GHgkOAbwGZklBC>G9DH~0G9fP_m}HL}1%*2? zVz}z!#UDbxHxJu$2;PkLxrCEgP8skl1QtyztLIqx`GKD%H7v_khob zpI`UxFefn6dst>*5+_&|V9_34aVd-kMKJi#>xdWi@wdTWSz5&p_Uq!P-=PZIec z&0ZQ>`5T+u+?cQx75?3b>xmE9_pq%7b99f5PCAIvm2IhBXhz-8j8tBteMVJ~1Cgb~ zY>2k@nx_SrkTCCmhf1Z;p@HMz6`L7zj(p2{Xh~4xh_oBo7c>KSr}Q?@fw3JU{K|>- z1*Z=QHxvJ~uWOAr-a-WMeZ!1dvzBR=ZXxbuXB~Tp_w5Tt z^tHR%^2v(w4R-?G<6v8?P^NpeCY0QucOxboR)9Zu%L|o<*$1&*$iN?mT-i6W*JjO3@xY)xOcf z!<^;)kdq;Z-Nrw|E1u3lq_gXf0>J8r9_9J#v+Dqkg0o%?fQ85_`0x|H>n_%CUV}k} ze`wmn46JIaVe)da0LxgMo9O5PVG867u*=kV_Af6dKB$*x76@t@= ztR~0XCjntuXyJ1vN1vj1s0AK4Y?$s*VmQ%%Wc}T>U)8|LB5u6_RpVkA{UW2s&JWMn z(%zqUq!byT>&Np9UKmC7h}n4G8q!?rDN^p;JC&V}5T=fTcDvR1JV~XdL1Njse*8uE zO#y4L=1aDj3`oE`2H4+w)o-w9dNb*IWU>I%BWAf#I2H-`5cwh8*7wsH;|m#+lhQ`O z^PZJg8@_I*+oca#n;D8TKx}bQ2@o8bh}@ky&GyWU_&UN7k=tg@K$h_sIaKD>ZzS{ob_VMy$Ym$JWWHvH4q>oDEmZu1_0rkAdtb_%vHr@p|B7F~4B3+ah7`|eJ@X@{LqhJeO1i*A zD7IFo>FlMDttEvYJsNxE0~8+CMon5RQ{;{cIq4CbEvi}@TmRfj4#JrU1Lrz%LdJuA z%1gl8#ca^d;v?X_8@yl{+Udwywp8MWPoEAYYbv`OxPo);Ce%w8zzEuVy!v&%udaV) z{i63?W6xc>~lP&o1CNWq#sIiMLEAk zBVziaqN1)NMqInC-3t~=1_N+9o$tAaOmRfy4rF@3JBmh7fD)SEJp205NP9a$q}||R z#SO}N`}z!_q})hdFyXeUX#EeH#RYubw$V#ZFNA1+oB#`z_pm9Zt|h+*RF-lp&d$t zWW2fi@}JM}tgVJkzqTNqDpc{SX8n}4@5RZDghS$Vic|fu575P5()qcdqOt@L+!OtX z${l%!Ie&U{By=XQxV(*9`m4|GR6-}dOuH6a7Lz$1^-D{|8T;!SlrsnnR;0L??4gt~ zfD#s}7&zTJVf^IZ`m1rpQJznZ@t zXZGevX!*hIT~43hbKt-|sSY*N)H?rY!s5Tl44Rn-Du78)jxCHFPUDlwIr90-m$~f5 zbJ_WIhY!DceKiDq7RrZkaLu5A0DIKF^O1V66QASPD0|Pau{i_qbdCz>ECSQBRL}7! zZxT_RSlY3~oG9`pbnLs3z0!#zA~rG6x@2whbg$sRmDv-F3*&KH5Vdc;eEm@)sYt{N+~lPMEFP!$CsXX z5@bFD|HNEQ)A}6IAH9-2r`XrA=fq=7!AM|s{6>tqy5rF;XAI5S_jl*Am_c3__YUx= zsEnz2&Pc^0gdNtp#nUmW3-Lu;O~Weg8Ci`8U6Vpa&n$+9hL~tAi+b_ZYUTC6DjR^| zC58NV*wRNkdRN)nLC20F@{{BRDU;}y@y>-}{1|K#7B;mXyBN%g?yXKZ;bh}DWejL--SKG2bRl-!H z;@B-;P_|xv$~cj(eM>#YFOu1I_@_6~P!)3&3U(JvGyzu}pI8P2G-zdGJo5yAamCe?yeZb!>D(|0eDYQHi6&MndjsbH?*{$YC zCuz_{kRnwAK=Q?q{C|x||6y;);O(M0YrqCf;Anf$okI@xLq>4`SrciOMyqaVWtH>R zEvIk?m?0pWhKxHzAuLgG-~wn9o3z(&LXTl$S4_ zleRFP~Cz?#eJEYVb&ng^7dsj6QsGVXp6j!#nn=&YCUffO!|Sq^RHe0H z0k9=CmMWa0MJ7Q55KBtH-&s|sTiy6!wsut9sZ(oD^~;-LX}R#s>CMa)QGF-1KOfLpr;w zjQEpTlx_<~dj|+wKe`s!*VrIPv8epdcWT zD0yik5iMA~*>g)rcC1mX88ki^&#lcGzd z25J9r(jpR;Ul=r6I1xgydt+M?>`K^E=}XfS7UuHG9y#cevufY*Pj@zMs6u5){)6H)xIHqdcFEBY8gnhLn^>na$6%?oz0b98dA}JqCRR*{ zgl*?KY;2!%ZOXo_o_KS&tHd_x-M6n9<;gL&d*U{6u31PNxQtgtS~}#ONwmLQg=u~3 zM2R5_*1J#ci%>j>k7dNU3|pa4C-=p?jw)N*7%JW6s@9wMcJj*Ff|uEv)lrBTlVU~2 zL9*yChL}Wq%cssIX$LeKx6BevzkynKnfZHF>sck+@hda5xd~M=9+})eb2Jt5FmGWe zR`OAZ&d;pNmglQBOmUL2G7?SFSlxc_z)DH11slR7P2y-H+G8n^SL`3N4* zS#vBrtwN0-@>JZ=2d>{aM7tHXcds#4x$+)0izriRWH3(;zjYF0921!*Tn-;YzvA40hIdLaG0Me=Lg*(%?GG z6B5Ys9&YnpT!N?xo+BAd$DGM!76!;=-g^49BbX^YTbZGX&#!x(|GmS$tH%ggZu}1Y zom;2K{W1AE;_e$=YyDfLO-hbR96I}}AiXeY`R?X&-j%5`xj>VHW~%)>sp!PH1wPDz$~!{l80p0JVrV(&U=^-GVRI?n=b6a!VRc%uiI`_b{#pgs0gTStqH>! z@%u{)60(VcSK<3L`2K)4@E{W3$YIWg`hX&<@V}2AV}!xPMl6{#e}jS-){&3(fu-Q5 zsdeg<<*~DApDtYvKhdyJNWz7@_tIv<^w?%}soB6Sb(E6`GJ`m|C7MT4)m8i|el$sZ zN|itcj~}EsilSeQYd@AVQ%)SnV}c6Wh%x|ZA3>d}g5d`#Kt@GteMoQ1;6#=LT}TUe zP5*%=f#r&g36lRa)&9r=s78`N8Yo2GLxs*|CM_veLcGVzi*9Tcf$iH$qf1^f^a`PW z30{PeoS%a5P|r3r^wl=C011}zD7{U-rQt?Oz0H5fmJZ>Sp<^y31^OoN2UG-oh{s70RTd)ja;&%U%ut7-f~T2cpO00W&)IR7kOePV^0)6*~E__`*%2omZU~$ zb>MOkB#5Aea;Vs_X>})A2is^6+c?3_lp2on7ZGE9zfB|3Ii4#;RJt=@C>fuC zG_+hQSBT~M3cxxoV%bevPgjti)D`VN+V1B zwK)7!y~eDw8ewL2p$9~l==r2^my-X}0(k0+T$GBDLmfRsB=s6s!EW2ah}?am%j%+&Y|G-DCuaU}H2ENg-O(D1Uk6 z;%Z|L6nGm64K!omeNzu=AmpBi^Q2(oesPYd-Z!)x)|jQ}=3WyVuk3v7>-xUj6AVLu z5t0r|b%tF_P)?3{Ha(DFu18}S6fHvtH?aMTdz-0kiH>)PhsS7h^M=q(sr2fBJSX)t z#M8vuUF*m}RZ;csFq27zDgd4q88lRd(4TtBY-%#fGB3|s>bX8RsUDr&&~qVvI?4*s ztWv+RlbWv2x^qYA1}bo|CXI0d3X**y%^+HlTanEv zYHo?hpoDH?TQ4NGDCVw`012&dzYLpDrQw`wQUKx&yk=#+tK-a;a#qq~uml_%Fqs{O&2K>{D zAw33wmk1M02~A*_C?Z}n0!N5kLczoz54-wuU@04XKd5G!tI6}T5{i1uZ@dMj;?9`r zi#Cb>5HBOym!=C2T^+c zSNR8&RS#q08X$kdfz>~R{@Nnna)Y=mG$wpf zczKT`BFfM{$R3t-`Epm(>_A|CbfKh_v;?ph4i$r%U?SjZjiCFfOJubNO+S4B!+&1|m8a5=RZD@Y4(<_N= zS)L{T=Qf)NSq%iDiE}*g>!@~8CDp6`{+*=vfE}s@0ArF4LT#1?ns^8`qU_#Jw_cRR>{r1t#S8!8TFr3IuI@80&k!fmAxH+4vX<}McI4OoaQsk$a`M8C zJC!9(Clk+w=@l#l?ca&76ACBtn4v8oihlV}Bs(#h+%ZBS;TOc;JAf<=d^A=?4seH@ zCIrA{!Q3*(!1e*i3(|X^mWz8yoRWBng$1=8Jd+o*CP*!cX z5m^#A#rT8>5U%IBlSZV$*-JucVAbeunSTK-VAh*x!zRy~)jKf}Fk3`9?R0i4$%|xz z@UPoC%_@L1UhONWRJdGE#qxA9@=2L1MIE#$mSym72sq5vKu-T+{ty|s*Wn-noz6M)?6 zVuK4NP8-z%8#iodPqntgyognGmoY;Khl6q11%9cVBtb%TQ-JRL=Z9V4=mfW@?FU+qSW_%we(A4lWp=cqESBZs7a#-l4&Wxb?ujn!w4!{F?XUi`fDw^Cu zfgZAdjy-Z}U4ry)Xl5K;R!D_S;1^>e3ktibW~=FSv6{SIvx-gFaq((i2Cr{VRvfXm z(={ zZ8t3L&)wrE()zsprqe3FkA<{d)CcHWA3d)I1{MF0_y=Ue;V>Ln;9dOxjq=QaDxx6S zz?L0&>K^~bgn)5Au=T8cWu1~bM(IRHp^9>*>`t^PdJHi}=EIJ{^ZCiiM$AL*_Tw9- zgf_XgZlNeM_qO=@!09pHK#KMDl2kxavXtV?J3F}5H>ncUb&JD5$ST}D-wY) z&^@PMnTdP!)Tw)%=A%y!H82?Xy&Z4X?iVj#_D}y)v+DGzQ*J@e<-%*@n9JWnv;dm2yM8y8A)s9 zWf>`=YhaR}Gq2s#>^qhnmUxYmHbunD8VP0!fD@lM{*QmT$|Q5M%6E?jD0}<)`v;x6 z$6N2s-Wzc0%1e5%0qkYU&(HhwW^g_)Sh9vY*;WD1_He;!4jPNGV^2(|t_(eQXO(C< z6?67|on>o#SCk7H;HUggLClCBSU~TixN56-`TqTV^qbkPb~T>K(KPeEcx8jm--GHz zev-yf(=*TW_OsVbcB}P#0|?1IcP9ZO{`?6fw$wQB=kxcompH-w+6NEv60C>1IF+5G zeTNV5A`0xp3lgqyCJ@5kl$yyg(*V(!B85`LG>fFK8`;^?#mk5tUa;)v!^C(8wyMXY zlLL$YxY*O_Q(niu|F8uhY;57OkBzU*kfq%w?lSD;_Y~U`_&2&L+6`*-KyQ}6TdtC>lD_~1c%b7C;mESE6iic(8NWMGP zO@WqbZ?yhRj`n<4*Sm7-_pTvqOhf`A^0-VH6LStF-vC7{wSlV63RHmo*};#-#@+=Z z(OxwNb8pWcJiJjs^Bbu+I@IJ0VtuB^ULP`KZ~J<@c2N(2+# zKri(;#H--ZuT=fuT)hrI)>c77n2x2W;Q3cNkt(>oGstiB9d6Xqry@-R$g|wGXbW)T zSE~+o zg_pZV?b_dP+gYxxq2CSV{6^0JuItIcP3X3&_=#-_yPXw49ma+ku!el1&bHxAH4Qf+ zSJvv@-Rxcd%Ax)DmYD|Z+=7yfN^?=RadjU(rm82`{P}4^egx@yH*<7adl@~wHhj+P zcJWatDr7jfcme{y>Y?JMm({-%t-Wxl9Qlucs!-R7r7`|I=$Bn2o-N8|Qv!+$3U}#L zg+98yWmxq24$-mFUsKtH0{w}1R=r$CZs5Y4YM&M?Cxt9ptayRHJr6)H2_#Gb;5c-s z&f{v{Q7Nirj`y13b|t^Lm%=4DK3Sa@1=rfJfp{4B%)s-MZL3QV1l&Z+pttVVch3v2 z*P4;|sUgS$TqJ`EVm#c|U@B2y$1 zQSeM=3BV9uh?#J!NN7Id3EDAAiBBK1e0jpuxQqJpAwrVa1UR#Yyt#G-l%=7W&cyuz zZ2xG5r)X8=e^|N<_yg@}3Sv5{PSHJe%jvXG6UL389@*Gv!XFSZLub|G_?xb>T*qM3kug8%{c?6U)7$G;WKrjrj%-jM$7lc^* z>4@spgZHETU0zYxiZfRck!8kNc(vxwYLJE{nv>>o3&g`Rxknj!3sFbZ8x>C$s35dc zC^Q#SYQ~;=#wjG@AF$=iw@{YLjL;?>4AfLqzO24rfVtI?_$Ug)PLr9!2e(){qNchT zSp3D1yyH-RAOf(4?YOj;h9S05H9Hy>KY)Tg(%<6OBs3$^y;xaUeZ+AQ1w$&g55!;m z8o;C{UM^e=-XQ@F2#lK%<0C$Ad{MryvLc))2>Ua`;1ED6`&`tcn~o!$SrD$^E?!md z!fp0UbPd8)DJPZ$zRM&GFlX+aSUR|)wM}$H?0ANSN)ODTCp|D=qtN#v@2*o<`PP58 zWT*jw5u);uN8%zUM!u}>rGJK8L(gbr6S9D2<5_@}G)VSckOwIqfx_k8+moRQOOH8Jm zNg62shV8S%v9-%E(7#6AET{&r8m`oT+wFw^;#djX^T0O|yzA*fu${g9lz z9E6Lig8XEsLOzHNb?VeIL(dq%sbaE3gukUk$I=a&9?E;zqj&F8<{PX3URqpHAt9}C zUB?UkAtJNdw9CcCLG*;>hp-INt0 z-VglU9Og1y34ji*yD#d9hyIP$9$i8N?*{dh1;&hE(D z(^w6PKXcAqh+q3Jd>HdNw10eyNvrjx~D2Y5{Gf5_VHEZ|skuuBQ2r@dl|CwSm}fvR|y=yjii zj}Nv_QE+NMSa$CIa71^+6`V$3;m2A-BX|!fg^Ap= z^8{LQ*ZRlG2(PL;0N+te`A==tALoZxe1xboW zW`UQ@7|cReK5lj8SDitxL*9obvYBGT&8B!F?1(~)RO%hYXaeS62JnC|J+!L*TfiQB z7=5w47k*vpArApi71>0-rFmDtpX+T>=>VYarpp~DmCYTAF->?2TeEEeWMBwae1Fb7 z8@gm-3QX%K?yCJmVbWNJlD$*$X{IZC6t%Yx&MpYzXqmjXJZ7RWm8MO_&`aT%iplPd zN6YxetQpvqT7R|iUQn)_E_*(#X(5ZTF1kB0XR3AR@Hp;$(7fO-r0#C=e<3*-TeoiY z7JfGBma6=&z(Fo~oq6jdxjx_WCYotwz9UMhcLTIGtmFx^^3N-AT$F7D@In?H3SNbt zjm$~M=IZJjsOAqN`jI8W+{BK+Oam<*3;(&TD^u7NP)}>C+VZ(tjI^cms1uq|YN%4( zn!l6zBrtmUmSxKF@d4EAbQPdhO)qvjIex-~(O?Fu%`%&V%o+N+)t74xN4%GM|9(?| zTB35rzbw27^>(r}UHmaN)V|pwv4oUx_ zV@b8E)nC*g)Yg()xpZZbDWmH+LB^z}E|sASijM>_hU~c2K(62f;ExOz6eC%_`}CADz1&?c}--3vSW7S=!Tfyc?t5}XKHg3uo?PFAPRr}sIc(P?|MTQ z3NO~-XW5QP;wO;7^W{DIpo-W8<{iXCBbH1PQNzWMF0Ez3WKd^T;&peTS_udYEH<1N z1i^~n+g^4iGvp&KF5~Mb`pMtEk_SdDYY%C%RIixq%tpH>y{rSr<&{ZPGMz61$b!d$G!Y^0(x zp(cPKYUyC}!o!>>>*6-p^PLS|QREQu+4(DtI!q465&UjZkp((eJNxjblKH>xXT{)4?|Ws)tn25xiL3(Jzz#awXMdSJ z(R^qWYYZx*l-33XFC*~9gV!a(b8Y@>@$^zP2r|qVF!JhP!cM%eBA7yQNGG!6DDbCo<5jH z-uQ!)wiA#7nGeMg5&%H`obJaT%J^u-rr?)3#2G=>!~xTvU2_I7p+IDo zisvt1=9RfthQz%ISKGMN(#2ziAHa7)uJHIg4oMJOH$8dHUr z+p!Lmfna!b70`7uD2jK0izVIRy^9%ac)g z1G$^7Cz8mIa|CIa>9bCn^-qnqFmGVR{tIYYOvR_Hkc%LF(HPoQZV;t1+C0-QqMMjA z=c&u(qY0Zhy)JoHY^F${UL5xY22RqCUcd84v^gl!r4qFQXU-7ObE1HxgpVTP7??29 z?)Xh+LXMug1kg+gl#4UuFip6~mH9vww7*0!1)ZAokGv(m%^CNE2!%DE;9NvsD`8U9 z#X_s1)v#CY;ZpT~S^&~u=oqAB2IIn4ArVP1|D&C|PjCnp!X5pTc*H3Sw?V|i8<)`a z(s8y$Lm(}L39E~wX$)212d9z*DeA%HuB)^Hv$vn!nj2MY$02?b0r z6+44rExrt)G!M9MWcT~rAm_t1MnBhn{XiFqgntZ?S|U~0x3Bk1MHKTR2AwEw<+?ZtK}xtQoDb{G8&{ru@utwa9uie~W187Sk)5mQDg z!Iv_Wx`Et|{&NE?RQpbm4H!5!1+-TH9T_o$j2bvk#LRerZh0hI6MbUJ>B{~Y!jq8E zJU~aHjF(h}`O{+-Wr>r6E`mC@ot&stX%0j_VNnz-qudrcwtPM9IAj{~eE2ZXC3oUa z6zj7Vkr}@u@WV>k4D0f;d4rUo?&Qaeqx`nA@M&yzS~=1?sve*^8nB9V!U4qkrs<3 zxZFm)QhYd|-}C3ry~)X6z>)RHr)~oq+T#4|xib+MHda-gN3~)>ei~!a&q$qrfW`nf z^obWN^?(j1V`Jx{*BT-uBrmQjWms%-^8RugtFNRQ>4OL!1y^Bd&RDRZNB*{(=wQ#_ zO*_lo>EAIl17e{7Ty6#eUsMY@JcLKWGEkvTnL2eYg@Y?)Kx|TyP03mwyXk!fupIpQ zI@=e)V>qcn=h#{q1M(Kg<1X&aI`%>rP>Z}WwAu#^6VGef4{YM-p+hMm#DP}0=@ILx zjYxJa)wBF6V*JlYYKU&%zR>Blg)pMJGb9)F<8*pG^=X zuHt?y8rIhUTnT>M+y0y?`mj7FY+YRXAXgA{pDH{Y3<`tPb9}$MSuCs`-5+VOoHe=? zIc|oumsq-k+YfGvzbl1j@BoKiT-V!MKzwBO5d039MC4svD+vY>Sszxf>)72Si-tCI zsb-KuY!{U9&3I`gKOd}b@k7zL&wa>QuSYTwkp_ZV_CNo2d$OD_)V`*ptDfaq?oL2x z3`I>fD5EPSi{{wMTjl601yh#keQdVqBggD3+MeZcuHnL0D4-aEn&=Z zj#A0UNTSzo-U#wNaLxBkoUU$xCx*_ESAeDp*I1oFBq-JOc0^njtq4brqX zuxXF?z>%7D&;fd#G09_qh7po>JAbuito86_EAi9G87jIJc0B^t7tOBg7~X4i!{$LS zokvfeymR$;)vWmQD*;GfzI%69(XT-R|9p+3-w`FZf#FevUA}y|;C+|1UtTw#1(i}) z9Lcl3&Ory1NGwr&+41gb4Q(JlA5jb6Ec|zwSod(gEn{drYtwP@dW4d9Qy8JE*5?TL z{{nq(nEwA$)|toUoUeWSmMswq$R1FvPOi58)Ovz zSX*-l6g@7fr;~7NkaC|YE1mCsmj;tjk9};A%M`$AcF!|W7;&dT`NrP`3~pko(|q8~ z!VY_2L7KN{v3Jb~3OS)J_2*pX^ch?=c;~il_LKwq#!31ZT4wTu(({i*pQ?MIH(VX`64>hl`N0$TkeN=_2F;#!{IVL3xn-snYHW2Zm*|%S=O*>2mV(JJicx(Yt^~ z-e3q*k3#E}T-I_y17!Lq)S-XjKA`@Yt5beU9rG6oF?)Ws{)SevxY97cTpSW}Y zgbsLw4BjP}gnMAnx<}AVsl^}6J$7)C+H*9k9%<;kzyDnMuLp*%)RmcplqBd<)Xc(S zvs%FMeXa1S+YT0Sj0!_cQ_qWw8z{KRB{z>AwYyQXMIc_s?p*9q#%&?7E->HS3#}bk zCETbo85oJOk;l@Np-ppY7S(V+i~a$KRBRw92baJ2r=2J&z_^($Eyx|@lp<$hMBUdQz&p&U+D(X}(`RzF2L(@-)e^Go0CFkI;9SnzfwuVX3mWQ5B& zHrxoN81gc4Sek&^#Uo$cr1_cKOYOnL;hi)?u2wK}9L(}8KbKkVB`zW0YC`o$c zn>g$Mb_(G1w>su|_eR~BvqQdoef1+X=Gz~(A3IzvoP)X+Vy7b|zk}idAZ3o&hey=_s@efB(dcosFicH9@J z#SWxIqW%rE>2kLE)qQ3U$HGkKlMubI`P-|Wzv+M5(dm0Mm#3!U%k%W+xhtLWqvtDZ z0E~PbP&X}V;w^)m48K$@`jlPqCu^Q^L1*2W4KF{7O374v9_r6yb91^|X}30@@o=Xw z($KOdx8kNBj;NFRFEWciEN93E=+Jzwc$U%hW0uX&g~D~Fw4Fiz0^j-jDq23;Sq>Xk+H58_wRT5V!=#(15=#ovvcP}pIaRSWs{XtL)0tLN~)?d-jbN3_y2U5OICMhPVW9St{<#t&FkRQ18SS{UUz@e z8(7)uAz}mMTs1mCh@d)0 z)q{(xoKjvuHa&o;YEyUW(EBQFdG54Hf6LG;wb-+U8u5u$U?x}2dO>ZBlJ zFZV+GgqmK19ioRq`i`fO$=hRPI|cEsPv+Ivl5>%*K;z4GJ=2Jv8!WPNOMwPb5b~F8#_$ybyjzW8li76|9XKzN-8dLW4poL}7#crn&L{D&=5Qc@h* zWqGei2tTB-w4SG9P$|30=(6@68T5%*Ldh)e(X;0sibc4Y-N3};&X`xv zpNYkgQ)c&-gnc`g^%dex`R9Ik60Z+2`TKvK19S4Z+u7 zA7`1?6UVe5#_gWS9kRX1A$CWiI(d+ytD~NWAnN6I*xiwrNKRfR&*WI(k6&FWV}mDj ztu_3H6F-&fNFq}Ql}#Lfx#=yNzWiE$ZnYcGB^>jujVE3TB7BO2pFpaw$$Qq7WI^lm z?WE6doZMdDV=yuw_Pci_p$N`cfNNd=IoV2-C)NE}X&{dtGLpxB> zPT~dFJS8U)w#b;cfK8Mz9O=EIUA`=l{N2)0KLDCXS3ECeRjIw~YM)`-fvQK0pna!D zn<6dASyAYVn5G!Q7R7j|+4jB)!F35B+r-Kyzi}JwjqjK2kSOF1gc)B44tNhUHz@gn zk}TVOR~Vm6>bQ8@!G|=ACmwRAfEN73m{g1 zGmBczynh(pcp`}c$H+k=BO7-_tN zbPkDdr`O%Hc1Snf!<7H_h(s{UUY7!oowo3NdgI`@>0=QiQNWGnH%VRrOH76N4+WGm zbopD!aZ@I_K*PAD_o7c<-=QC=tEj6T!EBi}C_F|kUVI`aPScwMo%@LdZ7ojI`uJZM z*Q>V2T`&B$-!Oj@C%hvM;Vw?*!mD0ab5_`hSRYJk9U90iUmxL2fOd7zCHaj z(*&oE9=#=Jw{bY?qiX)A6^1D$bv2-FQHPDB`^| z%6*#aIXK^h#*r!L{56hrg07*jl42-Vj!G~bCFNpDIp<|Av2azAfIz5H6l@toK+Zpk z`tjxjYpV>NKLXQ!kd0m>hL|a~wjr~spDW$6>BPW7YnoV+=Ny5=-6&kcx-~--xP#JU zG#Z8lj5LFI(J;>IOR#nX=|hvj-z-7eWhNNhAO~mVNUnKrEdXd=32f- zKKnEvyyS}))fF94T_RsjdZJ}n7*7FIh^-gzfn-g25@y5D8$GvZ4RHFA0u`xt{yk8U zLk`(udYMYyXN&sJAZt%1@Q_9n2qfaj05a6TB}tjpE`RK4A zGf&z20HvXkdB&M3dsKA4XmliOp29^GgRIC#SsC(KA_?@DeaNW>C#-}!fbTP(Ta!41 z%^){9YIFOL1x*%N8ubkHpeoajQTsT+j!N3Pxz6q!wZ@Xz58f#o908zM`oN70mOd~L z1XM6Ux@R(vdbr)y;O$6yxLBeEq{Q%rm8>Z}JVcs3zgH&M$4441b(GzbNiFt)CHV}` zkZ>%t{*CAYe1LsfM?(-~?N zOzs*XHyg9xG|I2y@8UC{SIXpaSL@KhpKOL2UUo0?Hf;3j={Qovq~jCY0mt6!L=t8c zbgkl>A|M0Le^(JnZi zwFDs`Z;zHym1WEjrJ8yS4>y6rhmu8B-02{8L`10D}QNUvIUNJB1dTOdd zY?*m^o05{;(O1_-ys}{D$?OM?dK4)4zYj+Q0DY793UVuzXCM>{lL$97kO*IYe=Cfu ztUZS*fR$@LmNbJ_*uhJa`Pqcp<=LZg>RoGa=HaCiz|T6h@9$yE1PkR6vIbfKmWlEU zm(eJMa73WIA3M}vS#~?{VEs*5^C>&#`2jmS;RXRhs71vU&U**-aEdh`4zaKb} zIjRivr7%|&J{@h;3OY+cKS>`m%Y1DBI#~F5RsP2``MG|~U3tdM$v|YpAvbsuzB})B zwd}6`#An||PWR}?21ABOaVCyUVHbxXhaqc4TMR=0Ry~AtYMVW>t za#pELxkf9sTO3yWmSlvSENl4mjSL%+L!6x-=8!n-4|Bav@*plnVAw+CWKZ=VsYx<9 zhTBG2>-6krUF{1lqz=d^9K74I5!ewWudEy+BcluJzn#m8D^&G2zdkB$!19fM?O3HO zkf2L{kQ<{3Ss27r8dsLRb2b0{tYUQtQq+w`w`KR=_f9*a*Z zm0#07WL5~r4qs!!vp4hpDptCs`R2W3MB%|ha!;~=1GnF%$6ZgvJadRWw}P)=sDR(U z0I(vV$smXJ1iIiUYG*wCbmpkE`X7m_JI?9Pqj+?2RdX)l*tocB9EZL;@16S4I&P_K zg12+U$Hg%OSdfa=m{#JM)55=shTGIXOPhvbeB#?lj^9^;KqWG~yRNQ^*6Dly{UCAe zPh47q;bG5hsL}7?d730#Q{Tj625S|yi%24uT;}% zv)7z~9*BPA{^C=bWvX}nwIDJ=L>)t+?hR`vACv{AqGdJdfB&cs(1Jh{!ZK0cwtyR; z=xC-juJ!-^$QFqh;BAZGfS9}HTrWJ1aiumYnI1o%WZVn`PF)^9VM!Wt?QpUaDzP)oQ6%iJy9e}xE4!s-w_p{oHEmwl~@X|3LuLzveY)sIw z|2~RDZQPc?dQHh81oHQ|bai2H)z4S$pbz(}N=8Q-eii}xAxuDT$Clc-Ud#OTBd*WU z@p1m515A48v~cauO=YM%My4`w^@y5Te3%r|qc?20k`rg!;=doPWIQ9JcmfC$GwB+j zaeZ(#@d}jrY!l4QySpi8*wlX`_*l!jOCY*GO){seE;A_%4X<79hr-Q=4|f&@^MYHM zI^ji<-zc}H=ihJ;LRo?)=KX~UKw^(r32rm#y;f9zc0}FMOfCLi(OIn>aihmU%cJoA zQJYfp^!|E{cI|o(n0|=yC_d5yAilE!50y(4YgH;uQR(9TVymRGeHFZa-@dNHhtIBl z${Ki?V*9?ep+j^t6uqDG+SoF-5IXS0QFCWvdlYY^mp`n*#~x2O`>e-gF8u;`X-BknO3t#P_w zJ2EGOXYv70!_(N0cI#jCg(KUiz}@*)eT23pzQt{(TIvw$6Ul?;dl((HynzHTipS zNy%nOYCfCtr6Wdf+lrENkQl_)NS@TD1uNa$)-OA70qWc4@|rm9wYGibzR^8I`voQ% zQAZ$E3lsoypesc#@k+Bdr2gsj$4mX)mc+`sQyPwXmfW$UuC5O1GSg=>Z3ou>d9IjF z5`3$Fj!LuUS>bg*Wxg9ZKf!DBV;M8S!HzRKy2!0^E7RW$X$3+L<(@t+hqqHOoGLd8 zWf@{1e)q;UiT&wcWm-^p#fnk1fB5qKdE~tf3I>88vTOFfBo=S?^??cQaxmW+z|AJv zSPBC$T{uUT!zVloFhZK^Qyk%K28&fPa~NYE;Y7F`BnX* zES(Mx0aNfxaK}iEN@IZ#>jpKo3`LWJlYu4tK{|G1Nkz}D&wv$|^rrd=F1$K2F%Y!v zMCR5cw1N(XG9l?fBgy&|WgWtCStiq`Hz_K}Sw$UiT(1iFRM){)p^#ux}8u1O2}=uZ0=gKtwS}_N5f%+~hn> zEi4Ri$$4xJY=S~z3%+R%c3(X73`Uczl8Y00uaccZ9h|k4%oYV2R24NPOE{^WwW`CM4m}hEK&+Q4cCy$a3{-%D7VEIx>83Xp0}VjhrT5YXDiR|IZp?Y zM?%4bdF9fbhi8zA%H!GXNzo=c5&_6;9l>g3x&bt)k{ac95y&w0m83#IQSC-041>%y ztiu?q)cAOBx~nh_QRFaUF_tiqd-r0_XMW3mIyd1ze`RH7pFQ8cCi`i8d_4E-Mkose zhTZ!19T#E^9L`6U9CbL{T@&U{gmc)SDSJd&}t{VZNUuo0b8B5($8phvb!W>ED-TLrJed+gSr}0)0J- z`uB770*({$Q~ZqBlNRPz28vdpvomPQ2TAHnPZwfM!cEX6OKZSCY^{boYChKsq6Y!9 zz>pBlSjJyb+>`>%IFLSxOSmalwkf7%3>dPNE?m0Q-1YV#s!XZ9xNsS4A$d@jtDbns zSr1~|_DIxVE)p5G0F=OxMzq=zrNX!+u?R^&j{K9hZY!VZ{K?@d88mR>5{Cv6zYI%S zx;m;cU%I-ZBYgzDB9%t`39>qJb|>>()sO~1BO@~te%=6XR&qVj*tr&rb3Oy-UPB-8 zfVgWezxQCLshOEk=@Sbbw}Uv-6MEB)!_o^pKszL-xg>XpB_cmR>Cbm5y~lFR%8#<8 zN7U7{!F0er5#5_4w*cE-D=3&5SnfxWR&Il+S|sseH-l^l-B8^d68GV$s--l<;)_}j zv@g-`9EPzAvVvN!+!`!v8F!e7Ah^E6IG!NoWN05QHg5lzb+yf6Fo$rl1a2^7V~?bK z6 zNK}vjPFMiB)^**&XQ(r4fo4iK&St#W>;e5L=`Hv_^H|G{m<90QnA1-upc_zW*)mc( zlj6j2un;o!H;)WkOGGQw%cU|~nplcx-8uzCod#2fo-`*kDNMF>-f;HMU;={n&}lPAeA3dT(K#zZy3_okX(Qq=fMgm+%nW-49*=H$HYq7s z{2zcu@>{X6MDXv)m_z!Wzat;Lh~?RHx1~8msTvL?a&cuas|-v=y{GSXct17JF{pq^ zyj?46>s_=WW{?DCnf9uF0Ra&#Y{40!VsqIja~&@n5ghOl$0xb0{#anUyS4R2yB01; z9_{?;-&E?@H(7AaNC--dQHt&LxL@3in%;AL`Ct1&jht}XY#zdzqw4Q zZKh@Mj6>QHBZx35V=-VEPaKYhVUR;c3w|a6F5#csx7!-4J8fZ0?7>+u9udZ8fT|(i zejhqF@`g>PO5mRs9R@T)GH?T}z39E2;F zQ)>CP9lfwLbh3LOy}XI}IR?xauuh+&sPHJ|iX`yBP~gTafBv6tciJ&iMFz1_m?ORq zI66}hTM+>qfSRG_d~j;vKlW$Yh{Gh@n3W(2Bz^my-hXBE*Rvj!H+XZpu=lVA?ru4I zRs#XG#KI?(2A#<@S8?VF_9>Ac)aWZ$I4_bGiiP?4-Q!NUkwLfCmN~6y6&z<22~WV0 zpUK7jfkb%~tuc|@mz?7|V1sx|UCU2%>Z4)+HB19JEh(Ha3Z)fOH(a1oRB4anu77v2 zZkzmg&=``G$#GeZc2E>hC}+-vK6*aJw}XRgB4>%9-7iW?E>9Uo+EoJVv688xlwTQ% zUa+i~^WrGPdmBYZI2E*a)xPC2Ro>)VNgJJY?#VYiDpJNMZa#Wcv(MEiUk0Ju#~t8K zX_q(mZ!D-F^px@olM}8wKQzkA&F!j?Wesse+}3EaAiAQ$A7EsptKdw%8!imrIKJB; znm>W0(=#&i?Y4e=f6m1B!LkrK=gkQDvhwmi`rbdha^qjo0gO#O3U-lXX-6s5NEpn= zMa2Nujl3z5Uh7*=oVej#GKARa84F$)PQTlfKA{J`^E{5tws~FDut@xdSuU3==|!P6 za>WKm0cA&29WdAFN`<&>*De<~56M7URhH+=z1Mrhh)|A0E9`n}muV%1XM8zXS{|9q z?>fQ4N?2Mj;9z$B9#GfPnxLR0JCRqNkQip<>lt9b05o$MuJ; zUG1Y)n-NBglp0(2$-p14mu;V3<+5Z+A0eA4D11LZoklLc8RV4NM}`;3kxjO+NOVh{ zgz8CX62Kxvc&FMBu4Uh+Gp+ngUfjWT#`@p0_TXWgYil(f&T3;fL6X<{?YeAkBOL$SmacZ!1@5G9W7psBlAMMK#EQ*Yj$UiU5AYcVB;YeiJc9~BD{wrqI4 z1quG?GEVXRS6;%zHS*??shnlk-)<|%G;@z^&!(`?5mWVG_Siq!*)Fa>UM?NNqe-A> zyXaMSZoBsw_js)eY>4MO!{2lkMyo;vIe*q0uUh_&S#hTlS@C^}5)Uwg!PXKShkExd%M_r2-NncpIu2Yq=^ z$j|3M2})oTN4y+qb3DoubzgXPpwuQjHw0-0D4(-Y$F0e^`6GL;P z%-ryH33s+&Oz4Kl_g(Gf9b30H74QnbBv+Io6^>*l3tm!~zylqpUs{#|E(pSiNL`3 zj~r-duH)f2Vn>GJztLB&Fr5WzODZv{H6L@GYl}iX^P`g%z&}jBX;4i~jQ_7s)rO8f zenn+v%|P2&J;HF4nroBn8u583<=uoO@yo0$xsxh`qr$@#3M%+HhO3HsVggIRRL7kE zgCl~zy2;T4yk)KsXsLP7m)Rpu1RhV_5vLJHv34#o(K*+MQqhWV66Bu|@zT-+F$;|r zEteB_cEvZYcgm!}+x+|j`}HM%Qn3I9_w4B+6Y8#kz9Wi{r?bvzBon}O85?r`!PAdL z*BUCBazN)DtqNFW)uC(w4}vgF4OGn#z~cR=FCJ+ z#2}NNjJzP~2L(*NzT!1Ed5SxWghn^(pMSPN9=*A<^F?|21d51AvI0iGa#s`kgq zOB74p5z;A{0)a>J76Z|agPB`ey9QOcSL$$^@wp!q#k`fua0>}5o2U%osuCApBGRzr z-Mfh#=#kv3fhaXon4nb|IWhVZvPIA`4fHqax$%x-kL@=6_$po;bmGJ=8@`6Q6`)BO zMFEzl6UR)R>LQ<3H#vH;rq-m~q#B^j4FD{#i=HsEyLz*OAt8A%J0*qI42$K@SUnxb zG3g5N-Fs?eAj+3j<%RncIiMG&C>^^i@M%~;O_UTDkCJaiBb`f^Fo7#03UWeCA*Gws z{eIj0{T-KUQG#H`SBsgI9K>o^3|=LQ6h>yWfo>UO>@~G|Z{lOv`v0Sov7O{^`R?I9 zJ&N_a=%;MYFPrVN>(hd|9f@5*1Hc;6U?U6|s~lFGV9XUh3f2$(e0bmws6?43CMy|e zc#>skbftuI$s`#uv(Rg25C4yxC<}RPBK*Xjw|QsYDR{Clu?=GCBW@!mb_2emUE(7_ zKKth!vmVv~Lz{o){zthr$+Tm-v8c&W&Vu5QZJBcI6)Z(`z=uztZh%6p;FzE)H81@= zCWB^T1vM{)&7jxk_68Gi=_4p7Veb&Lc^&rId~esWqofQ-Gzx-{pl^QwW+jerMz@#(&xNb(^R`_2IrZ5HrNP}2UMqew*%+78_Qgt>hxV$hUXYCN@OT4N^FeSccF97cfTp1HBlRTPABTv+u+gOhgN zqD5P2eXpI14ekMY$AvjQ)Im%d_@lW1gQBSzJUA`9wt4|_m;A|yB~ zsQ`qK=(~0I<$g3_i0meowFL9EGv2uui_?bcvYwqy)@#bS2TCCFx+nV`?NE2f99(2R zk`hVj=rmaM7@Cz0E-r2#}NXH(rd2yVs-k2Zy-)CKfkr zu0;sKHnWqM<>8gfzq5Xv5{8fCJjLB^p#l3`2@GI z%iKp5+Hl(##8pB zr={g!hXj3@D7q3Z{z&kZFo#u(QBDn7^q@T!k2V=!-AM4z%hzO zrHle?Y2N0yF&Mc!PB{GgZlEAX@J6%DwSVz&kBcA%E5c~*_|HT=W8-LjFF#*JD`pf> zO&E_f4}*oWqO#&?=nocK{-LKAddQa3Dg<(o0-RZ8WjNZ*G98nU-d2+=AfAgsAl2J; z>}YE|Wjp4vNLr>n@RSX-xm;|otRIR=XJwr8{Qm<9fG917nRP?%k(_dW{lS(F<!DHE^tjit57b=O@3XW6O4d9Kk)`VrkRU;iJrVAGYl7s{C zML`xIu5iDwcBh>gp|!O1Dqdb*jT$vF)!8j`gQbClOnkB7TU)umlc`-DApF6%(y6B< z#c4;!!LUuLLYO03*#t>g4CoEDTGvQ@7PEm2Uge}Q zz^5*Q0_Yn@qI75%6vj|>^cJ!g7&sXK%yI+c;<#YFjYw1~{!TGvCH}$+q4Kn;%D8x2 zZ%-H10d{)|ehKW6fx>BN;gkQZPMnT2hG08WUKzk)_y}Tf8Y@J41CSYu%aN5O1U~nW z^5NG5R@CGrGG z!*z*-2BoA3qGD~OkTEBCZ8dSJf~Ui7u6yvFTtU&3}JpO@#3(OcwOu%AE8Zvaq zuo7HH{dHwCAHw zDtPo3+@C40&}NI+E3dy2?xo5rn#yYjZhcuKjLswgRmla?(h5M*!u>1hB=mOZONCRU z{)x!0fH9)rl7S=4#sT-b#`8jqtNHtKZAm6)W2k&>ALn(duj?ug#4!hHE`u~uz3S|s zQ54!bWpiF!rLDMcms!^@udb#l)FbC7CE@b#r~*|s4nrQZ8f07CuK!Q=vZllMmRutI pr>l08 threshold. - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Psiref_Utils `_ - diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f deleted file mode 100644 index ee69ef5c..00000000 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ /dev/null @@ -1,41 +0,0 @@ -use bitmasks - - BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_ref ] - implicit none - BEGIN_DOC - ! Reference wave function, defined as determinants with amplitudes > 0.05 - ! idx_ref gives the indice of the ref determinant in psi_det. - END_DOC - integer :: i, k, l - logical :: good - double precision, parameter :: threshold=0.05d0 - double precision :: t(N_states) - N_det_ref = 0 - do l = 1, N_states - t(l) = threshold * abs_psi_coef_max(l) - enddo - do i=1,N_det - good = .False. - do l=1, N_states - psi_ref_coef(i,l) = 0.d0 - good = good.or.(dabs(psi_coef(i,l)) > t(l)) - enddo - if (good) then - N_det_ref = N_det_ref+1 - do k=1,N_int - psi_ref(k,1,N_det_ref) = psi_det(k,1,i) - psi_ref(k,2,N_det_ref) = psi_det(k,2,i) - enddo - idx_ref(N_det_ref) = i - do k=1,N_states - psi_ref_coef(N_det_ref,k) = psi_coef(i,k) - enddo - endif - enddo - call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') - -END_PROVIDER - diff --git a/plugins/Psiref_threshold/tree_dependency.png b/plugins/Psiref_threshold/tree_dependency.png deleted file mode 100644 index 9c2088e1946aea55e4e7034ccb57865b43145554..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8479 zcmch7hd|~rGlKnxFkWNA+$=>6bnI~Du*4`~4HXH;(tq>wTW{exB#Pulu^LN4T!G+Bq^NG6X@+-BMS%3%_^aCxrwbUTb^m zvf&qzwWgX1a&r3ht|}`YLD-R7DmV0f-!7*<(baPpZB8F@F9@+UJH7oRM#)E}-64h}UtL|1}F-^p>W z;iam-91_b<`gEf*=xslv5}KWhCw5M(JsBH6_g8Mtzsn=d<0y_j1bJ$-7#mKHRxBm3 z^$amYM@FxaWviSuYEUFmQ&nBN5^BX1MU<}HA?9=s|0!C9bMWKZp1){vq|UmU zSyNLJ5fPE!lPAQ)#B^kh-Q85Ks6-9B)C;Vv#byMutTBz&`9=a6x-GV%_XX(FyXM>^ z1?VHN69e0Medc|A-o9*=?33$L!OPm22A{K73WmZVk+{_ROO*(y6X)Zn`=8pY%UvoCZhc z-5hXO0A{wc~Rp99xC*Qq$*WKOy?KDIb6cq3oY>x$)FrRxD`}+E1 zd{#V1rdCEOd{#%VF-7?j`EL-OIdg`PP(AZ!ZLMNu9vK-Kbwr~Ucf8RNYuo&Mc9BzU zOkh=26+EPG9&T(b#=)jwaN=KB?T}DX#zaNYkq|a4`cUhLmz(E3eDL4_3WaiZ{`2RL zGYU07KQEHffgluNG|bHWaq6%xoGywyj$f5?4SasT)8*aY-+z;ma*l`qLDyNT+`M_2 zi%UgSwW+z8hl{JBu`z$p`Tf12sq?CgWk`faEda~!#OiWA{ z{{;QR|MxGH zl$2idX@=loYinp|XlZHPzI|I=9cJm;H_MIj@$$N- zuis+({l||VFo*T^M{(+#Ygo$W=H{#qr_s>VbT?--FxO+jD&NT1#KcZCS&Q4r*|{?C zXn$=@BuZ6NL&Lbh{x*#5?d^?1Wiuy~cF#lVFbJDh`mS5wyLV4dk0#U#hr_`xEG#U* zYinyOifYouNZ=KG28e_aXB%1h+NyUp&8=qYvXi9PTgW_4fACN6f^jv9@+} zbhNhKukzcfH~(e9h@m`pE>%9D{KJRozcXz_!5s4P^4I?bKYv7{bw^EL!+*_|BKrFJ zZxw>7zkK;pR+ijhpJ!1MxYU;mPj)}nHPBqukeBxI<;#tYjdXN$uyO0nY$qeDfk`PT zOQa5iFB&yrkMG|f94v6?N>_N8Z}k29cc_ID*Ac!rb=Jzel0NPB8$M$JCEm-%qRH*{ z1?i7xli7j}@8tC>DBdG!AfNXvXM+u1$V#^_7_=3Y5)<1vSgm1WW`2VHG;6;(Iy$;D z`b0;7UXM2+*QA7=fq^-yi5Nxq^fe7p@Wga$JUnNHE-!WXbTFm7E-$Uer@H%?l9G~# zL&Z_57^tely{@2@#l<%j#)Q_@!&OgqQhi3(cXqOHC>ifRP#kXG$N#7r=IB4!{*%$O z(Dq7@pN|iAeIx#*Vmm{8>n5apQ)A;*#z=*u1)W`wR57vm(?S@);~_gIytKS=wa@T|%>2T^SdZPEg`Tcdmv_Zp@AN@R0hBd&l9- zf{k-ei!euj@#F0j0N0Ogvqr_Sjxkq5%rAWlbmc4d%GL*Y(E!7_{dg9&aTT1PYkqP z=%9!g-~PoS^;_~}trpw*X_>1dUmp*&~3R!h*2gvM}+-!?=$D6OXrA!M|8F)M+0`uo+@?^4J`?| z^w?CawA=e`aGTZy{_M8v|2i0DXJ`_5{K1)#sN|uKuCfyTFO;eEX3m=!w)7-*o_;L( z@*6D?v7Q_2UP~)aMvCh*I2c)Eugt9mt#Uy3+}_+=+dJGD3mOv&_^&iS|7uXs38lhe zcU1ky=82{PxeIpr?8usM&{KCQ7Up0+Isw7wWo7X%hkCga>kAw*w0BOz!zhk|puy?p zgs5Kn^6A-UgB!^B@lo{Bqr2Ol3mhEZ3TYk1zf~~1j*{b{o%%ZsKZq?^g?cL-GvXs> z@OQWR-Q1`sDC+a7pUJWkBJ}jqM%e)e?1+c}xp_6Ym$dH!HTk(M7Fd>({r;Mljn)+r zA@L2@#KjS0acOCU-adHKPG$w_$cb%yFaZdrfE;vy+t*PVxt)<4KT zctC~t&iwe$5KTdXL`Hj?#>9Wm(iG;eNdGxViib8`@xLiuz-o`WeuWetiD60BUtF^y zK}_@O>y#!sQl&f;JZ^=nT{xQUNI}rEv-U#`wI3LZPjE6h4<7pu~rS)IM~GkHryxk6r^ z3dz>jcJy?k!bg&|h|e}!DkATe<=#wK#fbVrzd_!8`t(EM(NCU*`uchVadC0k@cr8! z^~L<$@861cmw5%C{i3mWbDd95j>eK-4pb>eDU?ZF#pC8iLh;B6`W&PL>61{~>tzZG zdp)K*$)D97`hvxlh3JfpjS&R;aQxln?a+jTgo`rXrH^(}(#pK4cX7l0{f{1n73G@3 z@)Q-Fy+W|+nl*aU+o($^ywGlTOXS*lwsICZ=_}ZN3*pg>Hjgg3q&IIIlTgB6OG{s? zaHh)mbeeto=+Ni2GmrU}O|reI7;y$RI+&Q_TiNb>WY}8A6?&|4*m$Z;H!6gi#`(ch zi$GE_(YJ|KYKjOU!YU*2pisn2?kuOf_L7w&XP_t_Z9PUU<1T5UhVL{9EeX3(0uM&v zF9#XEqT{OlPg9dUz1vO9(M$REX-nMx3z<^C z3fMX43RypLztLL5sa^aPn;LLp|IH-AxzQmzw~~dPRxyY6Cn~lzgp_nGw`9B{ zrSr!(8(YHaZ6@-w!Q#K4T?nv`^Dw5Qpt;SxyWT8vg>-*ck(-A5a$PVnkKA9&q?!U6 zD3U?v`K7ZKj~kU;8IR@^PR^4M#>j2I9>igpq8pPtX6Mp_(lj!wp`}o6D-q*QNI-Xb zN&XP%(rGJdV{QF0+Lwxiaw5qhFg!fms$ejTk}Zv6NFXc)C`nd& z;2RZAI|m1vJuXa`$cW+~0mZO+3$PG(4-Y)#@#Dt@)sEA@W^*9*T3XoSTT`w-ln**S zY}Y9jwu{Bdp{Z`uR$DX`T=aDXupES8AAxa!69izoALplma;#+a*gw}Xh z8OeFH-}*v(x-alboy!k;25_Z0<5mJzwgV3TlcSxzy*(ha+F1&F)A2WN-o$v9OuV(PPXD0yxi?EEUH;Le%HzjU&y`x++Zz;A zOZ@l#?&(LY8M}^@-!nK3@0lNTWsF z4!)a1>vPx?#f&Std0q^o&j-W@9h72_p-V_eI6XZryFFk7t9h1Ay6JLy)XJYf0>b}- zpT7qs4t)ReWxM6yMY}xtcO*F)=I2p%b~AZ3$1j7VtMc+-s~sB z7h#G@OiTop24R?I-s@Q8Eb(OKMeWXJjf$Jvg~rQ3Ue-$Wx3;!Q9**@bZ6WA^fq~7<&0b)H=2g=2@}n*zELL^pplPm! zp0DO4Cn5+}c^MfQ8F3oeOBY}T1=!iqRL@D~E-*5p93342$l$qMPovsnjv^!$J0W0E zEqmokD-#x#fltvz7xO}c7^xNcg252PX!H*cN9KLU;qD-4MfMj_QH{B5=g&V?E2WKS z{E&J4F_IXch?Hq~Q(KJM)Pr57nrM`8thPg7G9 zD7}Y=nEa)rwyWd>hzMikw^kJum2o_;JCRX)HX@8`=yK3EMWMpLy%twinh2`z^3vw$ zJIXCKHJnCBXsDm_>QtGk&x=NDAjMyS87hZGsbaPvqd|6c75-EQXL;@%~Umn{L zXR_z@KAoYG7gLml3r z+{C(J8_pPD@Ta(BIdaQlm_@Hml#!ew3_G{6=P#eEMNdM=MNOJc_FQSH5`Z?o^{m(T zOdLvt9IFtNWAGUd+12xeTxATMsBwfuP{s5wx%k-dgMM$DnLH3XcCqsx^?sQp{KAs5 z*(7pBRywuw_mxk*j{d57{Z2*3!`=oP_ve<|9ZZ;ym%cc;LM%(1 z)_rA{IMjJ*C&f&K7|b$@2ri6_$ZoWYA?T^*7#hKb3L`SCFrl?UEbhEHo~U#^zoM#| z@0pf)l04+X#R)og%%w{F|MeRFZ*Jnl;lGj>6chxW&=*8ZM1&v!nSBYdv9X{o@e>}? zw9E^samOzYGc z?**%?t3iY7^GWNuOJ%G15bN`K4Hdh1KYhI5xev%2+crWVTAnfhmyk#YrlINS>kI8FEG(oFY>rS=W+?e?(@Y_q3Q3zKPm6ZD0^{+g zrlwNLZBilcs;cBfMgK!dnG=@3sEEz(b;N)$XDTwz)y`sOV{7i|urI)&8sF=IDMcCBZ zjjzYYfe6}2AZFsHinykSYdN!m$WS$PuP#Fw|-EPzm4zz7sVXtskkY ztLy6O+Wre8qt_!B@2@s2MS>_E#o-%S=ayhK5E)Tv7qQU}+Hqyb!qOaSZG{KwNeo$x{Q|pjaa97_~vy|jy zXe{c5KhM|$hFMyUgJ+N=Z1FWa8};Bporr*}tSmHJXqNnjU$t)Cx?w2t(Z<);h&$e_ zLJgi1oSKM;HZWFTTYvm8X8LH+pxWEz-^FVA`TDAL(28iGH zXM{8oG-isN`oEf28JnA%o0!PR%d@hvrKhG=0gV_QHf4=bE3759UB6J3nK|<-M-TiD zFgs|;F7xv{O+jP7?g~ziYL~aL00x5*P5uJrLuF;<`}g?RZ_r!eGAqrGkDEIb<>g_6 zW2~yFIjLB!mI3DC;vyJaXH*k-sz}oP|K7^c*C-Uvdk4lrVc}+bvRIOk851+J=Iz@7 zv&jzLe+JG|Q7IOR&!N+z2Az*VvZuj&_!9Z3NW52u@0*%_>0b)(o2i=L+K=basotH8 z@Rv_l#kh=CmVu|_EJ2g&L@(Pv?_TD=I$FgU_d+96e!YQ4;cyK*KhKMMPqlNEDQYa} z1(z0)bP3iVT3S~@v786Hmho{obx1Sl#Ek2WOo?(Qy&q+6{= z=SSK4d56xoq-1218+)*9q>GJ7h<(A{!=MA^nC5tm%u_vqb7$uoo(D(d4J-9%5i+jUMau8~0A_w@Hf6{@j`#bX*2+1Iq#yXn3rgu0B#;Qu6id z*No@SKLR0=Br(0Vf)}OwIXl~}diT(-@?fRHqdZ`u5|`S3Yutqf+A%%-tG92p-t~vy z{|k;CkS!pPWu_~O#m?8iwc3^k9{G8DOCaoGVm-aLho04N`2C%}#j~2*J~ppyFwa_E zUjF|5d#D^I(PWbIitYcc4i*5PxOV+|MMiE8Gh>WGopt_jcRAhRO=5EF+xD7;A(&|5qQ-le;^{ z`ou|`$s*`z3tAD`bL*oVfDAD4y5@QoHnX#{!Pbh7jI4doq)o~Ggh-BpKiz6xbc3@Z zS~-m3PLBSLr<*sG<)&GMx1dG!@Lsh`+JLKN!Jt3z+pVSkAqq3^<=@u~E2ih>hU~E- z?Gp~203T~RgR&j-V#42-YDENugjNy_%^!Iw>pd#LT_rzDLL%wA_HM}7v-GBmjw(3! z$hdIOUWBO-7VIpaFtN=+5hr#^b!Xr1%rivR>K@3@;Jf}Trz(rE=o!PR6f5xLH` zZ)busCg5R1GLlWy2C;JRYt*b~Bo7|uMK%T^@0m1K@dsw#P z*o1`X(9l2ZwexHNo9APiVdqZsFidWL9s`OGNEehb5bN=};M&Ie8bV1XMn?0Cp&ymdxL!vuXgo0ek)Gi%6dsbJzFWP97wOZ#7GEFr z#ahXY-v|=|cAp~Q^2T@w(9+eXbuu%_-2G!?j>7GdmakKd3>FFMTyQSbd+zr0*Cuu# zfZ5~JVJ@yHCxbAMXaK-6oSe^8F`#a9&8zk!gsZ>FyUcySafAS~gmaj?ISHzmtI6#l zAt5EBeoN3Fw12#QIp{0|TtHjf{`5dVOiHTk+c&pGn|5Ftc~#rSKqj{0wF>ysAIF(B z#9dNT=lXBt41dXu0l5hRVv6pCP3Q{LmyrqWz{7Plrl{@XgH@W#Xc3GJBUmdBb$JuO zGo-50DGW(|{d#vin6kz8FGzZlgd1xS3~Di~cKJrh$;oMl_m>T9S_;P)JZI7-xv&V)*$j{Am0W$1%mck>PwY-(x*uz7IBdrtD&h`@clc2 z@Ed#qw}ws51^f6F?vV)j!Az3H8p9~G846a}7xH~G`J3C@uq@5H&0fF`+>Q?)zo(OG zqKR_NEH3tj&jKc@kvTgvlbDe3F0a~`1lkR_{=3Z`CXS)V_BYO!^Q#~r2;k3iNf;BN**2? znVLy!EmGipKq~R@IKY_$I2^~v$10yw#3Fvq8)$L&fGr?wQSHC*GxN%VKH-HHcfNj8@fbt3oy7Yd!2Ot6g`Vy7Q+R)O{0t$#3DDL7S*b6W!H#fHm=N-6) zfYtT$+iw@v5#)Rojax=JIeo5D3kWy@27|BzRfaLIUOgWp#dP7qf?VBFf(DplJgnxM zaFP@i6$M%wskIdaMHA;26UOTI0+lIb)yg#T3Q`BGpz%1&y2~&a6g8;!sdeW|YH)-N za!E7uu6(*q;UcjL1_x>KW5#_5jRSpSoJ)@=X7wZqn$WYc)%fqZ%es52s1QPF8W**# zlVNo1{QWC?&P%6Kbk$ntKMM|qLuM~N>Tm!_IGy%tI!f{rA!lY~HOSE~?nz5ad-@a) z$o$xta8g^8>ZP>g=Bb<79Gsl>GQs+OIk+rk5RbHE!{TrT3+-rEKSMWLpRZuhIpunrfz0WGKh3(!2}UIvn>!~QHGJ{$uBPWsD-VUwL`p-sH+UxL%#Qw0_Us6iB5 zhZ0}(l+HDX82T-t5L`zUu5#nX4KO?S5-0VbVu7~P(oV}^L>&}W(+S}A-!cE>R_Qf0 zH8pSsjB}ghK>2$~j{uP}?{=0jkujDTa4z0*J)5Wj$MLePlw&4f3d&=r)+Jdesx1KT z?o(cImKeINS-pGXRM=~t2oOF+K;8@E{g1qVc0yoOdhv{PmQ4@L3AuGsTji^g<+J|> DeZzG2 diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f deleted file mode 100644 index c772e2aa..00000000 --- a/plugins/mrcc_selected/dressing.irp.f +++ /dev/null @@ -1,1076 +0,0 @@ -use bitmasks - - - - BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc - integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) - integer(bit_kind),allocatable :: buf(:,:,:) - logical :: ok - logical, external :: detEq - - delta_ij_mrcc = 0d0 - delta_ii_mrcc = 0d0 - delta_ij_s2_mrcc = 0d0 - delta_ii_s2_mrcc = 0d0 - PROVIDE dij - provide hh_shortcut psi_det_size! lambda_mrcc - !$OMP PARALLEL DO default(none) schedule(dynamic) & - !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & - !$OMP private(h, n, mask, omask, buf, ok, iproc) - do gen= 1, N_det_generators - allocate(buf(N_int, 2, N_det_non_ref)) - iproc = omp_get_thread_num() + 1 - if(mod(gen, 1000) == 0) print *, "mrcc ", gen, "/", N_det_generators - do h=1, hh_shortcut(0) - call apply_hole_local(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) - if(.not. ok) cycle - omask = 0_bit_kind - if(hh_exists(1, h) /= 0) omask = mask - n = 1 - do p=hh_shortcut(h), hh_shortcut(h+1)-1 - call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) - if(ok) n = n + 1 - if(n > N_det_non_ref) stop "MRCC..." - end do - n = n - 1 - - if(n /= 0) then - call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) - endif - - end do - deallocate(buf) - end do - !$OMP END PARALLEL DO -END_PROVIDER - - -! subroutine blit(b1, b2) -! double precision :: b1(N_states,N_det_non_ref,N_det_ref), b2(N_states,N_det_non_ref,N_det_ref) -! b1 = b1 + b2 -! end subroutine - - -subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,l,m - integer,allocatable :: idx_alpha(:), degree_alpha(:) - logical :: good, fullMatch - - integer(bit_kind),allocatable :: tq(:,:,:) - integer :: N_tq, c_ref ,degree - - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) - double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - integer(bit_kind) :: tmp_det(Nint,2) - integer :: iint, ipos - integer :: i_state, k_sd, l_sd, i_I, i_alpha - - integer(bit_kind),allocatable :: miniList(:,:,:) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - integer,allocatable :: idx_miniList(:) - integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:), sij_cache(:) - - integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) - integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) - integer :: mobiles(2), smallerlist - logical, external :: detEq, is_generable - !double precision, external :: get_dij, get_dij_index - - - leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) - allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) - !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) - -! if(fullMatch) then -! return -! end if - - allocate(ptr_microlist(0:mo_tot_num*2+1), & - N_microlist(0:mo_tot_num*2) ) - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - - if(key_mask(1,1) /= 0) then - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - call filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - else - call filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - end if - - - - deallocate(microlist, idx_microlist) - - allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) - - ! |I> - - ! |alpha> - - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) - if(N_minilist == 0) return - - - if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! - allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) - - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - - - do i=0,mo_tot_num*2 - do k=ptr_microlist(i),ptr_microlist(i+1)-1 - idx_microlist(k) = idx_minilist(idx_microlist(k)) - end do - end do - - do l=1,N_microlist(0) - do k=1,Nint - microlist_zero(k,1,l) = microlist(k,1,l) - microlist_zero(k,2,l) = microlist(k,2,l) - enddo - idx_microlist_zero(l) = idx_microlist(l) - enddo - end if - end if - - - do i_alpha=1,N_tq - if(key_mask(1,1) /= 0) then - call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) - - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - - do l=0,N_microlist(smallerlist)-1 - microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) - idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) - end do - - call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) - end do - - else - call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_miniList(idx_alpha(j)) - end do - end if - - - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) - call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) - enddo - ! |I> - do i_I=1,N_det_ref - ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then - cycle - endif - - do i_state=1,N_states - dIa(i_state) = 0.d0 - enddo - - ! |alpha> - do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 - logical :: loop -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo -! if (loop) then -! cycle -! endif - - call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) - if (degree > 2) then - cycle - endif - - ! - ! - !hIk = hij_mrcc(idx_alpha(k_sd),i_I) - ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - - do i_state=1,N_states - dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) - !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) - enddo - - - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - logical :: ok - call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if(.not. ok) cycle - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo - loop = .false. - if (.not.loop) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - hIl = hij_mrcc(idx_alpha(l_sd),i_I) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 - !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 - enddo - endif - - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) - enddo - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - hla = hij_cache(k_sd) - sla = sij_cache(k_sd) -! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) - do i_state=1,N_states - dIa_hla(i_state,k_sd) = dIa(i_state) * hla - dIa_sla(i_state,k_sd) = dIa(i_state) * sla - enddo - enddo - call omp_set_lock( psi_ref_lock(i_I) ) - do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else - delta_ii_(i_state,i_I) = 0.d0 - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) - enddo - endif - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) - enddo - enddo - deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) - deallocate(miniList, idx_miniList) -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: i, j, i_state - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - - if(mrmode == 3) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) - enddo - end do - end do - - ! =-=-= BEGIN STATE AVERAGE -! do i = 1, N_det_ref -! delta_ii(:,i)= delta_ii_mrcc(1,i) -! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) -! do i_state = 2, N_states -! delta_ii(:,i) += delta_ii_mrcc(i_state,i) -! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) -! enddo -! do j = 1, N_det_non_ref -! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) -! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) -! do i_state = 2, N_states -! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) -! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) -! enddo -! end do -! end do -! delta_ij = delta_ij * (1.d0/dble(N_states)) -! delta_ii = delta_ii * (1.d0/dble(N_states)) - ! =-=-= END STATE AVERAGE - ! - ! do i = 1, N_det_ref - ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) - ! do j = 1, N_det_non_ref - ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) - ! end do - ! end do - else if(mrmode == 2) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_old(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) - enddo - end do - end do - else if(mrmode == 1) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) - enddo - end do - end do - else - stop "invalid mrmode" - end if -END_PROVIDER - - -BEGIN_PROVIDER [ integer, HP, (2,N_det_non_ref) ] - integer :: i - do i=1,N_det_non_ref - call getHP(psi_non_ref(1,1,i), HP(1,i), HP(2,i), N_int) - end do -END_PROVIDER - - BEGIN_PROVIDER [ integer, cepa0_shortcut, (0:N_det_non_ref+1) ] -&BEGIN_PROVIDER [ integer, det_cepa0_idx, (N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0_active, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_ref_active, (N_int,2,N_det_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), active_sorb, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer, nlink, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, linked, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ integer, blokMwen, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, searchance, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, child_num, (N_det_non_ref,N_det_ref) ] - - use bitmasks - implicit none - - integer(bit_kind),allocatable :: det_noactive(:,:,:) - integer, allocatable :: shortcut(:), idx(:) - integer(bit_kind) :: nonactive_sorb(N_int,2), det(N_int, 2) - integer i, II, j, k, n, ni, blok, degree - logical, external :: detEq - - allocate(det_noactive(N_int, 2, N_det_non_ref)) - allocate(idx(N_det_non_ref), shortcut(0:N_det_non_ref+1)) - print *, "pre start" - active_sorb(:,:) = 0_8 - nonactive_sorb(:,:) = not(0_8) - - if(N_det_ref > 1) then - do i=1, N_det_ref - do k=1, N_int - active_sorb(k,1) = ior(psi_ref(k,1,i), active_sorb(k,1)) - active_sorb(k,2) = ior(psi_ref(k,2,i), active_sorb(k,2)) - nonactive_sorb(k,1) = iand(psi_ref(k,1,i), nonactive_sorb(k,1)) - nonactive_sorb(k,2) = iand(psi_ref(k,2,i), nonactive_sorb(k,2)) - end do - end do - do k=1, N_int - active_sorb(k,1) = iand(active_sorb(k,1), not(nonactive_sorb(k,1))) - active_sorb(k,2) = iand(active_sorb(k,2), not(nonactive_sorb(k,2))) - end do - end if - - - do i=1, N_det_non_ref - do k=1, N_int - det_noactive(k,1,i) = iand(psi_non_ref(k,1,i), not(active_sorb(k,1))) - det_noactive(k,2,i) = iand(psi_non_ref(k,2,i), not(active_sorb(k,2))) - end do - end do - - call sort_dets_ab(det_noactive, det_cepa0_idx, cepa0_shortcut, N_det_non_ref, N_int) - - do i=1,N_det_non_ref - det_cepa0(:,:,i) = psi_non_ref(:,:,det_cepa0_idx(i)) - end do - - cepa0_shortcut(0) = 1 - cepa0_shortcut(1) = 1 - do i=2,N_det_non_ref - if(.not. detEq(det_noactive(1,1,i), det_noactive(1,1,i-1), N_int)) then - cepa0_shortcut(0) += 1 - cepa0_shortcut(cepa0_shortcut(0)) = i - end if - end do - cepa0_shortcut(cepa0_shortcut(0)+1) = N_det_non_ref+1 - - if(.true.) then - do i=1,cepa0_shortcut(0) - n = cepa0_shortcut(i+1) - cepa0_shortcut(i) - call sort_dets_ab(det_cepa0(1,1,cepa0_shortcut(i)), idx, shortcut, n, N_int) - do k=1,n - idx(k) = det_cepa0_idx(cepa0_shortcut(i)-1+idx(k)) - end do - det_cepa0_idx(cepa0_shortcut(i):cepa0_shortcut(i)+n-1) = idx(:n) - end do - end if - - - do i=1,N_det_ref - do k=1, N_int - det_ref_active(k,1,i) = iand(psi_ref(k,1,i), active_sorb(k,1)) - det_ref_active(k,2,i) = iand(psi_ref(k,2,i), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - do k=1, N_int - det_cepa0_active(k,1,i) = iand(psi_non_ref(k,1,det_cepa0_idx(i)), active_sorb(k,1)) - det_cepa0_active(k,2,i) = iand(psi_non_ref(k,2,det_cepa0_idx(i)), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - if(.not. detEq(psi_non_ref(1,1,det_cepa0_idx(i)), det_cepa0(1,1,i),N_int)) stop "STOOOP" - end do - - searchance = 0d0 - child_num = 0 - do J = 1, N_det_ref - nlink(J) = 0 - do blok=1,cepa0_shortcut(0) - do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) - if(degree <= 2) then - nlink(J) += 1 - linked(nlink(J),J) = k - child_num(k, J) = nlink(J) - blokMwen(nlink(J),J) = blok - searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) - end if - end do - end do - end do - print *, "pre done" -END_PROVIDER - - -! BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -! use bitmasks -! implicit none -! integer :: i,j,k -! double precision :: Hjk, Hki, Hij, pre(N_det_ref), wall -! integer :: i_state, degree, npre, ipre(N_det_ref), npres(N_det_ref) -! -! ! provide lambda_mrcc -! npres = 0 -! delta_cas = 0d0 -! call wall_time(wall) -! print *, "dcas ", wall -! do i_state = 1, N_states -! !!$OMP PARALLEL DO default(none) schedule(dynamic) private(pre,npre,ipre,j,k,Hjk,Hki,degree) shared(npres,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) -! do k=1,N_det_non_ref -! if(lambda_mrcc(i_state, k) == 0d0) cycle -! npre = 0 -! do i=1,N_det_ref -! call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) -! if(Hki /= 0d0) then -! !!$OMP ATOMIC -! npres(i) += 1 -! npre += 1 -! ipre(npre) = i -! pre(npre) = Hki -! end if -! end do -! -! -! do i=1,npre -! do j=1,i -! !!$OMP ATOMIC -! delta_cas(ipre(i),ipre(j),i_state) += pre(i) * pre(j) * lambda_mrcc(i_state, k) -! end do -! end do -! end do -! !!$OMP END PARALLEL DO -! npre=0 -! do i=1,N_det_ref -! npre += npres(i) -! end do -! !stop -! do i=1,N_det_ref -! do j=1,i -! delta_cas(j,i,i_state) = delta_cas(i,j,i_state) -! end do -! end do -! end do -! -! call wall_time(wall) -! print *, "dcas", wall -! ! stop -! END_PROVIDER - - - BEGIN_PROVIDER [ double precision, delta_cas, (N_det_ref, N_det_ref, N_states) ] -&BEGIN_PROVIDER [ double precision, delta_cas_s2, (N_det_ref, N_det_ref, N_states) ] - use bitmasks - implicit none - integer :: i,j,k - double precision :: Sjk,Hjk, Hki, Hij - !double precision, external :: get_dij - integer i_state, degree - - provide lambda_mrcc dIj - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,delta_cas_s2,N_det_ref,dij) - do i=1,N_det_ref - do j=1,i - call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) - delta_cas(i,j,i_state) = 0d0 - delta_cas_s2(i,j,i_state) = 0d0 - do k=1,N_det_non_ref - - call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) - call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) - - delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_cas_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) - end do - delta_cas(j,i,i_state) = delta_cas(i,j,i_state) - delta_cas_s2(j,i,i_state) = delta_cas_s2(i,j,i_state) - end do - end do - !$OMP END PARALLEL DO - end do - END_PROVIDER - - - - -logical function isInCassd(a,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - isInCassd = .false. - - deg = 0 - do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) return - end do - end do - - deg = 0 - do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) return - end do - end do - isInCassd = .true. -end function - - -subroutine getHP(a,h,p,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer, intent(out) :: h, p - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - !isInCassd = .false. - h = 0 - p = 0 - - deg = 0 - lp : do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) exit lp - end do - end do lp - p = deg - - deg = 0 - lh : do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) exit lh - end do - end do lh - h = deg - !isInCassd = .true. -end function - - - BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, m, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) - integer(bit_kind),allocatable :: sortRef(:,:,:) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit, searchDet - logical, external :: is_in_wavefunction, detEq - !double precision, external :: get_dij - integer :: II, blok - integer*8, save :: notf = 0 - - call wall_time(wall) - allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) - - sortRef(:,:,:) = det_ref_active(:,:,:) - call sort_det(sortRef, sortRefIdx, N_det_ref, N_int) - - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - ! To provide everything - contrib = dij(1, 1, 1) - - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 - delta_mrcepa0_ii_s2(:,:) = 0d0 - delta_mrcepa0_ij_s2(:,:,:) = 0d0 - - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & - !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas, delta_cas_s2) & - !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) - do blok=1,cepa0_shortcut(0) - do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - do II=1,N_det_ref - call get_excitation_degree(psi_ref(1,1,II),psi_non_ref(1,1,det_cepa0_idx(i)),degree,N_int) - if (degree > 2 ) cycle - - do ni=1,N_int - made_hole(ni,1) = iand(det_ref_active(ni,1,II), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_hole(ni,2) = iand(det_ref_active(ni,2,II), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - - made_particle(ni,1) = iand(det_cepa0_active(ni,1,i), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_particle(ni,2) = iand(det_cepa0_active(ni,2,i), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - end do - - - kloop: do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 !i - !if(lambda_mrcc(i_state, det_cepa0_idx(k)) == 0d0) cycle - - do ni=1,N_int - if(iand(made_hole(ni,1), det_cepa0_active(ni,1,k)) /= 0) cycle kloop - if(iand(made_particle(ni,1), det_cepa0_active(ni,1,k)) /= made_particle(ni,1)) cycle kloop - if(iand(made_hole(ni,2), det_cepa0_active(ni,2,k)) /= 0) cycle kloop - if(iand(made_particle(ni,2), det_cepa0_active(ni,2,k)) /= made_particle(ni,2)) cycle kloop - end do - do ni=1,N_int - myActive(ni,1) = xor(det_cepa0_active(ni,1,k), made_hole(ni,1)) - myActive(ni,1) = xor(myActive(ni,1), made_particle(ni,1)) - myActive(ni,2) = xor(det_cepa0_active(ni,2,k), made_hole(ni,2)) - myActive(ni,2) = xor(myActive(ni,2), made_particle(ni,2)) - end do - - j = searchDet(sortRef, myActive, N_det_ref, N_int) - if(j == -1) then - cycle - end if - j = sortRefIdx(j) - !$OMP ATOMIC - notf = notf+1 - -! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) - contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - contrib_s2 = delta_cas_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - - if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - !$OMP ATOMIC - delta_mrcepa0_ii(J,i_state) -= contrib2 - delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 - else - contrib = contrib * 0.5d0 - contrib_s2 = contrib_s2 * 0.5d0 - end if - !$OMP ATOMIC - delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib - delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 - - end do kloop - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) - call wall_time(wall) - print *, "cepa0", wall, notf - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, delta_sub_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_sub_ii, (N_det_ref, N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ - logical :: ok - double precision :: phase_Ji, phase_Ik, phase_Ii - double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl - integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit - - integer :: II, blok - - provide delta_cas lambda_mrcc - allocate(idx_sorted_bit(N_det)) - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - do i_state = 1, N_states - delta_sub_ij(:,:,:) = 0d0 - delta_sub_ii(:,:) = 0d0 - - provide mo_bielec_integrals_in_map - - - !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & - !$OMP private(i, J, k, degree, degree2, l, deg, ni) & - !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & - !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & - !$OMP private(det_tmp, det_tmp2, II, blok) & - !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & - !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) - do i=1,N_det_non_ref - if(mod(i,1000) == 0) print *, i, "/", N_det_non_ref - do J=1,N_det_ref - call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_Ji,degree,phase_Ji,N_int) - if(degree == -1) cycle - - - do II=1,N_det_ref - call apply_excitation(psi_ref(1,1,II),exc_Ji,det_tmp,ok,N_int) - - if(.not. ok) cycle - l = get_index_in_psi_det_sorted_bit(det_tmp, N_int) - if(l == 0) cycle - l = idx_sorted_bit(l) - - call i_h_j(psi_ref(1,1,II), det_tmp, N_int, HIl) - - do k=1,N_det_non_ref - if(lambda_mrcc(i_state, k) == 0d0) cycle - call get_excitation(psi_ref(1,1,II),psi_non_ref(1,1,k),exc_Ik,degree2,phase_Ik,N_int) - - det_tmp(:,:) = 0_bit_kind - det_tmp2(:,:) = 0_bit_kind - - ok = .true. - do ni=1,N_int - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,k)), not(active_sorb(ni,1))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,i)), not(active_sorb(ni,1))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,k)), not(active_sorb(ni,2))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,i)), not(active_sorb(ni,2))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - end do - - if(ok) cycle - - - call i_h_j(psi_ref(1,1,J), psi_non_ref(1,1,k), N_int, HJk) - call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,k), N_int, HIk) - if(HJk == 0) cycle - !assert HIk == 0 - delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(ok) cycle - contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) - if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) - !$OMP ATOMIC - delta_sub_ii(II,i_state) -= contrib2 - else - contrib = contrib * 0.5d0 - endif - !$OMP ATOMIC - delta_sub_ij(II, i, i_state) += contrib - end do - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) -END_PROVIDER - - -subroutine set_det_bit(det, p, s) - implicit none - integer(bit_kind),intent(inout) :: det(N_int, 2) - integer, intent(in) :: p, s - integer :: ni, pos - - ni = (p-1)/bit_kind_size + 1 - pos = mod(p-1, bit_kind_size) - det(ni,s) = ibset(det(ni,s), pos) -end subroutine - - - BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] -&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] - implicit none - integer :: i,j - do i=1,N_det_ref - do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) - call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) - end do - end do -END_PROVIDER - - - -subroutine filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) - integer,intent(in) :: N_miniList - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - do k=1, N_minilist - if(is_generable(miniList(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retournĂ© par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - -subroutine filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: microlist(Nint,2,*) - integer,intent(in) :: ptr_microlist(0:*) - integer,intent(in) :: N_microlist(0:*) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - - integer :: mobiles(2), smallerlist - - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - if(N_microlist(smallerlist) > 0) then - do k=ptr_microlist(smallerlist), ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - if(N_microlist(0) > 0) then - do k=1, N_microlist(0) - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retournĂ© par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - - - diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f deleted file mode 100644 index c2e5dd55..00000000 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ /dev/null @@ -1,601 +0,0 @@ -subroutine mrsc2_dressing_slave_tcp(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(0,i) -end - - -subroutine mrsc2_dressing_slave_inproc(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(1,i) -end - -subroutine mrsc2_dressing_slave(thread,iproc) - use f77_zmq - - implicit none - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - integer, intent(in) :: thread, iproc -! integer :: j,l - integer :: rc - - integer :: worker_id, task_id - character*(512) :: task - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_push_socket - integer(ZMQ_PTR) :: zmq_socket_push - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - - - integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, degree, degree2, m, l, deg, ni, m2 - integer :: n(2) - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al - double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, contrib_s2, wall, iwall - double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - integer,allocatable :: komon(:) - logical :: komoned - !double precision, external :: get_dij - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_push = new_zmq_push_socket(thread) - - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) - - allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) - allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) - allocate(komon(0:N_det_non_ref)) - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) exit - read (task,*) i_I, J, k1, k2 - do i_state=1, N_states - ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) - cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) - end do - n = 0 - delta(:,0,:) = 0d0 - delta(:,:nlink(J),1) = 0d0 - delta(:,:nlink(i_I),2) = 0d0 - delta_s2(:,0,:) = 0d0 - delta_s2(:,:nlink(J),1) = 0d0 - delta_s2(:,:nlink(i_I),2) = 0d0 - komon(0) = 0 - komoned = .false. - - - - - do kk = k1, k2 - k = det_cepa0_idx(linked(kk, i_I)) - blok = blokMwen(kk, i_I) - - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,k),exc_Ik,degree,phase_Ik,N_int) - - if(J /= i_I) then - call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int) - if(.not. ok) cycle - - l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2, cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int) - if(l == -1) cycle - ll = cepa0_shortcut(blok)-1+l - l = det_cepa0_idx(ll) - ll = child_num(ll, J) - else - l = k - ll = kk - end if - - - if(.not. komoned) then - m = 0 - m2 = 0 - - do while(m < nlink(i_I) .and. m2 < nlink(J)) - m += 1 - m2 += 1 - if(linked(m, i_I) < linked(m2, J)) then - m2 -= 1 - cycle - else if(linked(m, i_I) > linked(m2, J)) then - m -= 1 - cycle - end if - i = det_cepa0_idx(linked(m, i_I)) - - if(h_cache(J,i) == 0.d0) cycle - if(h_cache(i_I,i) == 0.d0) cycle - - komon(0) += 1 - kn = komon(0) - komon(kn) = i - - do i_state = 1,N_states - dkI = h_cache(J,i) * dij(i_I, i, i_state) - dleat(i_state, kn, 1) = dkI - dleat(i_state, kn, 2) = dkI - - dkI = s2_cache(J,i) * dij(i_I, i, i_state) - dleat_s2(i_state, kn, 1) = dkI - dleat_s2(i_state, kn, 2) = dkI - end do - - end do - - komoned = .true. - end if - - integer :: hpmin(2) - hpmin(1) = 2 - HP(1,k) - hpmin(2) = 2 - HP(2,k) - - do m = 1, komon(0) - - i = komon(m) - if(HP(1,i) <= hpmin(1) .and. HP(2,i) <= hpmin(2) ) then - cycle - end if - - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(.not. ok) cycle - - do i_state = 1, N_states - contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) - contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) - delta(i_state,ll,1) += contrib - delta_s2(i_state,ll,1) += contrib_s2 - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then - delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - endif - - if(I_i == J) cycle - contrib = dij(J, l, i_state) * dleat(i_state, m, 1) - contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) - delta(i_state,kk,2) += contrib - delta_s2(i_state,kk,2) += contrib_s2 - if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then - delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - end if - enddo !i_state - end do ! while - end do ! kk - - - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - -! end if - - enddo - - deallocate(delta) - - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - -end - - -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer, intent(in) :: i_I, J - integer(ZMQ_PTR), intent(in) :: zmq_socket_push - double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(in) :: task_id - integer :: rc , i_state, i, kk, li - integer,allocatable :: idx(:,:) - integer :: n(2) - logical :: ok - - allocate(idx(N_det_non_ref,2)) - rc = f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - - do kk=1,2 - n(kk)=0 - if(kk == 1) li = nlink(j) - if(kk == 2) li = nlink(i_I) - do i=1, li - ok = .false. - do i_state=1,N_states - if(delta(i_state, i, kk) /= 0d0) then - ok = .true. - exit - end if - end do - - if(ok) then - n(kk) += 1 -! idx(n,kk) = i - if(kk == 1) then - idx(n(1),1) = det_cepa0_idx(linked(i, J)) - else - idx(n(2),2) = det_cepa0_idx(linked(i, i_I)) - end if - - do i_state=1, N_states - delta(i_state, n(kk), kk) = delta(i_state, i, kk) - end do - end if - end do - - rc = f77_zmq_send( zmq_socket_push, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_send( zmq_socket_push, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta(1,0,1) = delta_I delta(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - - rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' - stop 'error' - endif - -! ! Activate is zmq_socket_push is a REQ -! integer :: idummy -! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' -! stop 'error' -! endif -end - - - -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull - integer, intent(out) :: i_I, J, n(2) - double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(out) :: task_id - integer :: rc , i, kk - integer,intent(inout) :: idx(N_det_non_ref,2) - logical :: ok - - rc = f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - do kk = 1, 2 - rc = f77_zmq_recv( zmq_socket_pull, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_recv( zmq_socket_pull, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' - stop 'error' - endif - - -! ! Activate is zmq_socket_pull is a REP -! integer :: idummy -! rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' -! stop 'error' -! endif -end - - - -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) - use f77_zmq - implicit none - BEGIN_DOC -! Collects results from the AO integral calculation - END_DOC - - double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - -! integer :: j,l - integer :: rc - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer*8 :: control, accu - integer :: task_id, more - - integer :: I_i, J, l, i_state, n(2), kk - integer,allocatable :: idx(:,:) - - delta_ii_(:,:) = 0d0 - delta_ij_(:,:,:) = 0d0 - delta_ii_s2_(:,:) = 0d0 - delta_ij_s2_(:,:,:) = 0d0 - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - - allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) - - allocate(idx(N_det_non_ref,2)) - more = 1 - do while (more == 1) - - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - - - do l=1, n(1) - do i_state=1,N_states - delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) - delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) - end do - end do - - do l=1, n(2) - do i_state=1,N_states - delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) - delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) - end do - end do - - - if(n(1) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,i_I) += delta(i_state,0,1) - delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) - end do - end if - - if(n(2) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,J) += delta(i_state,0,2) - delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) - end do - end if - - - if (task_id /= 0) then - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - endif - - - enddo - deallocate( delta, delta_s2 ) - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] - implicit none - - integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, nex, nzer, ntot -! integer, allocatable :: linked(:,:), blokMwen(:, :), nlink(:) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al, diI, hIi, hJi, delta_JI, dkI(N_states), HkI, ci_inv(N_states), dia_hla(N_states) - double precision :: contrib, wall, iwall ! , searchance(N_det_ref) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer :: KKsize = 1000000 - - - call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') - - - call wall_time(iwall) -! allocate(linked(N_det_non_ref, N_det_ref), blokMwen(N_det_non_ref, N_det_ref), nlink(N_det_ref)) - - -! searchance = 0d0 -! do J = 1, N_det_ref -! nlink(J) = 0 -! do blok=1,cepa0_shortcut(0) -! do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 -! call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) -! if(degree <= 2) then -! nlink(J) += 1 -! linked(nlink(J),J) = k -! blokMwen(nlink(J),J) = blok -! searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) -! end if -! end do -! end do -! end do - - - -! stop - nzer = 0 - ntot = 0 - do nex = 3, 0, -1 - print *, "los ",nex - do I_s = N_det_ref, 1, -1 -! if(mod(I_s,1) == 0) then -! call wall_time(wall) -! wall = wall-iwall -! print *, I_s, "/", N_det_ref, wall * (dfloat(N_det_ref) / dfloat(I_s)), wall, wall * (dfloat(N_det_ref) / dfloat(I_s))-wall -! end if - - - do J_s = 1, I_s - - call get_excitation_degree(psi_ref(1,1,J_s), psi_ref(1,1,I_s), degree, N_int) - if(degree /= nex) cycle - if(nex == 3) nzer = nzer + 1 - ntot += 1 -! if(degree > 3) then -! deg += 1 -! cycle -! else if(degree == -10) then -! KKsize = 100000 -! else -! KKsize = 1000000 -! end if - - - - if(searchance(I_s) < searchance(J_s)) then - i_I = I_s - J = J_s - else - i_I = J_s - J = I_s - end if - - KKsize = nlink(1) - if(nex == 0) KKsize = int(float(nlink(1)) / float(nlink(i_I)) * (float(nlink(1)) / 64d0)) - - !if(KKsize == 0) stop "ZZEO" - - do kk = 1 , nlink(i_I), KKsize - write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I))) - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - ! do kk = 1 , nlink(i_I) - ! k = linked(kk,i_I) - ! blok = blokMwen(kk,i_I) - ! write(task,*) I_i, J, k, blok - ! call add_task_to_taskserver(zmq_to_qp_run_socket,task) - ! - ! enddo !kk - enddo !J - - enddo !I - end do ! nex - print *, "tasked" -! integer(ZMQ_PTR) ∷ collector_thread -! external ∷ ao_bielec_integrals_in_map_collector -! rc = pthread_create(collector_thread, mrsc2_dressing_collector) - print *, nzer, ntot, float(nzer) / float(ntot) - provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) - else - call mrsc2_dressing_slave_inproc(i) - endif - !$OMP END PARALLEL - -! rc = pthread_join(collector_thread) - call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2') - - -END_PROVIDER - - - diff --git a/plugins/mrcc_selected/ezfio_interface.irp.f b/plugins/mrcc_selected/ezfio_interface.irp.f deleted file mode 100644 index 062af449..00000000 --- a/plugins/mrcc_selected/ezfio_interface.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /home/scemama/quantum_package/src/mrcc_selected/EZFIO.cfg - - -BEGIN_PROVIDER [ double precision, thresh_dressed_ci ] - implicit none - BEGIN_DOC -! Threshold on the convergence of the dressed CI energy - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_thresh_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_thresh_dressed_ci(thresh_dressed_ci) - else - print *, 'mrcc_selected/thresh_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, n_it_max_dressed_ci ] - implicit none - BEGIN_DOC -! Maximum number of dressed CI iterations - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_n_it_max_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_n_it_max_dressed_ci(n_it_max_dressed_ci) - else - print *, 'mrcc_selected/n_it_max_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, lambda_type ] - implicit none - BEGIN_DOC -! lambda type - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_lambda_type(has) - if (has) then - call ezfio_get_mrcc_selected_lambda_type(lambda_type) - else - print *, 'mrcc_selected/lambda_type not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f deleted file mode 100644 index 91592e62..00000000 --- a/plugins/mrcc_selected/mrcc_selected.irp.f +++ /dev/null @@ -1,19 +0,0 @@ -program mrsc2sub - implicit none - double precision, allocatable :: energy(:) - allocate (energy(N_states)) - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - mrmode = 3 - - read_wf = .True. - SOFT_TOUCH read_wf - call print_cas_coefs - call set_generators_bitmasks_as_holes_and_particles - call run(N_states,energy) - if(do_pt2_end)then - call run_pt2(N_states,energy) - endif - deallocate(energy) -end - diff --git a/plugins/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f deleted file mode 100644 index e3a2d1f5..00000000 --- a/plugins/mrcc_selected/mrcepa0_general.irp.f +++ /dev/null @@ -1,245 +0,0 @@ - - -subroutine run(N_st,energy) - implicit none - - integer, intent(in) :: N_st - double precision, intent(out) :: energy(N_st) - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration - double precision :: E_past(4) - - integer :: n_it_mrcc_max - double precision :: thresh_mrcc - double precision, allocatable :: lambda(:) - allocate (lambda(N_states)) - - - thresh_mrcc = thresh_dressed_ci - n_it_mrcc_max = n_it_max_dressed_ci - - if(n_it_mrcc_max == 1) then - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_dressed(i,j) - enddo - enddo - SOFT_TOUCH psi_coef ci_energy_dressed - call write_double(6,ci_energy_dressed(1),"Final MRCC energy") - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - call save_wavefunction - energy(:) = ci_energy_dressed(:) - else - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - lambda = 1.d0 - do while (delta_E > thresh_mrcc) - iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") - call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) - call save_wavefunction - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - if (iteration >= n_it_mrcc_max) then - exit - endif - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) - endif -end - - -subroutine print_cas_coefs - implicit none - - integer :: i,j - print *, 'CAS' - print *, '===' - do i=1,N_det_cas - print *, (psi_cas_coef(i,j), j=1,N_states) - call debug_det(psi_cas(1,1,i),N_int) - enddo - call write_double(6,ci_energy(1),"Initial CI energy") - -end - - - - -subroutine run_pt2_old(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2_redundant(N_st), pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2_redundant = 0.d0 - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - print * ,'Computing the redundant PT2 contribution' - - if (mrmode == 1) then - - N_det_generators = lambda_mrcc_kept(0) - N_det_selectors = lambda_mrcc_kept(0) - - do i=1,N_det_generators - j = lambda_mrcc_kept(i) - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - else - - N_det_generators = N_det_non_ref - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - j = i - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - endif - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2_redundant, norm_pert, H_pert_diag, N_st) - - print * ,'Computing the remaining contribution' - - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - - N_det_generators = N_det_non_ref + N_det_ref - N_det_selectors = N_det_non_ref + N_det_ref - - psi_det_generators(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_selectors(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_coef_generators(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - psi_selectors_coef(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - - do i=N_det_ref+1,N_det_generators - j = i-N_det_ref - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - - - print *, "Redundant PT2 :",pt2_redundant - print *, "Full PT2 :",pt2 - print *, lambda_mrcc_kept(0), N_det, N_det_ref, psi_coef(1,1), psi_ref_coef(1,1) - pt2 = pt2 - pt2_redundant - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - -subroutine run_pt2(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - N_det_generators = N_det_cas - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_ref(k,1,i) - psi_det_generators(k,2,i) = psi_ref(k,2,i) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_ref_coef(i,k) - enddo - enddo - do i=1,N_det - do k=1,N_int - psi_selectors(k,1,i) = psi_det_sorted(k,1,i) - psi_selectors(k,2,i) = psi_det_sorted(k,2,i) - enddo - do k=1,N_st - psi_selectors_coef(i,k) = psi_coef_sorted(i,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - -! call ezfio_set_full_ci_energy_pt2(energy+pt2) - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - From 5b8e54825a9c1292d17a52e668c0c36b7ca55e58 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 17:50:43 +0200 Subject: [PATCH 45/48] CRLF --- plugins/CAS_SD_ZMQ/selection.irp.f | 2414 +++++++++++++-------------- plugins/Full_CI_ZMQ/selection.irp.f | 2404 +++++++++++++------------- 2 files changed, 2409 insertions(+), 2409 deletions(-) diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index 33aab57d..a0eb5efd 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -1,1207 +1,1207 @@ -use bitmasks - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert fail: "//msg - stop - end if -end subroutine - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 - end do - end do - end do -end subroutine - - -subroutine select_connected(i_generator,E0,pt2,b) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - enddo -end subroutine - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np - double precision, parameter :: res(0:1) = (/1d0, -1d0/) - - np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) - if(p1 < h1) np = np + 1_1 - if(p2 < h2) np = np + 1_1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 - get_phase_bi = res(iand(np,1_1)) -end function - - - -! Selection single -! ---------------- - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp - double precision, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, det, ok, N_int) - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - val = vect(istate, p1) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - endif - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do -end subroutine - - - - -! Selection double -! ---------------- - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_selectors(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) -logical, external :: is_in_wavefunction -if (is_in_wavefunction(det,N_int)) then - cycle -endif - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_selectors(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end function + + + +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_selectors, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + vect(istate, p1) + delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + endif + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_selectors(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_selectors(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_selectors(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_selectors(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) +logical, external :: is_in_wavefunction +if (is_in_wavefunction(det,N_int)) then + cycle +endif + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index b0078b18..6cd0cbe2 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,1202 +1,1202 @@ -use bitmasks - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert fail: "//msg - stop - end if -end subroutine - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 - end do - end do - end do -end subroutine - - -subroutine select_connected(i_generator,E0,pt2,b) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - enddo -end subroutine - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np - double precision, parameter :: res(0:1) = (/1d0, -1d0/) - - np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) - if(p1 < h1) np = np + 1_1 - if(p2 < h2) np = np + 1_1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 - get_phase_bi = res(iand(np,1_1)) -end function - - - -! Selection single -! ---------------- - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp - double precision, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - val = vect(istate, p1) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do genl -end subroutine - - - - -! Selection double -! ---------------- - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - +use bitmasks + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert fail: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np + double precision, parameter :: res(0:1) = (/1d0, -1d0/) + + np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) + if(p1 < h1) np = np + 1_1 + if(p2 < h2) np = np + 1_1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 + get_phase_bi = res(iand(np,1_1)) +end function + + + +! Selection single +! ---------------- + +subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + BEGIN_DOC +! Select determinants connected to i_det by H + END_DOC + integer, intent(in) :: i_gen + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: vect(N_states, mo_tot_num) + logical :: bannedOrb(mo_tot_num) + integer :: i, j, k + integer :: h1,h2,s1,s2,i1,i2,ib,sp + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) + logical :: fullMatch, ok + + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) + enddo + + ! Create lists of holes and particles + ! ----------------------------------- + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + do sp=1,2 + do i=1, N_holes(sp) + h1 = hole_list(i,sp) + call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) + bannedOrb = .true. + do j=1,N_particles(sp) + bannedOrb(particle_list(j, sp)) = .false. + end do + call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) + if(fullMatch) cycle + vect = 0d0 + call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) + call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + end do + enddo +end subroutine + + +subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1 + double precision, intent(in) :: vect(N_states, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp + double precision, external :: diag_H_mat_elem_fock + + + call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1)) cycle + if(vect(1, p1) == 0d0) cycle + call apply_particle(mask, sp, p1, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + val = vect(istate, p1) + vect(istate, p1) + delta_E = E0(istate) - Hii + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) += e_pert + if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert + end do + + if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) + end do +end subroutine + + +subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) + double precision, intent(in) :: coefs(N_states, N_sel) + integer, intent(in) :: sp, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + + integer :: i, j, h(0:2,2), p(0:3,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 3) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(nt == 3) then + call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else if(nt == 2) then + call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + else + call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) + end if + end do +end subroutine + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end subroutine + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end subroutine + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end subroutine + + +subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) + use bitmasks + implicit none + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N, sp + logical, intent(inout) :: banned(mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3), nt + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + nt = 0 + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) + end do + + if(nt > 3) cycle + + if(nt <= 2 .and. i < i_gen) then + fullMatch = .true. + return + end if + + call bitstring_to_list(myMask(1,sp), list(1), na, N_int) + + if(nt == 3 .and. i < i_gen) then + do j=1,na + banned(list(j)) = .true. + end do + else if(nt == 1 .and. na == 1) then + banned(list(1)) = .true. + end if + end do genl +end subroutine + + + + +! Selection double +! ---------------- + +subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + do i=1,N_int + negMask(i,1) = not(pmask(i,1)) + negMask(i,2) = not(pmask(i,2)) + end do + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) + end if + end do + + do s2=s1,2 + sp = s1 + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + banned = .false. + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + + if(fullMatch) cycle + + bannedOrb(1:mo_tot_num, 1:2) = .true. + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + enddo + enddo + enddo + enddo +end subroutine + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end subroutine + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N_sel) + + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + integer, intent(in) :: sp, i_gen, N_sel + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + + nt = 0 + do j=1,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + do j=1,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) + + call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) + + if(interesting(i) < i_gen) then + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + else + if(interesting(i) == i_gen) then +! bandon = .true. + if(sp == 3) then + banned(:,:,2) = transpose(banned(:,:,1)) + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + end if + end do +end subroutine + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + do i = 1,2 + do j = 1,2 + puti = p(i, 1) + putj = p(j, 2) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + p2 = p(turn2(j), 2) + h1 = h(1,1) + h2 = h(1,2) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end subroutine + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end subroutine + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end subroutine + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end subroutine + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end subroutine + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + integer, intent(in) :: i_gen, N + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list(myMask(1,1), list(1), na, N_int) + call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end subroutine + From c9cf03479a8e061e23a7f6d55733c30278897fe4 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 18:38:31 +0200 Subject: [PATCH 46/48] Merge some changes --- config/gfortran_avx.cfg | 2 +- configure | 2 +- ocaml/create_git_sha1.sh | 2 +- plugins/Full_CI/full_ci.irp.f | 5 +++++ plugins/Full_CI_ZMQ/selection.irp.f | 13 ++++++------- plugins/MRPT_Utils/new_way_second_order_coef.irp.f | 7 +++++-- scripts/compilation/qp_create_ninja.py | 2 +- scripts/module/module_handler.py | 2 +- src/Davidson/diagonalization.irp.f | 2 +- 9 files changed, 22 insertions(+), 15 deletions(-) diff --git a/config/gfortran_avx.cfg b/config/gfortran_avx.cfg index f065d133..7cbb0dc2 100644 --- a/config/gfortran_avx.cfg +++ b/config/gfortran_avx.cfg @@ -10,7 +10,7 @@ # # [COMMON] -FC : gfortran -ffree-line-length-none -I . -mavx -g +FC : gfortran -ffree-line-length-none -I . -mavx -g LAPACK_LIB : -llapack -lblas IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 diff --git a/configure b/configure index 86fff79f..c45569c2 100755 --- a/configure +++ b/configure @@ -102,7 +102,7 @@ curl = Info( default_path=join(QP_ROOT_BIN, "curl")) zlib = Info( - url='http://www.zlib.net/fossils/zlib-1.2.10.tar.gz', + url='http://www.zlib.net/fossils/zlib-1.2.11.tar.gz', description=' zlib', default_path=join(QP_ROOT_LIB, "libz.a")) diff --git a/ocaml/create_git_sha1.sh b/ocaml/create_git_sha1.sh index 7b47e96f..f1fb7fa6 100755 --- a/ocaml/create_git_sha1.sh +++ b/ocaml/create_git_sha1.sh @@ -2,7 +2,7 @@ SHA1=$(git log -1 | head -1 | cut -d ' ' -f 2) DATE=$(git log -1 | grep Date | cut -d ':' -f 2-) -MESSAGE=$(git log -1 | tail -1) +MESSAGE=$(git log -1 | tail -1 | sed 's/"/\\"/g') cat << EOF > Git.ml open Core.Std let sha1 = "$SHA1" |> String.strip diff --git a/plugins/Full_CI/full_ci.irp.f b/plugins/Full_CI/full_ci.irp.f index a53064b4..0d816f3e 100644 --- a/plugins/Full_CI/full_ci.irp.f +++ b/plugins/Full_CI/full_ci.irp.f @@ -3,6 +3,11 @@ program full_ci integer :: i,k + print *, '====================================================================' + print *, 'This program is slow. Consider using the Full_CI_ZMQ module instead.' + print *, '====================================================================' + call sleep(2) + double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) integer :: N_st, degree N_st = N_states diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 47c8fa26..c277cf58 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -50,7 +50,7 @@ subroutine assert(cond, msg) print *, "assert failed: "//msg stop end if -end +end subroutine subroutine get_mask_phase(det, phasemask) @@ -72,7 +72,7 @@ subroutine get_mask_phase(det, phasemask) end do end do end do -end +end subroutine subroutine select_connected(i_generator,E0,pt2,b,subset) @@ -98,9 +98,9 @@ subroutine select_connected(i_generator,E0,pt2,b,subset) particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) + call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) enddo -end +end subroutine double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) @@ -271,7 +271,7 @@ subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) end do end -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) +subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) use bitmasks use selection_types implicit none @@ -373,7 +373,6 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p integer :: nb_count do s1=1,2 do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) @@ -491,7 +490,7 @@ subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,p enddo enddo enddo -end +end subroutine diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 781be55b..ce3a74c8 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -210,6 +210,10 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = (fock_operator_local(aorb,borb,kspin) ) * phase + if(hab /= hab)then ! check NaN + print*, '1' + stop + endif ! < jdet | H | det_tmp_bis > = phase * (ir|cv) call get_double_excitation(det_tmp_bis,psi_det(1,1,idx(jdet)),exc,phase,N_int) if(ispin == jspin)then @@ -251,8 +255,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,kspin) * phase -! if(isnan(hab))then - if(hab /= hab)then + if(hab /= hab)then ! check NaN print*, '2' stop endif diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index b495019a..780a7a91 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -476,7 +476,7 @@ def ninja_irpf90_make_build(path_module, l_needed_molule, d_irp): # ~#~#~#~#~#~ # l_creation = [join(path_module.abs, i) - for i in ["irpf90.make", "irpf90_entities", "tags", + for i in ["irpf90_entities", "tags", "IRPF90_temp/build.ninja"]] str_creation = " ".join(l_creation) diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 0667c376..021fa27b 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -298,7 +298,7 @@ if __name__ == '__main__': # Don't update if we are not in the main repository from is_master_repository import is_master_repository if not is_master_repository: - sys.exit() + sys.exit(0) path = os.path.join(module_abs, ".gitignore") diff --git a/src/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index 51728851..e4d51198 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -354,7 +354,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy Residual' + write_buffer = trim(write_buffer)//' Energy Residual' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' From 6882c915d8cc61c581e51248f07bad8d48c4b633 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 19:00:28 +0200 Subject: [PATCH 47/48] Cleaning --- configure | 2 +- plugins/Alavi/.gitignore | 23 - plugins/Alavi/NEEDED_CHILDREN_MODULES | 1 - plugins/Alavi/README.rst | 23 - plugins/Alavi/alavi_graph.irp.f | 28 - plugins/Alavi/tree_dependency.png | Bin 64760 -> 0 bytes plugins/Casino/save_for_casino.irp.f | 2 +- plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 4 +- plugins/Psiref_threshold/.gitignore | 29 - .../Psiref_threshold/NEEDED_CHILDREN_MODULES | 1 - plugins/Psiref_threshold/README.rst | 24 - plugins/Psiref_threshold/psi_ref.irp.f | 66 -- plugins/Psiref_threshold/tree_dependency.png | Bin 8479 -> 0 bytes plugins/mrcc_selected/EZFIO.cfg | 33 - plugins/mrcc_selected/NEEDED_CHILDREN_MODULES | 1 - plugins/mrcc_selected/README.rst | 12 - plugins/mrcc_selected/dressing.irp.f | 1022 ----------------- plugins/mrcc_selected/dressing_slave.irp.f | 601 ---------- plugins/mrcc_selected/ezfio_interface.irp.f | 61 - plugins/mrcc_selected/mrcc_selected.irp.f | 18 - plugins/mrcc_selected/mrcepa0_general.irp.f | 246 ---- plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES | 1 - plugins/mrsc2_no_amp/README.rst | 12 - plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f | 129 --- plugins/mrsc2_no_amp/sc2_no_amp.irp.f | 14 - .../check_orthonormality.irp.f | 6 +- 26 files changed, 7 insertions(+), 2352 deletions(-) delete mode 100644 plugins/Alavi/.gitignore delete mode 100644 plugins/Alavi/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Alavi/README.rst delete mode 100644 plugins/Alavi/alavi_graph.irp.f delete mode 100644 plugins/Alavi/tree_dependency.png delete mode 100644 plugins/Psiref_threshold/.gitignore delete mode 100644 plugins/Psiref_threshold/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/Psiref_threshold/README.rst delete mode 100644 plugins/Psiref_threshold/psi_ref.irp.f delete mode 100644 plugins/Psiref_threshold/tree_dependency.png delete mode 100644 plugins/mrcc_selected/EZFIO.cfg delete mode 100644 plugins/mrcc_selected/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/mrcc_selected/README.rst delete mode 100644 plugins/mrcc_selected/dressing.irp.f delete mode 100644 plugins/mrcc_selected/dressing_slave.irp.f delete mode 100644 plugins/mrcc_selected/ezfio_interface.irp.f delete mode 100644 plugins/mrcc_selected/mrcc_selected.irp.f delete mode 100644 plugins/mrcc_selected/mrcepa0_general.irp.f delete mode 100644 plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES delete mode 100644 plugins/mrsc2_no_amp/README.rst delete mode 100644 plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f delete mode 100644 plugins/mrsc2_no_amp/sc2_no_amp.irp.f diff --git a/configure b/configure index c45569c2..85285f9b 100755 --- a/configure +++ b/configure @@ -102,7 +102,7 @@ curl = Info( default_path=join(QP_ROOT_BIN, "curl")) zlib = Info( - url='http://www.zlib.net/fossils/zlib-1.2.11.tar.gz', + url='http://www.zlib.net/zlib-1.2.11.tar.gz', description=' zlib', default_path=join(QP_ROOT_LIB, "libz.a")) diff --git a/plugins/Alavi/.gitignore b/plugins/Alavi/.gitignore deleted file mode 100644 index e4e1a2ab..00000000 --- a/plugins/Alavi/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -alavi_graph -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Alavi/NEEDED_CHILDREN_MODULES b/plugins/Alavi/NEEDED_CHILDREN_MODULES deleted file mode 100644 index aae89501..00000000 --- a/plugins/Alavi/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Determinants diff --git a/plugins/Alavi/README.rst b/plugins/Alavi/README.rst deleted file mode 100644 index f2194755..00000000 --- a/plugins/Alavi/README.rst +++ /dev/null @@ -1,23 +0,0 @@ -===== -alavi -===== - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -`alavi_graph `_ - Undocumented - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Determinants `_ - diff --git a/plugins/Alavi/alavi_graph.irp.f b/plugins/Alavi/alavi_graph.irp.f deleted file mode 100644 index 4e953add..00000000 --- a/plugins/Alavi/alavi_graph.irp.f +++ /dev/null @@ -1,28 +0,0 @@ -program alavi_graph - implicit none - integer :: exc(0:2,2,2),h1,p1,h2,p2,s1,s2 - double precision :: phase - - read_wf = .True. - touch read_wf - - integer :: k,degree - double precision :: hii - - do k=1,N_det - call get_excitation_degree(psi_det(1,1,1),psi_det(1,1,k),degree,N_int) - call i_H_j(psi_det(1,1,k),psi_det(1,1,k),N_int,hii) - print*, k,abs(psi_coef(k,1)), hii,degree - -! if (degree == 2) then -! call get_excitation(psi_det(1,1,1),psi_det(1,1,k),exc,degree,phase,N_int) -! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) -! print*, h1,h2,hii, abs(psi_coef(k,1)) -! endif -! - - - enddo -end - -!plot "test.dat" u (abs($2)):(abs($3)):4 w p palette \ No newline at end of file diff --git a/plugins/Alavi/tree_dependency.png b/plugins/Alavi/tree_dependency.png deleted file mode 100644 index b4f0df8b656dd6b03f85d68638531ed4f085777d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 64760 zcmdSBi943<`#t&)DPu~83ehAP5+Rv~q==}D$xtFggvvZm5lPBWh6Y0+3Q?J-P$6TI zDWoW~kh0g+=kwja{oTj@2lny4$I<)h@!a=)UFUV4>s)J{cbLvGbtd{v^b`t(N#n4p zE`>tXMWIlCTC*BIF?o%THRa3j+730NimDI;;vh(!)rs*q|f8R^&FbbMVWT=(xDhvCgO4#Kc%_ zY;4}Ve;=%zdNplcLPCQ4lCiO|^udEwH8r%yjvX8A$liSS-aWqcVJBuaI4!l*svm@M zd0dW-jSUSAEzi_TU&qaTJuZ$D*H=0dTqY)vqwo+cm3nXkIn4t7%yJDc-6z>ORT=B z-_xg}E-o$!-(tjTH-$3@Szf<&=T6AyS699?r>aQ1erFRD6rB8UR5VpPS$?$r35WZy zpG@b^pSQNou(A$NPA$K_S&H0SMux!MgIAcRrly)(TdRDjR_*m%aC|*gyLs>a{U_^} zxh$K4@!i^6?=(6sOqwr$RamL02%t-S@F0LsCD`oE4L(j87Xd6M&AU5T>>D@M1qKFg zm5^ZD7tgruP(=By-FkanMs;F0denBcI{BT;qFP*BTo?%9%{8xD&Bn%NHuNTX4Ks6X ze?>rQcDAs~>(wVup5zk}Vl4Z+v}gXuCptYny|-~Q=rzM7t5XY=#tce&)BzckS+mt|VA$+*zYFF1Jh$oqTYEDFo(4jnqA ztZte04tvdc!NaG|XGN}b>H8kUhLAxnWuk0FKH~cIpvZY;dV2cY%Rh{=Op4cccXux= ze2EhCm>*~V#Bg5oo}=G6d(#sq*wVBTgAZQ$X*TjU-XPyPy8DMN_O7bz@0@7XnKB;T zOg3Cx>8WW+U}R04(HGWrS??ZaW>)yqGW3s)F@&l57Zpi+{{Hdeg1!k=c~8%lKCfTg zB4R$e|+L#;1E&O(z@Q5_S>FHmjXyXL}$3zJ`yeeR!cN>Wx|Up?G- zN9@wjVe1PQ2H!+)LmY-TM|0}!vA2x5m$woY6{WuN_m8=`xnDSkXyL~}dJ1AmT~m`$ zQ%kF*%*V&1%=`4{;fTzQKP#R|eyP2_d2(hZ;Q4cLW?uQX=~>I#$B(lHGjjPqe7Idz zRaH?imYzFItbp9j+M1dg5`c_MOiqK(@?;PmtD?DC2VY*` z{yIFaV69%7rjnDB*!<7WjWq>S!NI{@FD~*<&&*8Cf4a!P9rEvMGfQxLmVKpO*dGNm zdwXG*yX=h}9qg~JOw^w7`4fcrIXWu+pKr`8xPPC&=;cd`wv6KjFC6ae<$LzrPcPl~ z(+fYf@WA>>#x(8ZNQCb8?b|1FENV?Dzs%x|KINLP!lBFcT)fo&R#Ak`)6=)1A^1$0 zH}}FI!&ZSc3v-=m$v#g_%l&D!x`*`7cm>_Ox!$fjKU3q=xvcB~>c+O)nmen0_4!2o z>h)mRxpU{^_d&BP{gdQf2z zGPAd-N18264itI(5*h#T<_1&m z#dBNa+)s=OL=+gAn8kO?cr8gR{hE0Ck}J!Y?(IDW&BWD*w>K5;krrd+l-sm0w83mp zHN|J8+nW`OsjX!%D28Ug=5L` z**6QhY#ETB3tYdx=PoKP&PFMS_fAP#Kj|JWp%CWl{pHKI2`uUZ|?kT@>hWb-s zJA0>8UzV5sf}`2D58cVUuOIc~nwM|BNNG*)WbalA@IB*Ab?H*V{PRCiiHVyXKEHhQ ze_!K-p3;F9{IzlW$0qs|7AVavHlCvM52Ad77;Jsm!>Po@`ztIYEmxbJ zr?cyt{N=3h=Y&snuIlvi;^vAEAJzv21!X*btozNAQ%@gDVFMoEfpjBSlLf?3EoH(7dXVLuf z$L|;VN8WY2b+Cpd{CzH$;_$Iu_-Jj{a}p^xQJ5t5?~lH7r*roD%9Of2%dL#RmcQq_ z`4_8Lv@d>n%T@l4>BbSi9Y-%*5my+$cZK5RW%k3!tcl00rzmYjNc%=&B7?B7aQnT% z>bQh2)IaR@*yT#LT$o92AP-j7z-f#cl;N`Z+ z$%5Rgv-`R4bypl!Q!9Vb_xF$IXORxNr}Hi=@;9QXR1Z-nN_8GvMfuvaDl^lk?Bcv# zN`C(3&fMFl{w%g{oci#AW5t9i^x8G$C?2^JA0#d9sW=SM3Rg37`s$@0+kZO1=MU}M zA4@ZhlYhI85nR{$z4qnwH%Lk zV!54J;_FN4Df8iNX=zy(UZY%R({gqnm#myzOP;0r7HLOClDaM+_g|PmiBtFVls%O> zUFdYdVz?o;$aRcebWd#p17iORbSyuiD%0i29gaBwGrv3CQfD@@Y z0)dh3<3pDYunQXncAoL!uBfQ!D)Erw(63G4oZz>z@3<{&yw|ovXmXF>b;$&;YS zNBaOQ7N#3T2Y&vHoSwdzUIVkcNIJDYO|?} z1W>wI_GdK*2Zxa1Gn$oOJ}V)kqt-5C9a^K-5t;k(Q14nhI%=PtYjph4y&urbaFfP&fWvzL)^YC^)M@t)!ha_+O`4>e+%UtBzcQp$bwjz~~P)r(Tgi2VmdawGmk zoe->ffA65vw+}lGKho8_E6oZNVcU_VkTC;M=#g_Vz!lnp|+Jfk8n7lLJ*njsw*B1qEUj)oWhQbr=H@T0cK;5z$^pdpqyE zj;^jh$~*a@5EkA;$Br=rw)PJU`1O`}R8>{25)lz`ynH!0FV89F?emO`HBuLQtLMf# zSvPME$5P`6-GBU;o}HbYQ{GcLn1weICx>&>CdqnPE=$o!VACdzRGt3s?N34@BM-T_ zNW4#0h(ees?~I|M0GBpr>h1b}YhFmZc*QNAzcJN%;S14H_)s|5t~R_`bTDhCh1E`Y@VPr%n-EUr?~$&fb1t ze4G(q?ee`XOnqfv$2Gu6&8=VRqUb2&y(Px|+attI_In*gHxoyXzrvps&MTw2Yj`VQ0WZ3T4~2 zZNtv)?(PdSO$sg9#xJaz-f-F)C7{>K5^ip5tHzHud1gO+_^@}v$jIm&YnWJ?1>jPi z6^;b`l`B`Qt!2GqH-xE9PEPuUhaVN+iB+S=swHSRI!5jgQ+M-oD=N zrdVylre9`UwucZJ0dy?EX(N5--`HHZV1W+G#Dq&v92;$Gb+KfQedtp0^p#?h$QQlt zN6S@7WSp*!*#8_$gfsl${(WjnGm`Dl@UW7$ws!y7h`h9FIXqu{QWDRh>zinS0<3Lp z%x6bi$k(diYc~Kly{3xSTph0&EY*8e1*HW6Wy>nw5qK>;{J4?PwGSV3Z{50;lAF7Z zg(qmYfB=Qk*4CDC`qgEM@3Uw7mZ$1?DLNNZVh(Tj2TlQuH#ai_4h?XZT5T3lVCTtr zJFo6deZ7*A(WYn5p4~tfy1eW;G%~`EoaN@`)}Ve`Nmx+u!flh<+S&$xTO>4310$o3 z-z6#`%(;1aenCNM&xih#EebSL1M~AGdS1FRpoclErKNV^g5b~3uR>;LT^>Gql=|%1 zdc_|*7`3#t%r9J^7Z(>FZgP!!$ukmAqNSpug0xWi?*NV#iz8u3cI^?_y<5q~X7|s& zvZtOyU%z(#F8O&g;^oVixdjD5Xg9~l$IZ^4r$Z}_oQr?Ey1V7C9IEa5f==~<*3OuL zrMa;p&&7Q?XUcMfGLQ~*BL@*AfdK)lwrttboM&05&U5?rZEBxuUt|8$u_H43k=G7u zXeeE}v=8an@z>AOxA2h+ZkLn#c8_#-zr6h88lI@Cy}h7!@nuBb`6}Amnb)sfqcR4Oa3u2G0)L>*M&PmMOHx0-(R5 zu1=0>J!iDg(BHYTSh$Zqh?2xWifH;1mVtc$EkyjU8h6tH?~H~$4xw1Lr<2Lze?U7pd#suGm2vQVcm z30T9x9VHfvq(sBIe!aiX%J06=hzM0Yv6y8oqh^A{S~Q@bKLk(c==cJGac!1zs0IVn z|MhD~ll*T+(lvq{sh_I(YxrCS0C8#dTfjh7NEOJ5bnWEY0^82L9`kl0IrhG){1w=- z=o>eDV|HniK+uIFZy6kqJ9reR@S65e? z0lZ=XLYi9)7zT!igOEoDmltOQL`6ehy*db#7>omx`ao=6d4W?%FFr7kCStP`b7p3y zL8<2ftM_-;GBNe0Sw^Mn2oQ`!FmeD6^5uzMCVhSVR7#nxyUcparU(WhTU~{fWpUh8m}uz&websw zpu)n!h7s4<(c?6$S1WH{ue5#r09ZaHa54kHN~tO#7N1|bHW+^>I91|4R|zU9Fp_T# zH#hh4@=VhLXt}U&t?6H0^m%U}R|t%%c(&6Si@UJ6IDm((MsR)qq71)aeD0owA54?lkWtb3b^@-|t4 z*S0f9?d;j@XjXzEs|+3huxKGPQ}GO_tmO!r#JQ_aP%EB4pV^jv<*b#}eVn0YAb$iA z`lil|c>gG1?w=lR^o$kl5S$dT=-4iKu{Q!ds9jfX zY7L_ms!Ju1_KmxDBS8L1UPwTxz-sYJN$J;oGs?ML#E8@+>Ch8OsJTyt_M~MyZd5D9 zXFJ!CZ5*<8!_M-G3Z+qjxd`rq?3*@inmcqK*?aKJ$`VJ~v3vBQqN0qOB-Q|w&{7D| zsidq-jZ04UdQ8ZA{) z5aH%$&(eVCJ?Bk1tf^UzA57KnN;X4dF$zKjJYmnMB+m;*eA&8n>wMM1+0DT$Ha9mb zYG{Nt{GH$#866Ephm~dgBIn~seHQ~?t*MT?y9^Zy{9dII7GET9-rw#a%-nC<+HQr0 zBJtAF(X|3{$3Ff2`*%!G5bef|8~1nh#-!EP*QdUDbNEAh`wq(N@SQUsS{|s|bm!Zk zKU771rt!sD5Rj0#g?gq=$pDWx+pd4+xVbqWupBFee$ASUI|mgM&cv&w>gb@5b8&L6 zqbv=EiwYb#5YNmlqe{sDIoq3-SjGBWE~kGs0==i0nE=E;*W@q(7-eMtIy;u8{X zDyMGczaPC#UH9_k%U}M+B)mb8t)-l^vXUJ0=; z+oPZjRaIR^-f~el_kTen#8lWBXM-zIr7SNmyU&~wV2jE>kI%7O`~)OzUI4k@77YXO-mBcxSlS) zq*i?VgUPe!&(~7!$+|r={My(x1K2hm1Ra2iGCMa%du%!b$?5F*^D2U|)D#N~i{=7b zeVre*=StMg%*+DpC9D!&etDmkmNu7WKPq3yB)n_Gh7I7yWnH^Nl7VOUiiu@jF|6Pc zw=!E^m@;^7#YFPmF7=%2`!9<2cMlx4cRRu-r zYM(s0QU1@Y9$=LP@+id@SmHhq?4DCu8NYgwpR-QCI<@#aK(4g*SgWq)J(-QD49KLb zCVw5G$bI2*V-Z^nYwIcVy%UQpcao6=tO;JdEqYbfp8ooYx{P%Rs@Mm^I!NtBL z3d9RG-1O7q_Oh=TLqkE+3GCVx5_%!(M?zfOji{(5y_Kj0UC=Dn<6U|0WVCCOI8al! zqx`7wM~BXje{9W~A?iWwsz~G@ZPacFG~S!Utr)XUzbZ6kec}uSWYd95+cmbYf0m#B z@JgSTzM*tzXrcWlv>$=sS!Ua8jvPJuEnKuz$0|h?CWV#P$8n4pDK}7og-^e{W%VvW z4VQa}WWVt*OXsh?mA`i&)v2kfN_>*#@?iDcv8&@OlJqsu^vJ0whs?q zU%$TEu77?CA!xe~xrcOrXjMp@TUuJCZWG(DV_*=fZ|X*S?%X+`*nzS=9Tz6I;wvK} zBGv&gq3F#{^zi~KD63m!n*jDAN!*B!55wg|a=f!2`5*{h*Lg3)Z5< z>+aG{QU!qt@&F4Wl7bwFZy1j!RWS#jS;N9YI7Om?dCs-#N8O#S==$>J>^`A0rCSi` z0RS$9W`w3l0LWX=46%E~#Z|x-j=W0@@%cNGOo#|OyR7Cs1BNRDm9&Hf1Asd)(v%#9 z1yjU{;SSIHT8SniqOef%w&P;L#4jbd)oXNhtrS~7bRHz5A<(l9-#&1bw9X;-ga zZBXRMXZ1FY>h$T;xPy+fxC5nIv9abeBkv&5aHBsUX@*EAIQT(Gz0Ff`^e0Z8viSA$ zb61hmw)aVL44_or-aW9PHBBo3y$hkQE`h4=7cqSus+A}?05Xx5)x0@Hi9m5s^Q~vE z_?uS}UMxw@W3rCdr@t%Da$T4z(I02OwSw5%4FG%M8iGjd!-o&KmUYbI-31Kj$&h_3 zAeo6-z2yW#2=zFSt!ik<70G=t7%~$Bs=o@m6%=EUTGN_dhTeseyqE+%ji02X%Wb3576c!0k5H_SJu&42eFu+ zG#bd^9fO~Xo#~+JkOl|D1E@7>ECO&fi@d!2?)1=!H(Hp|Jp@CrA}}n{~s6075pz$ERMI=*4#` zA-oas%zO6iN&WIT==7zh!g`&j zr)NrL=5800S|dg*$H|!bvqdi7*7I-MhHl6Y$Axdt9tNmjHfzzf7QK2!7(qNcQOT3( zr#VqT3ExecQ1nJ11NlWnn30JozQ7MDKo661b80}Y046LV84+?sL%6(8T-<4K`W$X^ zH}8v!eZeLoA&^6$qVdHZ!M_7TLo`sr0n#5JwwgOTIb=$Y!~zKZw{f?y;79m5jdcib z-?@{2|Nf0=-7NArbu&*CI}PIK1MSSnd2@LjG6CJJV`>@+TrU`2AFwj=_3NI#^A;A= zn>TNkmX$pEXlRZCiGfe*Bufdm?zkZ=vjinOf2;RI+hGBSd+3eL(B!trTO zJaqIZ!^p@8l1M;mDj)vR%);XS^2g@pbpS+&W4E6b`l^92MWDt#$j@hc^ym>zgc2~@ zkt0WRjEo)&rLpv7zbP-LaLc&(Ucb&nWZR`#8_oEAw15Bp&3*nnprk|&nsBm5yjX2g zBuh%JWYgQXj8;}w896!R9GP2M2B80~sI5J;m;_z}yvsHzsbA4a7N@872ns5@yDx34 znXIty^7r@OW#yK8UTA&T_l@?eR;}XX;!4GiH1zR~8yXuK3Ho?XN;|{JA-_DS0yN8v z#pD#TP~9LR2a3j#<+d2*(~FCB2Pa+=FG4?hAH7D)JixWeEW_t}9eSkgK0XVg^8iEW zDaGB9#>&brViJnJ!+fAJsO$OpC?j@#N}Rlx3?eBId7g2L^g3u>NZ*>-kZ1}Ffr8^? z-S)wS5aK%4VGi7@tbTzV0aY8yx(!Qp4GIv#RfVYHJBTX28=?HPbV=~oJ((b|yD#D) zqNB7{e0+W$3@}0a<_J}C0bvkK_U|7Zz0;3A7MnrNDCiD+|78$_>XBP2K%t1a&sux_ zUHnRZ;RgzeeFHjXBE`dg@@4$vbNeO!*@T3I1xWvSa8r+n|wfjZw;D{vpU6iBBa))9F1#s)nP(EBJ9)o78Xe!S?j0M5XD zL|>iUV5t@Ek*k@#5jKs{=2X(Opj~`ZGq?6Xf5!lYS<0cu7xarmU+Hyx2l*I&cM6v% z`7{4Xb|EZ}qZ*az5vYRu7yC+Y9NsQ{<>wZnJEv|d*o2!WNS4LhVw{#RZs*bAu359D z{05)OIv$?)Ql>t~{(S{u$e4nZ{SG*fm;pz^alu-6vG0B7Cod(0BvEca@UftM`=_^s z<(&#pXB98dF)@ii8+2F3l^(rd6-ZD%m+b|*AVAQV@yW<+BEf^K9u!$^5MC!|(DD7z z!-wU_26seGS5AGYD=vCWA-DE%>W`V>lgntPp;;X{5C>DwF=cgKW7mM>o}M0}Od(BJ zKyi7!IVrEMpGU~HfCwifDWfVONe&KnYmybaj^`+lasB1Ugo1-zA(RLxOM31nS_2i@ z5ppEKKSpb{RX|`3ps6sL58wT^9g0Hi4EV_49tE-av)I%p(f96Mhu>f$>HsMkFfWL> zJd}*WhR$D=eG^tdkBW5_y*t4quuFk^15)|Jf@jGxhomUn>$i#y3cZ5M&mJx@F)AL>!-6~IuRpu*_3xjr z7G_(u^DeXt5*`8sB&!U&Ee+3dwSh3QeGSOuayWhdmD1jl#EF4!`l~v{d#k>!3OuMldU*Wfsxg54TvWH$FD-hz%b-lxA5bz&@C-3Dc4yD>PRir!@7l| z`?W$_^9T9hZV{0~W@cN-atj+5_Ct9H0cS76uE&Sx=w8n=R813&^xSFc!4w}KFO5#q z)5{A{lMrSgG*Y3RrL~TgbuG7lfiM=66R;aTBB#lIB`mMu=wZ#RXj-ZkroIe7vmWAhg@+&}x%o;o zB>f{J!N95V(?*}=OjMMW9dVzf<9r@jFDtY+OWKu#d=WFRq(KnMPM3mD^@LSRKu~b~ z)*Y7D>priUuLQooPV_Gz89+fGFZ611CN&mfXmy&ijivlzo^_aE+Z;y+) zSpcpA00PQ23~il%&)dJA@3tif4z;uyCI9WcgB+v|{-?rQSXxf~qe5fzR%2sDhvquZ z)FEdc*V9`?0nh^p6{MW1sHjN6x>KRx_~||C5R{VQcv|*XCdaho8WBT3T`W`ktbaQ# zZRbnZv0z|&MU{Z4%Xzm$(B3-W$blxF+}0FcV}TekDZUiskux52QeWS4dZ?acNH%)4 zl1?}UbKPdF(9xbuafy(FWo_OB;vv$-ja#>9icS8$83X5lE=BR`Rp~x~dnGp(7Ou{I zZ)d=hMzI-0AErU~4@efG{o6vAc|za3=^RpHk@MGM0W}*lgv*hkbeXSOjJrW)Aqo!!7>t-@3Z(9uN6FP@^Za-;Pkx#RH=*T3M`bt5-<1Dmj;k;93}!|em# z45ChhcU768JC~gVGLmQ{=xYeRfbNG~f*&I4wf=uF=>kY6n!^nSRaZI0Y$XsCJaX>+ zkOCU0pJZkd6#!J_0DMz*fZb4Xb~);%MWR`E>My6V`&7t;?ZOw%NzQ&>Eer9ZqPkkO z{9#1JqRWO*DyP=cA>fH#6DY^Gt*RfL|H5HAG zH-pZ`y~IgfuXh;Q+f7H}y8yXtEm!xN9X}T%J*0pqW1ecb2mwW}O zL(CPpp3<2!yyza7auPNFIQn@VL#(`MY}At{A|6T|h!uAQ4&cXRfUL**vJCX}fqyyY z+Pn_P8U!Lm5>gQw+4!dyEO^}9++0Oa%jA4^b#;}$d9wzfv4JjmwkaVTo(I%8a_h^; zJsDY9fjE_?vJ9x?Fb96o&57mP;IrsD<%3x~Chx38~&!U62s;Qy)A%LBJ6P_`9hj+v$9 zDv*fs>bK=iLeWKx64Dvu1n6vH7648p*d1O5xQxFuIquuL*SEO%05ZS1g~jxnG8CJ= z`}QfrXK_oRGdq#xZx0&?m*a+pnI_4bmWr{-#bUk9WiXjF%;R(j2??2*n^WP65JoE- z8t5TMjdta20|V9H-(UW!-q=@C&kSqn1loQ(RJ`50*M9rEE?X=(hx$HY*Ll>>iHY|d~`Kp`LgjrfeM z>8Plnf|TeV9?pQRG`o0_CHnC8{&btoZI8>@IXJ!$G1lvM;jg!judcA5b{{@^RL}cBoBcRs+7ui(W6KEwW~KBg|h@FnW#Plt$?v4j|Onw7<*~J zUOD?&`OY0X29V1TlRAGBZ{2z*n+BC>&8}U$hVM)TuoxSEN>9?O3)I)qN$EN4z5obv z|MjGAZ0tsq5yBo1m+|oML@`R3zk7m5;Sez?2g?~71xiL~XN(evQMA!0!&$#pIvyS6 zkUyJZ0b36iaDH3gJ=ndG@cfaR!H9#nh$ZM5CyAcBjs^6f z*V3#XZW=PRo8^mGIJ${KM6`M+(x7d=fU-mJg5x#>w+aGrFS09-&K##dd)Ls=*}$Nn z|Eli@4_$UW*f$oImPlI!b$?J)dA{e`wQG)Z-%qL@Is`POZ0G_>zoo?E3K6BSZE9uS ze-@Uj>oBJv?J+Mzlsh!beBkAg4tslh!GzSnn%MkAU-ak4jAAS_DZ`++h}ge4^A%!0 zQ4*mh^X=Wc4qrI@rD&x!i?$Ha0~WIyqKXr&kHqc>QW1DV1sA+!tm?^fJnaZ55QMPa zd?~ua01y?3cxF&eM6@NIENnLe_emYqK#+nK_@MOF$*q8Oe9?#dCnlo)J1Ouwr_hN2 z=u1Ou;3{;4)Co9nAKet1dYay=Uzipa7V^JYJej6WL|y>HJ3uBGz)Atzl0KRAJYbbZ zKfMtBwJEOu=FOXqkaq$@LcW0WhgT#B#00q+)Qs2D4SVdZXl!AeBoG@WIsO9&xbRF> zwoglfQ&mFlBWE$0GQ{Pf+M~VT+rFLV_pb?Jw3KoEPB^@NxGDn^6BC`GH_# zL&IdFXc-|%i@=70*z-q&N<&LqP%nCDeh`xj(WxL*Mz6lR zUr%ob+VStwnCSA-*i&hzK^hbsvCHEI#7z10_4KuFFTT9OZKzLlEIif31^+-jsuBkX zWQ00Y%O?uGw@}7-eU@24S%DU-!+6HJEn6bMhthLj&y1e=+VlmiX$^R1UXBjlJ5+{W8&jA$Sea~Kdh8XE-nwz zM(QXj`8BsBX@FI`&a03Fg_h_fr*cd*Q2o%6UC2pE@h$zkWc%#Ji(Nns?hsPHfpbx= z(~bWsm`fkzj|O!2)~zreuol01)rvy~8sEMFdgZqmZFxQnh@kqWfMaRJHU~z|siHW~ zf)fGb%?{qJ1+l5IGiEJ!c!Aiy_=w9tdo; zL{h3{p5(EeF)f&msBdVv2615&tFgRx} zxyvflh;xvEJTNpquE`;4$|j_4+hMfAZfyAz3IcEqKLZ1U%%vfiicPyVFxY`21aW^e zCr88!N`}Av^^lN|R4}3+vE~J>J}-_5H^WErc+K&=qI0PP_HeZlH~` z@6Oj4l@=Y!qm`7Bx&u3j63_`7H}~he@jQ*ay-5_=PLUkkLFU$$naqp~>uH5$;z#7@ z2Fu6uyA&t%LT3&)RSL56&O{$Qy_$XN{gqQw5ZX6@i~sbk{5kWS`^*x$5U5*gyFCWx z=BB{ZuBB)^(j9gNN|%5rORf0iRJQxs1lDbbn$cu$mW%2rWfnGk7Ko_+1BG*=OoOv+ zZuzMbCvJdF!wJb#yME2(^5wLz2cDzf4MYEQ^2X?5<{%3%W$s&R2!3tH&Ykkp?f_C) z0NG!c>>RQe8wbpZtt6~w@cfd$r|H_YYagbkt3y)JTYQ}q*x7mhqTbG!<3OcvT3U{u zo3YlCU+7=;p|dj`cAz!f!^PGTE)L_^(g=VEJ`8a|cF}U{wto&dqymNn_%SH*gAgXF z82BsE!t=PoBPeS4$lGX>T6#rEGqSFIbTf!T&8CbW~imv+BPR!GKHY~v=MR8&ElaNm#9f-yj@bd5+qZn1^xtg9y9v_el3nho0 z@}1i@J2NvCb?V+utprt+%j>2)nch9vpQ8e*%t6ejwds5G#gFiOMF8s?wcXLZ7oy(< zMFBZiwd6dAB!TAHCn>p8U%%5m zd3Zn*MREsH_^{Z^{}?>x#f6h!o0fO9ZK$J6umk?v%&^Ao+Nci1cJ!4fi3xVX4lhU#O!WxwdXk6ac50olH%XexT5 z@1`EU2bIsdJr1T1h>6iF`3gUcAq*wx zo~DaK^dn!276l$*e;*b@--b!YlCM607td2GGO!D6y`L^RQJdcyH@q^r&%Ij$d5E7f7ugQ#qZPf)*xcQq zG#vr-QlT(gW!;>oW8_o>nUi#++xyh(Qh6@Q_nu<$9lLhv0qX_@2Y>LGC{c$u1|j^~ zorC(g09#YOyu__n`=6=+0;dC`oor@o`VwuKi}IfR{pT#p8SB$%v(dGK0g1W?AL454 zIc>XxS(^vUThtUn^72=r7Evf*7AO?>FV7v^w5cGxsjV&F^fwMHW~#pAS-smNWL(II z9ws9*({1o88T|NPju%Ee_jMEcxp?>qzqe(g*Q+A4CS6?yXz!Hyqh&8Az{^CrIu!iz z&(ho~%CJ*ay6}HjCO2Kn8MBEL-|Xz{OPipIgSwjwOMX?{F8uUmS$f(jUES#(AE|eK zot;Y<)FM+lm?tF0Qjno_IIVf^bKl+Tnt4qf?CrS`--n!>@=~~x>bB8#pgBdes(jW) z5?UJ>=L6BhO3QvW?mBRwxOc|&1-sq2oX6(Y zW0tp9s*)tN(4108XM4S2_bu3D&YnA$IWEEvYMOM&8lRMH7{jdv4O5dtW#amED9A>{h zNmTz_2BO)|&yUDF$kHvO^Yz%=aJ;iBYmBN*LraTRr)<~c_Ukt3VvQ^2+KIJ|jSPxE zE}alyYv_b!8jIm0A?V?p(YO!R;@JENI9>sVRd&W?KKwIs|L53P3^*NXGAhFJJE<_A z8C>ocK$V7x+oy&HylSy$r0xJQ*-igx5p8(?J`yKaPz$X7TE&tL3kaCCzSCDD(3ivC zcNM z`WXQ5fc{?xUFRQ2Ds3Qfs1=VNKMp6i94O6glr{w2ums_%UTM4;zO+wFjE|Q$`H*NL zV5WMcSCX`oKcyLL_gG11Z7s5#n_Ka8F*X-fd)wyCiSG7qljIVY=6^g{j?gyl{m*(0 zoSV(J*|%@sVgBfK6!+m+eQWIG?8o!TEf~m7oD)2xt&5a9KR++wwd4}}ZrlF-v0y^2 zaef37)h(x%mabxbXnaxh#)QMs7GeyC!^Va$Jwxb!yZ|=sugbMC%uBTu_i#vbgR5Z( zu@b>j_z0h`*eCmRbrW?TT+yKW*qt9A10hZzRr0j>JcfiQbZY3}X*F!vy~b71XH2 zym_YXMe1fLKvuG%(A%2rb0GN}31ex&CWL(KYL=RSB_#${9yc0dWY>7nyH zA2S63E#MhJS8-%Gp3JFX`%_W2W8Z&ux{6AGgL&N1G547kX2A(WfPEAQ{yxC#OZU0Q z(|@o{`N%HAzu|7x0u5_#!F@zSgAd}`5(cPg8z=cyRhcH}4B^T_YZiu; zGq2y5;Z`TcR|*9Td_)A}U0JvF0F^4Hrb*>%4Q-E~K7Ab>^H%iG#4Qiw+6kF52>&o5 zf~#3YaL362_GFHyPrs+9q)-q%0RYahQl&n5vd87&`Ckve|AxU8;_!X=igML@Ef=gf@*2juJGL9Cq58dRM;(DPI9V0x{c$Noo4EYi%Mm{bzpt+C|B~I%P3T zJGGIX_MU=I5?VKPOrWtz^VxpGv9qbaxr21NV2AuoUdscCLrtlNi@4c%By$so!^^HTP!+sOIw4pd%GhX*%a)}Hw{{49I^SbHB?%|}}06TP@OFS5Y zV{@AO^!OqOpAX;#G-YID@}X8L(S>53pan??4MhuyS8h6ej@PA+L$Lb^u1G^{;f`WN94iw`lZVm!1Wc1&@+;=Epxa{Qq{3bn4i zOJM5Z==X1BCwNQW28CX0a5S^>=}4eut{NBJ``&q8-eW@Cd->{1pB4Ge=pkY=gt|5K z^XD;;lKnEwRr!vvA(1qM!ny=iq$sl0!KftR{c|$F0MFe&2^lVEkjwq#T@FBerYmRn zR=Fs_not+T8LsUDs-rZ z6dqJ(@E?S~2D9?&XRNc)%;VVN)Kou|A{CIM)n8|9@J4|A^G!VN%L`5(Je0kf>9hS6 ztCk>T*P}C}p{9b5>^i0rDqOQ9i$U2i!Tq)1DIXLV*o@YrD6%>u4w`N_f!dz($(SDL zN!>s>_`&v!t1)N*n4_$L;vc4_DiOrwJfbP%Jn~kL;U!nvo;|yFr=s+S;hhP}vOG~J zKg4@^AHwDM35zUcp!vSWmgv`-qTQ3WI1)%D=762h`hYl7 zfw>0Oj9P>WncZCMZ9HvgXD37wGNI{;LHGD z8iWpkyzhXmgeuJzy?=T86MZt41e}Q3j|YW?>|nG1xd)?opWb}>4i#&Q?A3KZ^W`wL z!W9t=`j0#t@QHot%k>X7p&epnXAdS1RvE+qHh8o(odwz77d;SUir}%(yQ4R#KiyU3 zSHi4nj!CgUoUw#*#melJlKLOw7*M6?)hiV}z31B=hzX|rcPbX^N%&zh5{p|SBe9r0 zhvaw-ty3l9bu8nazvfOA><@WTK$fjLcF^J|l8>P^4ghAWsHssKW>!3L51&KQ1iu{t z;bQ;@HX}Pb2>G}+k~?NkA2ap>Y>n9;~|I7o8x zMilUy0QFAXu{P>xDZ%}dXCM|q>;(`E+^iOO6$bo}l_<0)3)7c`?s9aM#TSW03Z(dMcz|{*n%px6?X?!ZYw|51B38Ne`SbU6z?gZpcBmb@+2_Lyb7Kk zguo!+J1!ES%I}9;Tb>vg86jip@Eztl7jJozk)a6AT31hxyvzuglOO5_8nEf(sw^xl zL{UJ`iLq-dx+9{gN7=g0XJ%#DwK$`&k}*!?>XuncE{s#Ye}Bx>F;N~c>>!vkDkSho zANn*606O&AHy|b=VZ8~r0Sg5M@%WiDEdBLVvEboB{z32JU$KUYm#Xt-O1nZrA5t6y zc+7Sl?cHz$GBB`#@2&?7SRF?fmq5Hq26CsFtt|s&!}%9>yI_O^k37Aq6)*=h7K#TG z3$Hv4g{(|{eP)dS%fTJLmR`E}dEH)Gawo#DT>>2}tD+_#DGjgW zWMtgnXogFGownfNLmIeQ|H^vG^P-=~=4pn6aUbhMW|ThNQdN`lT$s$HCR#C)Dmbx5 zk5WoXb~Y1Y5EA(t$Zb}5JyZ}3rtrvg3_buS9HLzx@V;9c0_VyMaH?l(A-AkFP*d%|YSZ1E}vkwP-js>60v}iG+LRMFTF(O>~!(Alm z*Zmi)trhY1EXYz29@ed)foC@apT{c)QsGTO${;3yq0nb(X@^XOFk=h6wKe+iHj(6Ju zIgM zp~iRNrAOd|1JbV@X`O}?Qn8udwcx~iFlv6S8!^7(1QSd)b4ZCu z^x;5-zY8RJD}tOx8tpD&!qcE&kWnHatqL^XfEiVWPPAKjPg}?x9dR@8`!R@h>6W!y zeugYTrU1zJKU50!%a;q4yUpXi5}XJ4PTuozSHXt|1P^hKr^g%ko$L1B*d=ld)rwE9 zYbOdT@hD<^hm7IjYz7t7?0whX*=dQMfk>L*?4$4ACG*5NmQ=o;%G*9EMY{2vGJ7Qr zBMqRFg7a!;j{+x{pYSdfGaykoU``qsGp?dwwvN0*1Pr(1Xfq$N>>%z<>TX)f8KepS z_Yo9Tq2TLUAH?4fPc4!O=-K0^PNg-^bGC1fsV6U3BlEXJ$c3z#rWs%9nw6eQ-I!0i zC-*eY6%R$gC9Wt8(I{e4hqreNOfy5zz!w=ZG8bs}fOsUxO_W^z%%#Z8U)oEikrOQ@;FK}NFLttl~>5*2d9S7+eWmyg`e;>Rm%Y$*b;ZE0a zYnWcim;*5M8hjB+PkmJ1pgA$mS+CoUOSIf z%85H{pbHGe6m(EB!wn>ZfEtp~eP#A<5BV&1G;_Jx_;LJUanRgS>^a} zvHc=>XC54hk9Ox!$i;$7WNs;*7tE#X#Zm)F4J5BD?{aZgrp>KD3W&-VExcS2^e^J$q`E9-^?wh z;o0HojWd?T3^SZug&%s*;uOo!8KsM^g@x*6MdS;kF_+hGoGH6n# zD@`^Ar{oAqKO41Qir&2tdk4@KSC<#Wh;sqWVg!#|!q{QWgVsjg&Vb~eQ#Bk5on?O? z?UR%F_se8g{S+x=h?AZD5?&J}%fo_BRSlSje8c>>A%Vvxbrz;7t<#$^YYr0vab%jP zf7kgJM1`8_8mN+6w`~g;<7}$_GWE|nP#L(EQ^8vno)awGYyUFQGLWr0#e?*@d=_c; z27V{kV}Y(t_EU9=B^}+mt{<8fWe>x3yaOWnmE!)!>V#Fc_|=rx!D3 za2MQ5|I}4-dTQviZsP42KW1s!DOg(at^$%p&`6`H-_#i$$6@U~mk7@?AKs1$EqhRg zJspsEPtIG0JnARg@v<9~k(M1IT(jYI&0Pg~CEpz8_(`$KoV(@>_r0Ni32YiEjfI?pc49=P;i&lj{WT!D@m51xqS=I|(6=~uE(jyq;C}cp0RW-HL|vE5Zt-2C<$n*}O?l;`X=Ug>wgSp@!L2P%%Z3 zGe#IpFSFfpQ-@hp>H}}TJG-VM&{87qeDayM9So%UHP!9#OXgH$TVbR z1TKLpW|M9L3Ssfce$TM*`(Y)?_9ukW7|bRNjs!M+ec-e5mlUDS&kV6>^qT3SDfqgs)uz&ITg*x0%e zv33@gHAjqw40r`ln7+_Vw`+NeCwAM)S(|WC5m!rHHOl&|Ra7jjKY0{X$kMB@ewzJXOz=3kY z$mj_67XP=F0@tT5j6j{N2k)Vd>fudm^<7oYUD2nydJs_Bx$2`|d9e zGg(Q}T9gzRUHbZQH*d`;~3Rg2DJoeZd(~Q_t!Xmr|3rV!L|Z@~3C# zH6~E3nSw?v1IuHbUmxBMhK^0&+^YAI-#SB34gZqPrL)i-}6uOqpxTW`-*9Q?9ZB57o+ zYSYhN0pTSU&ct71uKyWsaksRx-}*mmnzqn8(6;FI*hc7J$b>58*l#n`Q#apz4uPLt zL`o&vccYFU!ZWpL10Xd&xXc;&>j3QFrYaA281+uXMC9b?sL@x}Z{51GU-p+2f4d$k1JpiQD{TROX0 z6-VIsMZt;AvP1OL{qr)>Puu!*zfy%G)@aq2fGgKmY<-z}lSU3S(COOhmsHi$tZ=@K z^XRDIwbZ=|RTpN#)*@OeTfFohH+z<5fV^Eh`Q5L(i_^nF}%Du!F1$_p6;t3e(9IxOo|DZl_n&FT}91YnGL z7fnOifaQP#u#mHiCL*<`H%45IW73B+ft-uN;_i!1P=T=7A3uKFtGKKWeJ5J%_}lsw z(Q$E2VOT!xo7$^>^TWx>9k?LqBYlNEIYZK{f)IIkKdlPgB0_%jA(@?g-qe%djt(ltSsO15Cq&PJXA3iK;ZDJEgG%t#Ej(+s_ii7)e-Bv}F^I;&~GryRUqX7%_ z^G4O%w{ImV5K93-36Kn~x32gCL}-sf9hj_L`}Wf8W84K9O}%$d75ORHSj_px9!}yQ2?bQM+A^Gt;a)@ zE}X^#Pnka5A1E83zbmQ>q}&pfMBXM)8~j1z!Gj00&5QSppT2({u&pU7 z{$J1gQV8R69fMZ>)bk$-^|MF!cI>vmx2ylOKI@4MU=FQG4wJIHSKQvv^Y@=j0KCH&u!;6qE z{xJwFDU@SZ2)`1!9DmSPofkBsuEph#Vi!=fG z6%vJO!FgNr&uYsmAThaA&Yx7?w=QZ89aPIp*X(y6yt zMvb{nX|OoCa+6iX69ps1Y7ORqg~3Fm7m|WzXdg=dEt@FU5D* z)0M9@)#{h+-@-N2=?n;r`eIMc>#b#;fR4HAYPWN7Zc|4u|c7)1d> z19_KqwBTv-O3J3&d3n2GT)_ZG+h)AoNhr%}HU>#fDXH{=;2sS*QEaGT5}VR%7(W(H zHJZn}O!LSD(D0t!x^1jw`tgc}l$#$I2LQhI>apJz0%95-M|G~?{o@Vx}}v(t20P?mU?==G)!Lx*C+DdHz-k} zqPh-MTJM7rJr^ZfU`A;+T88l;zF-S-+eVvMvD!3ZN>EG2iXOv;9VqW{sux@%h3JlvoezZ${}BL^cQNGQJQ%)>yn4qen-M+S z^VmOqDYux5(xEIUBw~Z4!zG$y7vfvk#)Z9k`!)v@;;u)BT|5&NI>xz+7LDWedS!TL z3a|VG1aG30$v{^x)26&xI!yDfe zeMelW!t3n4V&Z_M5@pM|^5yHQ@T%N`f&dD9VTh2*zlOM>GqlQooV07DHkhacIFj-) zB=aNCkcqB_Q_Y{>y{6b^W@Zjez6Yo6Nba*7=-n$Wyo@=0^@iXCfTU+iesrLmCsc6i zg7%be?0&waiGXDQ`yP5wHB}>H*n*?JD_5<`p>-RwPy`V5yurE= zkL2;Yb-UC`B9(kVTsQQ<763Ok60~wT1fg~J$wJWo`Tb%21()6V(`cDQ?Z|R|d;G#n za()qI>Z9q5Hz}MlC^qF}n8;Qk5l)bNlv-5v`EwKpXX4M#*3+gnSG;|4`NFTONRHY8 z<%;5>S+m98^ot_t4T;1U`tIJ@L1J|f$rk=O=e7X>V?sKNrP#N;3zo5GZvW>o%h_~Z;LJBJe14i3p=QdO4G*U<` znS)zG)wjj2uH7(JpcY+Q{LOjpT=XZWBTKIA3|V)NR&z2d*f7o9|E$9+`)R>6{xS?f zGJqcXd@ds5hB(~boct?n_5saHAne(uF6Yi==j7agxfj9S{rSHu4SN#^u4q4a2=U2aQ#6K{WAN&Xx;Q@O!7KVHa$5TcSib;So7{ zzV=JyN7PZkQYyTu*EqTz(Kgy#T{8szMaL2Ankaz3Z=f&^1k+6=y%c#BIszrdFC5@t zS)bm)e-$LJTo&|GaflWnV$G*U$SrjjM{!7uJ__6|c^SQ@$KCYrv`)YtvAU}aYY53~ zj0B4UuT@_9XQm^xB(+EL>3g~yaoO@^nI9mYB_3M<9RhXhDg>h7B#4Bw3)1ML^l@(D zPZ~f;-o(-LoE{$j@g{DLtp^W=;34F<(2RDXj5DRf2ug%pt&KyZrb?IO60)L5l(=*4 zPjY_AGu#V}_$%qK=n)Ek=GRj+Y}DvFi{wR(bC~B1kJfvOHvw-<2XWYOSUw zy0cFcz5wY*v`chZ7r|!BVI%MLi!2I>wdxJ)eagU)vi-`HwL!%*<84GB_z>RH&&}c6 z>+G&dDYwrX<8^AeYSE!a(!xdopXbn~FZ}rYx}5&>o0(Hut1d8fE?Q$={h?;}xFgFk zwknN;%UBLPbqDR1LZtYdF2~@(#+jRURt31&9b^W9{xp(i)8$UHEFv#~7a>isTELwToo%_>xJsq6jgDC!(J z?1AlaNE9s#UAWii6J`$1?;|9HOo93$g)HIwpO+U>IY8=HADiHmsX`&ocv`EhVtFWI zQMO+D6PvGNnO{Uf{6=*mP*xn1OdTsy2@~4q?`U!=~VpN6d|)MeTm% zVE9-t6ys)Rt%rGeT0@7n=ZgFhul_2Bpcud=81MS1zvu$sDEFUlwr)n-*hs;r zO!1mUInTaZxtVvT6stm}JKlXk=zkXhe0&1>&dz#A5 zBH;9M0_sLW4zLH-K4<;bl*kC)aphm=`JtSZwYs=^(aRUKTanZc67R$1Wj?FdDySyp{w%elkXm`lV*l>#^+za9a+F7P#a8x%=ZCk8`YPL-I^`X8@7wU|Boz_0QN zm!GL^OMbPA+&$;SXAh?gL#-S1lgq8600(#bF=UQ4=)v6n;mHLa-7xcftX@L|)pD<* zlpPV83IO&w-wR$2yPH1)HHp#cTNm%SM6PgQxdlhE?$ev^IQnqu8StY z#>Z{3?Uo4x4y1OESYyn~t8#5j8HMXYG~6mH-yhwg!<>og#~C;)Zf7|I4N)J7GWF!? z(|aO%&pu;c2WWkdl>J=gr_YYOUpk5evScoylK)Kt>tT$+x3l`#UH04pkcF`S0dFaG znoVHzrtIVOyhWhPiY+TCk(j~7?j5TbW^f3#+GHoEDC2b_*aJG#7SgI%-uiqkfRoR7 zMKhN_-xgopCZGZW6FlaT_}!|1Pgte|E&tE8EG#aZR6V%)JVn3>m zj;1n0iESGbT7M+pU#rl@m^lfF(9Qz~CYVn0tZdY@sScL}Mi<3RN({5zjv134kM)`tFbefOiKvH>8nBrS5r-Y8q&XPN zF+|iGsA&qne#?0bEZ)j??0b}wF|+2+)2C0_vdv*nBe{PM04Y&* zjQ#T+@z~6ZOOO1jlz)X`{sCL$81UMJRbLlrtvcJH;2Kl3ltyyq!JLf&KiiR|QuExm z+41P;jl?0=+=_6aftU8e)D$P17Qa~(lHyFo{$k1}$=3pnow}+~T3Y&sB6jawjSHIE9Eojp*l4ZrY4VKtJ@kDL@; zM3@ww5bP+!F@$iYz+gQ)4;fzbYndzH6(HcQNpBqu{ZZaUfiWVt+dn(qYDWAsox1pZ zewB8rNg=MWrD4=}JHm>&{~xiO_KH<~xt>~Hq$#m;uI$YvZmiR~?_FSKU$iI>yDuoB zOu2!?&)OWLwdAqye8WJxy=}+~j0X?xtcAv0jlL9TbC@y86N*V`=`h?pH{AS~^g!`r z<~DBDuVxtyM$Ur=_UoI~cdWmATM-RiBR}IygfSQwg%5JkAhdVNqD3e9kZG(dF~>3O z z-7%pZpOoZmvB3!Nyz9q3p555z$32@267BI_7c^b}MX{s~3@i6D%BdjhBw z^x)LTpzswtiSK@ZmOFq>oJye8@O`squ$}@)dl}CmBOn8-_=Vy2J1oYPM?vYt4$8{$ zTyUBGxf?RNoQDs^dw%QNifJCStzXzHcc23&d?Xv!cFRjww5KDH9Zd<|jo${#VtvvJQ5nD9ba#WFy!FNMz4}1E*^5_O!jW?to~z24b5!YC9YUgJg?AW=}RQxUt8Z@Y$wvlBS^B|_bUf)o+ zf!C8sv+M{?5sFRuIbxJgL7^+UkrWNKM-!nbDjMuR{czSwToay?X?tgE;ZUBz^mInwJIj^uAk$s$Jk{$LDyU3Egqd_moQ~XY`j>xqk8zt!Y%s*p_ zcE#mc&6*|CgCzV9K3n2u1ZAcyLg;pS%KMuS+rj`yz643CGGm1D5rjP$nAQORMDl}0 z)T?LLws|p_kfb$;ND3`_V?ZHfm+8PR{XE`IZNka^Imn=2R)&gh?tB(;T7yn&ywU4P z*qLoc9R+D&3Q2$yD1{gd>WwAxUnGqf1^K?=$A#V$Nvd58Wa=mFSs}0(<_q?;kp(mq(JZu}W7<1I5^|n;!c$XyHk=^MOH-%Odd&Tpmq^ z#MuBC%fOwXLx)Og83PG696dV!@+-{TL{gb>w^`BKNF_z@Kr0)GeqCWtq|%5HBZL(o zV-Xgu;-E<@uumk}7kW%Z#mYaHtAk*q@gNYc37`Id}3?Sqa}Cmtvi^XfgYb(8_`ZC`SSltE?cC_unv8c!^i2!$cBsmPg3!F0~#3GEM|dj#LB_diYR-@H`f-m_s#6{36O zq9v7wIYIv;r|7*@eqIdUO&z!OZ)7Xidwayova(w>6QLHtxd8<>vVA~55Y5%?S|h(3 z`saCO5=(~gc$gL_*rPa(tdyuke9Pm=gvU z=fH?rbg3&pB%vLE4SPP-@P?2ZhCedq8Kkhcjblj)!Xfi8$T_uqyKIv%r5%T_2|&5C zRMW3mDji99tQAiAy>TpfwDjdJ8H-A7nNDddBC@#Be!(|bSvQ_MIZ)olqV-Ka`A#w; z7sxXtKPBk%k)fN@l~+xjj%j(;KWWKwT<7=4qx1`vo9G^dQ+3xg>ryaeD*f&Qftd1q z=gk>gbTnP>?lKPc#@tipWro`S`>%{*3Mw~mlKT$`2~WHBXUL9}##SVzB!VdpL9MdI zzA#izO-=;k5$YD(V0n+)Ys>wYZnq)#MDz`iw=&lxe_NsI&;~Jk)k(Uho_^_Zrb%vx z)&KRYSVa9O<1#oyLMfI(gf^9%pWbr7ciL=LtLugqpYO<*Kan#hz*I|jW`byi#15Um ztUDp)D_$wH z$6dTCkgI_p2{QABZLDJZtF!#&BA^#VXoeGuY@Vy8Zq#IGc4MTx5`B%Egm+@2+!!4$ z4Dxx8mEElamb&t-pR1~5Xbc&wGP0QXtl+HZRYkeO+$gGtyh~Z)8h`K?sl^LHJ_zLvE&Z> zJB^?}+w3OQ_WVEnC7N$~($CQBwbAztTi8rKG?ym~+WZl4y;OidvJ*tF9_MtMt?;nO zf7)0y*oMPp+&HOn-1s*Klwf_C=NlsKB93=qo0&{?-$Pds+aP9v3d< zf&Z8@&jzlBll;_V<%z zg`$oAOLMQ!gr!z}T!T#i{?#hPLts?Bk(6L2sZU7)SVFRBf=Qusx&1VM#vlE`-IGK%KiC{KnSodlaXsX0HWZrH2v8zY z#*1`|C79|(A%rn%3{{qBZjkN#3V)WN61$WWu5Luly9*<=Zg3Rw({g=Iw3&B9MK_8_ ztL5^yBEF%7PDR6Jk7$!XCbY@VPh_|(Tv*5JY_P9oN9r5C>eRXkJzCx%kbvU$!}F=Z z{n@K5XRue{m~12?2G&$B6*dG4S=9E3>$(7|KFv2qOd>n?-RqamoH0X+A9h9*qbCGTTFj2bZj^kiSG4thwvFAb#@H%xJKjx zhY3Q7>!W&&31^k{tBK&tP^4{;fk_CQDF|hh7G41*HaB$aGQsN9)4nZLDhXs+zNFol zwj3Az)<;3`pzSIatpu63RLEjYc72@G9La-o%$1Hu%d=5E5%3xG6QF~B(T~4bHhY-K zxc}1v?A&ar!-wS@QGUfm>7Bk#t%!JCp%@;~j5sQZABDN^ z(A{Zg9ptSR?PYivN>Kgr$9YzW~zy(;3cLI1g{_YT)g?aRXeTFqYJC^ajxSIfByyyAi3kN_4nSn zVTgL-xP1pDoDALIG!muN|3o;5o6anKF^=NjJ2k;#7B7D!1p@UmP@#S1(lF2ee)MwL zB0XUu*%rD%2RKs+ebz(B==|@3l!OR&cT#sV7vHOyLlJRm z-K5;#Kw%~fI79)}h&LPpxzMf`pemVZNMh@M6JWK!6XETzDV0P*rh?Kf~&;u=OW zV8mj=1U>Zp;`~9Qt+~~DCCq?ag9x3G#6f{|(Fn36FC7vTQS$A^C$$pKKFrSE)_N8g zG7n3f1yq4z1q0II$aI)DufEU72k$Ee%to8tBv+Z#hBSaA@*gX$p6y|t3igR&8tYUV zIT`gQ<2%5c7}gTFA;+^1t-1)YNe-k54*~wEKDDrX9FHD!70^GG5E<%T(d6+Dk`?-2 zjrRT9_p*P#TFo7|q|d4wh$TejWTU%@vjdfeq~kLC1?@^*ud{ZzY-Jwni@{8M6PGA} z{FC+07Wr)csR_cZODZ99wJSN_GUxUuKd~z^9^@DqR7=k*Dz-=hJ$_bkj=j2hU<#!) zQhe#KApcidx-D4XJ+d3M6b(y~|j*^hkb4^5kgf2kr3^LLH zNiiz>t#((;+RAVVBcl$KAZ92aD7Q(FVOnOdYsW9*@1;@^%^DkRT-OWxXbNO@q^P|_ z`sGAbgZTuVa(zlN@*7gKvL;=9H7E+H-@Gt=8D2>CQL6sz5moaD(-Me466i5@F%r}p z<%1ZnAYwla+B;j!=xBJBAdR7272hK-u4r1ZMair;Ff0D+4duu8)A-T#XUIDF>%Hbs z_d&l+9v7#OKOSv7&V?`jRNc+3y$lJEgj(6ea`scLnCI+V3XmXuJl1unc|91JjT<-G z6Up57N}U@3N&S!&u=9;Myf}|HUUCy9JQIvtY}D+%+&ORg7S;C3z`1_spZ&*du@V|= zP8dlcW!8fVE8gOuQCl{0DePtqe>hrpLN}x-;sNKiG~p#KmaCB^gZ>d0voE`=>`L4i zp;TaoR=@u?0ziOepd6avOHD;qq+-R2Z=RXtoO~GlL0-L_oS&tlqv3fAqbc?5LzB^H?#95hdDhU4HQ@ft^F??*t5q>*u5?725n}G zg*eP1)9y7;{vp=%g&)Hp7Q3R^Qou;40d0vm2wZPY?@Umt1=XKk2plXxJh^Ey`r3@9 z^7Pkai*gLmCU$Eo>r>G+R|u+wvepu!G(S5`pVHl-PzKu6^QN^Ka*xpCv847zN)yG? zX;d3uC%JQmph*be)tYC6>yAaxp}4h}|DRWmZlU`zH5@ zhW?-rvW>}Vg-njJxSlsA`|(VE*Zh^+udkJz-6X(>V{@*o+J-=jNI1^B=K1kq^9#l~ zZ(3NFABd^*!q5H(YB_fCNTNvSyMK`GHgkOAbwGZklBC>G9DH~0G9fP_m}HL}1%*2? zVz}z!#UDbxHxJu$2;PkLxrCEgP8skl1QtyztLIqx`GKD%H7v_khob zpI`UxFefn6dst>*5+_&|V9_34aVd-kMKJi#>xdWi@wdTWSz5&p_Uq!P-=PZIec z&0ZQ>`5T+u+?cQx75?3b>xmE9_pq%7b99f5PCAIvm2IhBXhz-8j8tBteMVJ~1Cgb~ zY>2k@nx_SrkTCCmhf1Z;p@HMz6`L7zj(p2{Xh~4xh_oBo7c>KSr}Q?@fw3JU{K|>- z1*Z=QHxvJ~uWOAr-a-WMeZ!1dvzBR=ZXxbuXB~Tp_w5Tt z^tHR%^2v(w4R-?G<6v8?P^NpeCY0QucOxboR)9Zu%L|o<*$1&*$iN?mT-i6W*JjO3@xY)xOcf z!<^;)kdq;Z-Nrw|E1u3lq_gXf0>J8r9_9J#v+Dqkg0o%?fQ85_`0x|H>n_%CUV}k} ze`wmn46JIaVe)da0LxgMo9O5PVG867u*=kV_Af6dKB$*x76@t@= ztR~0XCjntuXyJ1vN1vj1s0AK4Y?$s*VmQ%%Wc}T>U)8|LB5u6_RpVkA{UW2s&JWMn z(%zqUq!byT>&Np9UKmC7h}n4G8q!?rDN^p;JC&V}5T=fTcDvR1JV~XdL1Njse*8uE zO#y4L=1aDj3`oE`2H4+w)o-w9dNb*IWU>I%BWAf#I2H-`5cwh8*7wsH;|m#+lhQ`O z^PZJg8@_I*+oca#n;D8TKx}bQ2@o8bh}@ky&GyWU_&UN7k=tg@K$h_sIaKD>ZzS{ob_VMy$Ym$JWWHvH4q>oDEmZu1_0rkAdtb_%vHr@p|B7F~4B3+ah7`|eJ@X@{LqhJeO1i*A zD7IFo>FlMDttEvYJsNxE0~8+CMon5RQ{;{cIq4CbEvi}@TmRfj4#JrU1Lrz%LdJuA z%1gl8#ca^d;v?X_8@yl{+Udwywp8MWPoEAYYbv`OxPo);Ce%w8zzEuVy!v&%udaV) z{i63?W6xc>~lP&o1CNWq#sIiMLEAk zBVziaqN1)NMqInC-3t~=1_N+9o$tAaOmRfy4rF@3JBmh7fD)SEJp205NP9a$q}||R z#SO}N`}z!_q})hdFyXeUX#EeH#RYubw$V#ZFNA1+oB#`z_pm9Zt|h+*RF-lp&d$t zWW2fi@}JM}tgVJkzqTNqDpc{SX8n}4@5RZDghS$Vic|fu575P5()qcdqOt@L+!OtX z${l%!Ie&U{By=XQxV(*9`m4|GR6-}dOuH6a7Lz$1^-D{|8T;!SlrsnnR;0L??4gt~ zfD#s}7&zTJVf^IZ`m1rpQJznZ@t zXZGevX!*hIT~43hbKt-|sSY*N)H?rY!s5Tl44Rn-Du78)jxCHFPUDlwIr90-m$~f5 zbJ_WIhY!DceKiDq7RrZkaLu5A0DIKF^O1V66QASPD0|Pau{i_qbdCz>ECSQBRL}7! zZxT_RSlY3~oG9`pbnLs3z0!#zA~rG6x@2whbg$sRmDv-F3*&KH5Vdc;eEm@)sYt{N+~lPMEFP!$CsXX z5@bFD|HNEQ)A}6IAH9-2r`XrA=fq=7!AM|s{6>tqy5rF;XAI5S_jl*Am_c3__YUx= zsEnz2&Pc^0gdNtp#nUmW3-Lu;O~Weg8Ci`8U6Vpa&n$+9hL~tAi+b_ZYUTC6DjR^| zC58NV*wRNkdRN)nLC20F@{{BRDU;}y@y>-}{1|K#7B;mXyBN%g?yXKZ;bh}DWejL--SKG2bRl-!H z;@B-;P_|xv$~cj(eM>#YFOu1I_@_6~P!)3&3U(JvGyzu}pI8P2G-zdGJo5yAamCe?yeZb!>D(|0eDYQHi6&MndjsbH?*{$YC zCuz_{kRnwAK=Q?q{C|x||6y;);O(M0YrqCf;Anf$okI@xLq>4`SrciOMyqaVWtH>R zEvIk?m?0pWhKxHzAuLgG-~wn9o3z(&LXTl$S4_ zleRFP~Cz?#eJEYVb&ng^7dsj6QsGVXp6j!#nn=&YCUffO!|Sq^RHe0H z0k9=CmMWa0MJ7Q55KBtH-&s|sTiy6!wsut9sZ(oD^~;-LX}R#s>CMa)QGF-1KOfLpr;w zjQEpTlx_<~dj|+wKe`s!*VrIPv8epdcWT zD0yik5iMA~*>g)rcC1mX88ki^&#lcGzd z25J9r(jpR;Ul=r6I1xgydt+M?>`K^E=}XfS7UuHG9y#cevufY*Pj@zMs6u5){)6H)xIHqdcFEBY8gnhLn^>na$6%?oz0b98dA}JqCRR*{ zgl*?KY;2!%ZOXo_o_KS&tHd_x-M6n9<;gL&d*U{6u31PNxQtgtS~}#ONwmLQg=u~3 zM2R5_*1J#ci%>j>k7dNU3|pa4C-=p?jw)N*7%JW6s@9wMcJj*Ff|uEv)lrBTlVU~2 zL9*yChL}Wq%cssIX$LeKx6BevzkynKnfZHF>sck+@hda5xd~M=9+})eb2Jt5FmGWe zR`OAZ&d;pNmglQBOmUL2G7?SFSlxc_z)DH11slR7P2y-H+G8n^SL`3N4* zS#vBrtwN0-@>JZ=2d>{aM7tHXcds#4x$+)0izriRWH3(;zjYF0921!*Tn-;YzvA40hIdLaG0Me=Lg*(%?GG z6B5Ys9&YnpT!N?xo+BAd$DGM!76!;=-g^49BbX^YTbZGX&#!x(|GmS$tH%ggZu}1Y zom;2K{W1AE;_e$=YyDfLO-hbR96I}}AiXeY`R?X&-j%5`xj>VHW~%)>sp!PH1wPDz$~!{l80p0JVrV(&U=^-GVRI?n=b6a!VRc%uiI`_b{#pgs0gTStqH>! z@%u{)60(VcSK<3L`2K)4@E{W3$YIWg`hX&<@V}2AV}!xPMl6{#e}jS-){&3(fu-Q5 zsdeg<<*~DApDtYvKhdyJNWz7@_tIv<^w?%}soB6Sb(E6`GJ`m|C7MT4)m8i|el$sZ zN|itcj~}EsilSeQYd@AVQ%)SnV}c6Wh%x|ZA3>d}g5d`#Kt@GteMoQ1;6#=LT}TUe zP5*%=f#r&g36lRa)&9r=s78`N8Yo2GLxs*|CM_veLcGVzi*9Tcf$iH$qf1^f^a`PW z30{PeoS%a5P|r3r^wl=C011}zD7{U-rQt?Oz0H5fmJZ>Sp<^y31^OoN2UG-oh{s70RTd)ja;&%U%ut7-f~T2cpO00W&)IR7kOePV^0)6*~E__`*%2omZU~$ zb>MOkB#5Aea;Vs_X>})A2is^6+c?3_lp2on7ZGE9zfB|3Ii4#;RJt=@C>fuC zG_+hQSBT~M3cxxoV%bevPgjti)D`VN+V1B zwK)7!y~eDw8ewL2p$9~l==r2^my-X}0(k0+T$GBDLmfRsB=s6s!EW2ah}?am%j%+&Y|G-DCuaU}H2ENg-O(D1Uk6 z;%Z|L6nGm64K!omeNzu=AmpBi^Q2(oesPYd-Z!)x)|jQ}=3WyVuk3v7>-xUj6AVLu z5t0r|b%tF_P)?3{Ha(DFu18}S6fHvtH?aMTdz-0kiH>)PhsS7h^M=q(sr2fBJSX)t z#M8vuUF*m}RZ;csFq27zDgd4q88lRd(4TtBY-%#fGB3|s>bX8RsUDr&&~qVvI?4*s ztWv+RlbWv2x^qYA1}bo|CXI0d3X**y%^+HlTanEv zYHo?hpoDH?TQ4NGDCVw`012&dzYLpDrQw`wQUKx&yk=#+tK-a;a#qq~uml_%Fqs{O&2K>{D zAw33wmk1M02~A*_C?Z}n0!N5kLczoz54-wuU@04XKd5G!tI6}T5{i1uZ@dMj;?9`r zi#Cb>5HBOym!=C2T^+c zSNR8&RS#q08X$kdfz>~R{@Nnna)Y=mG$wpf zczKT`BFfM{$R3t-`Epm(>_A|CbfKh_v;?ph4i$r%U?SjZjiCFfOJubNO+S4B!+&1|m8a5=RZD@Y4(<_N= zS)L{T=Qf)NSq%iDiE}*g>!@~8CDp6`{+*=vfE}s@0ArF4LT#1?ns^8`qU_#Jw_cRR>{r1t#S8!8TFr3IuI@80&k!fmAxH+4vX<}McI4OoaQsk$a`M8C zJC!9(Clk+w=@l#l?ca&76ACBtn4v8oihlV}Bs(#h+%ZBS;TOc;JAf<=d^A=?4seH@ zCIrA{!Q3*(!1e*i3(|X^mWz8yoRWBng$1=8Jd+o*CP*!cX z5m^#A#rT8>5U%IBlSZV$*-JucVAbeunSTK-VAh*x!zRy~)jKf}Fk3`9?R0i4$%|xz z@UPoC%_@L1UhONWRJdGE#qxA9@=2L1MIE#$mSym72sq5vKu-T+{ty|s*Wn-noz6M)?6 zVuK4NP8-z%8#iodPqntgyognGmoY;Khl6q11%9cVBtb%TQ-JRL=Z9V4=mfW@?FU+qSW_%we(A4lWp=cqESBZs7a#-l4&Wxb?ujn!w4!{F?XUi`fDw^Cu zfgZAdjy-Z}U4ry)Xl5K;R!D_S;1^>e3ktibW~=FSv6{SIvx-gFaq((i2Cr{VRvfXm z(={ zZ8t3L&)wrE()zsprqe3FkA<{d)CcHWA3d)I1{MF0_y=Ue;V>Ln;9dOxjq=QaDxx6S zz?L0&>K^~bgn)5Au=T8cWu1~bM(IRHp^9>*>`t^PdJHi}=EIJ{^ZCiiM$AL*_Tw9- zgf_XgZlNeM_qO=@!09pHK#KMDl2kxavXtV?J3F}5H>ncUb&JD5$ST}D-wY) z&^@PMnTdP!)Tw)%=A%y!H82?Xy&Z4X?iVj#_D}y)v+DGzQ*J@e<-%*@n9JWnv;dm2yM8y8A)s9 zWf>`=YhaR}Gq2s#>^qhnmUxYmHbunD8VP0!fD@lM{*QmT$|Q5M%6E?jD0}<)`v;x6 z$6N2s-Wzc0%1e5%0qkYU&(HhwW^g_)Sh9vY*;WD1_He;!4jPNGV^2(|t_(eQXO(C< z6?67|on>o#SCk7H;HUggLClCBSU~TixN56-`TqTV^qbkPb~T>K(KPeEcx8jm--GHz zev-yf(=*TW_OsVbcB}P#0|?1IcP9ZO{`?6fw$wQB=kxcompH-w+6NEv60C>1IF+5G zeTNV5A`0xp3lgqyCJ@5kl$yyg(*V(!B85`LG>fFK8`;^?#mk5tUa;)v!^C(8wyMXY zlLL$YxY*O_Q(niu|F8uhY;57OkBzU*kfq%w?lSD;_Y~U`_&2&L+6`*-KyQ}6TdtC>lD_~1c%b7C;mESE6iic(8NWMGP zO@WqbZ?yhRj`n<4*Sm7-_pTvqOhf`A^0-VH6LStF-vC7{wSlV63RHmo*};#-#@+=Z z(OxwNb8pWcJiJjs^Bbu+I@IJ0VtuB^ULP`KZ~J<@c2N(2+# zKri(;#H--ZuT=fuT)hrI)>c77n2x2W;Q3cNkt(>oGstiB9d6Xqry@-R$g|wGXbW)T zSE~+o zg_pZV?b_dP+gYxxq2CSV{6^0JuItIcP3X3&_=#-_yPXw49ma+ku!el1&bHxAH4Qf+ zSJvv@-Rxcd%Ax)DmYD|Z+=7yfN^?=RadjU(rm82`{P}4^egx@yH*<7adl@~wHhj+P zcJWatDr7jfcme{y>Y?JMm({-%t-Wxl9Qlucs!-R7r7`|I=$Bn2o-N8|Qv!+$3U}#L zg+98yWmxq24$-mFUsKtH0{w}1R=r$CZs5Y4YM&M?Cxt9ptayRHJr6)H2_#Gb;5c-s z&f{v{Q7Nirj`y13b|t^Lm%=4DK3Sa@1=rfJfp{4B%)s-MZL3QV1l&Z+pttVVch3v2 z*P4;|sUgS$TqJ`EVm#c|U@B2y$1 zQSeM=3BV9uh?#J!NN7Id3EDAAiBBK1e0jpuxQqJpAwrVa1UR#Yyt#G-l%=7W&cyuz zZ2xG5r)X8=e^|N<_yg@}3Sv5{PSHJe%jvXG6UL389@*Gv!XFSZLub|G_?xb>T*qM3kug8%{c?6U)7$G;WKrjrj%-jM$7lc^* z>4@spgZHETU0zYxiZfRck!8kNc(vxwYLJE{nv>>o3&g`Rxknj!3sFbZ8x>C$s35dc zC^Q#SYQ~;=#wjG@AF$=iw@{YLjL;?>4AfLqzO24rfVtI?_$Ug)PLr9!2e(){qNchT zSp3D1yyH-RAOf(4?YOj;h9S05H9Hy>KY)Tg(%<6OBs3$^y;xaUeZ+AQ1w$&g55!;m z8o;C{UM^e=-XQ@F2#lK%<0C$Ad{MryvLc))2>Ua`;1ED6`&`tcn~o!$SrD$^E?!md z!fp0UbPd8)DJPZ$zRM&GFlX+aSUR|)wM}$H?0ANSN)ODTCp|D=qtN#v@2*o<`PP58 zWT*jw5u);uN8%zUM!u}>rGJK8L(gbr6S9D2<5_@}G)VSckOwIqfx_k8+moRQOOH8Jm zNg62shV8S%v9-%E(7#6AET{&r8m`oT+wFw^;#djX^T0O|yzA*fu${g9lz z9E6Lig8XEsLOzHNb?VeIL(dq%sbaE3gukUk$I=a&9?E;zqj&F8<{PX3URqpHAt9}C zUB?UkAtJNdw9CcCLG*;>hp-INt0 z-VglU9Og1y34ji*yD#d9hyIP$9$i8N?*{dh1;&hE(D z(^w6PKXcAqh+q3Jd>HdNw10eyNvrjx~D2Y5{Gf5_VHEZ|skuuBQ2r@dl|CwSm}fvR|y=yjii zj}Nv_QE+NMSa$CIa71^+6`V$3;m2A-BX|!fg^Ap= z^8{LQ*ZRlG2(PL;0N+te`A==tALoZxe1xboW zW`UQ@7|cReK5lj8SDitxL*9obvYBGT&8B!F?1(~)RO%hYXaeS62JnC|J+!L*TfiQB z7=5w47k*vpArApi71>0-rFmDtpX+T>=>VYarpp~DmCYTAF->?2TeEEeWMBwae1Fb7 z8@gm-3QX%K?yCJmVbWNJlD$*$X{IZC6t%Yx&MpYzXqmjXJZ7RWm8MO_&`aT%iplPd zN6YxetQpvqT7R|iUQn)_E_*(#X(5ZTF1kB0XR3AR@Hp;$(7fO-r0#C=e<3*-TeoiY z7JfGBma6=&z(Fo~oq6jdxjx_WCYotwz9UMhcLTIGtmFx^^3N-AT$F7D@In?H3SNbt zjm$~M=IZJjsOAqN`jI8W+{BK+Oam<*3;(&TD^u7NP)}>C+VZ(tjI^cms1uq|YN%4( zn!l6zBrtmUmSxKF@d4EAbQPdhO)qvjIex-~(O?Fu%`%&V%o+N+)t74xN4%GM|9(?| zTB35rzbw27^>(r}UHmaN)V|pwv4oUx_ zV@b8E)nC*g)Yg()xpZZbDWmH+LB^z}E|sASijM>_hU~c2K(62f;ExOz6eC%_`}CADz1&?c}--3vSW7S=!Tfyc?t5}XKHg3uo?PFAPRr}sIc(P?|MTQ z3NO~-XW5QP;wO;7^W{DIpo-W8<{iXCBbH1PQNzWMF0Ez3WKd^T;&peTS_udYEH<1N z1i^~n+g^4iGvp&KF5~Mb`pMtEk_SdDYY%C%RIixq%tpH>y{rSr<&{ZPGMz61$b!d$G!Y^0(x zp(cPKYUyC}!o!>>>*6-p^PLS|QREQu+4(DtI!q465&UjZkp((eJNxjblKH>xXT{)4?|Ws)tn25xiL3(Jzz#awXMdSJ z(R^qWYYZx*l-33XFC*~9gV!a(b8Y@>@$^zP2r|qVF!JhP!cM%eBA7yQNGG!6DDbCo<5jH z-uQ!)wiA#7nGeMg5&%H`obJaT%J^u-rr?)3#2G=>!~xTvU2_I7p+IDo zisvt1=9RfthQz%ISKGMN(#2ziAHa7)uJHIg4oMJOH$8dHUr z+p!Lmfna!b70`7uD2jK0izVIRy^9%ac)g z1G$^7Cz8mIa|CIa>9bCn^-qnqFmGVR{tIYYOvR_Hkc%LF(HPoQZV;t1+C0-QqMMjA z=c&u(qY0Zhy)JoHY^F${UL5xY22RqCUcd84v^gl!r4qFQXU-7ObE1HxgpVTP7??29 z?)Xh+LXMug1kg+gl#4UuFip6~mH9vww7*0!1)ZAokGv(m%^CNE2!%DE;9NvsD`8U9 z#X_s1)v#CY;ZpT~S^&~u=oqAB2IIn4ArVP1|D&C|PjCnp!X5pTc*H3Sw?V|i8<)`a z(s8y$Lm(}L39E~wX$)212d9z*DeA%HuB)^Hv$vn!nj2MY$02?b0r z6+44rExrt)G!M9MWcT~rAm_t1MnBhn{XiFqgntZ?S|U~0x3Bk1MHKTR2AwEw<+?ZtK}xtQoDb{G8&{ru@utwa9uie~W187Sk)5mQDg z!Iv_Wx`Et|{&NE?RQpbm4H!5!1+-TH9T_o$j2bvk#LRerZh0hI6MbUJ>B{~Y!jq8E zJU~aHjF(h}`O{+-Wr>r6E`mC@ot&stX%0j_VNnz-qudrcwtPM9IAj{~eE2ZXC3oUa z6zj7Vkr}@u@WV>k4D0f;d4rUo?&Qaeqx`nA@M&yzS~=1?sve*^8nB9V!U4qkrs<3 zxZFm)QhYd|-}C3ry~)X6z>)RHr)~oq+T#4|xib+MHda-gN3~)>ei~!a&q$qrfW`nf z^obWN^?(j1V`Jx{*BT-uBrmQjWms%-^8RugtFNRQ>4OL!1y^Bd&RDRZNB*{(=wQ#_ zO*_lo>EAIl17e{7Ty6#eUsMY@JcLKWGEkvTnL2eYg@Y?)Kx|TyP03mwyXk!fupIpQ zI@=e)V>qcn=h#{q1M(Kg<1X&aI`%>rP>Z}WwAu#^6VGef4{YM-p+hMm#DP}0=@ILx zjYxJa)wBF6V*JlYYKU&%zR>Blg)pMJGb9)F<8*pG^=X zuHt?y8rIhUTnT>M+y0y?`mj7FY+YRXAXgA{pDH{Y3<`tPb9}$MSuCs`-5+VOoHe=? zIc|oumsq-k+YfGvzbl1j@BoKiT-V!MKzwBO5d039MC4svD+vY>Sszxf>)72Si-tCI zsb-KuY!{U9&3I`gKOd}b@k7zL&wa>QuSYTwkp_ZV_CNo2d$OD_)V`*ptDfaq?oL2x z3`I>fD5EPSi{{wMTjl601yh#keQdVqBggD3+MeZcuHnL0D4-aEn&=Z zj#A0UNTSzo-U#wNaLxBkoUU$xCx*_ESAeDp*I1oFBq-JOc0^njtq4brqX zuxXF?z>%7D&;fd#G09_qh7po>JAbuito86_EAi9G87jIJc0B^t7tOBg7~X4i!{$LS zokvfeymR$;)vWmQD*;GfzI%69(XT-R|9p+3-w`FZf#FevUA}y|;C+|1UtTw#1(i}) z9Lcl3&Ory1NGwr&+41gb4Q(JlA5jb6Ec|zwSod(gEn{drYtwP@dW4d9Qy8JE*5?TL z{{nq(nEwA$)|toUoUeWSmMswq$R1FvPOi58)Ovz zSX*-l6g@7fr;~7NkaC|YE1mCsmj;tjk9};A%M`$AcF!|W7;&dT`NrP`3~pko(|q8~ z!VY_2L7KN{v3Jb~3OS)J_2*pX^ch?=c;~il_LKwq#!31ZT4wTu(({i*pQ?MIH(VX`64>hl`N0$TkeN=_2F;#!{IVL3xn-snYHW2Zm*|%S=O*>2mV(JJicx(Yt^~ z-e3q*k3#E}T-I_y17!Lq)S-XjKA`@Yt5beU9rG6oF?)Ws{)SevxY97cTpSW}Y zgbsLw4BjP}gnMAnx<}AVsl^}6J$7)C+H*9k9%<;kzyDnMuLp*%)RmcplqBd<)Xc(S zvs%FMeXa1S+YT0Sj0!_cQ_qWw8z{KRB{z>AwYyQXMIc_s?p*9q#%&?7E->HS3#}bk zCETbo85oJOk;l@Np-ppY7S(V+i~a$KRBRw92baJ2r=2J&z_^($Eyx|@lp<$hMBUdQz&p&U+D(X}(`RzF2L(@-)e^Go0CFkI;9SnzfwuVX3mWQ5B& zHrxoN81gc4Sek&^#Uo$cr1_cKOYOnL;hi)?u2wK}9L(}8KbKkVB`zW0YC`o$c zn>g$Mb_(G1w>su|_eR~BvqQdoef1+X=Gz~(A3IzvoP)X+Vy7b|zk}idAZ3o&hey=_s@efB(dcosFicH9@J z#SWxIqW%rE>2kLE)qQ3U$HGkKlMubI`P-|Wzv+M5(dm0Mm#3!U%k%W+xhtLWqvtDZ z0E~PbP&X}V;w^)m48K$@`jlPqCu^Q^L1*2W4KF{7O374v9_r6yb91^|X}30@@o=Xw z($KOdx8kNBj;NFRFEWciEN93E=+Jzwc$U%hW0uX&g~D~Fw4Fiz0^j-jDq23;Sq>Xk+H58_wRT5V!=#(15=#ovvcP}pIaRSWs{XtL)0tLN~)?d-jbN3_y2U5OICMhPVW9St{<#t&FkRQ18SS{UUz@e z8(7)uAz}mMTs1mCh@d)0 z)q{(xoKjvuHa&o;YEyUW(EBQFdG54Hf6LG;wb-+U8u5u$U?x}2dO>ZBlJ zFZV+GgqmK19ioRq`i`fO$=hRPI|cEsPv+Ivl5>%*K;z4GJ=2Jv8!WPNOMwPb5b~F8#_$ybyjzW8li76|9XKzN-8dLW4poL}7#crn&L{D&=5Qc@h* zWqGei2tTB-w4SG9P$|30=(6@68T5%*Ldh)e(X;0sibc4Y-N3};&X`xv zpNYkgQ)c&-gnc`g^%dex`R9Ik60Z+2`TKvK19S4Z+u7 zA7`1?6UVe5#_gWS9kRX1A$CWiI(d+ytD~NWAnN6I*xiwrNKRfR&*WI(k6&FWV}mDj ztu_3H6F-&fNFq}Ql}#Lfx#=yNzWiE$ZnYcGB^>jujVE3TB7BO2pFpaw$$Qq7WI^lm z?WE6doZMdDV=yuw_Pci_p$N`cfNNd=IoV2-C)NE}X&{dtGLpxB> zPT~dFJS8U)w#b;cfK8Mz9O=EIUA`=l{N2)0KLDCXS3ECeRjIw~YM)`-fvQK0pna!D zn<6dASyAYVn5G!Q7R7j|+4jB)!F35B+r-Kyzi}JwjqjK2kSOF1gc)B44tNhUHz@gn zk}TVOR~Vm6>bQ8@!G|=ACmwRAfEN73m{g1 zGmBczynh(pcp`}c$H+k=BO7-_tN zbPkDdr`O%Hc1Snf!<7H_h(s{UUY7!oowo3NdgI`@>0=QiQNWGnH%VRrOH76N4+WGm zbopD!aZ@I_K*PAD_o7c<-=QC=tEj6T!EBi}C_F|kUVI`aPScwMo%@LdZ7ojI`uJZM z*Q>V2T`&B$-!Oj@C%hvM;Vw?*!mD0ab5_`hSRYJk9U90iUmxL2fOd7zCHaj z(*&oE9=#=Jw{bY?qiX)A6^1D$bv2-FQHPDB`^| z%6*#aIXK^h#*r!L{56hrg07*jl42-Vj!G~bCFNpDIp<|Av2azAfIz5H6l@toK+Zpk z`tjxjYpV>NKLXQ!kd0m>hL|a~wjr~spDW$6>BPW7YnoV+=Ny5=-6&kcx-~--xP#JU zG#Z8lj5LFI(J;>IOR#nX=|hvj-z-7eWhNNhAO~mVNUnKrEdXd=32f- zKKnEvyyS}))fF94T_RsjdZJ}n7*7FIh^-gzfn-g25@y5D8$GvZ4RHFA0u`xt{yk8U zLk`(udYMYyXN&sJAZt%1@Q_9n2qfaj05a6TB}tjpE`RK4A zGf&z20HvXkdB&M3dsKA4XmliOp29^GgRIC#SsC(KA_?@DeaNW>C#-}!fbTP(Ta!41 z%^){9YIFOL1x*%N8ubkHpeoajQTsT+j!N3Pxz6q!wZ@Xz58f#o908zM`oN70mOd~L z1XM6Ux@R(vdbr)y;O$6yxLBeEq{Q%rm8>Z}JVcs3zgH&M$4441b(GzbNiFt)CHV}` zkZ>%t{*CAYe1LsfM?(-~?N zOzs*XHyg9xG|I2y@8UC{SIXpaSL@KhpKOL2UUo0?Hf;3j={Qovq~jCY0mt6!L=t8c zbgkl>A|M0Le^(JnZi zwFDs`Z;zHym1WEjrJ8yS4>y6rhmu8B-02{8L`10D}QNUvIUNJB1dTOdd zY?*m^o05{;(O1_-ys}{D$?OM?dK4)4zYj+Q0DY793UVuzXCM>{lL$97kO*IYe=Cfu ztUZS*fR$@LmNbJ_*uhJa`Pqcp<=LZg>RoGa=HaCiz|T6h@9$yE1PkR6vIbfKmWlEU zm(eJMa73WIA3M}vS#~?{VEs*5^C>&#`2jmS;RXRhs71vU&U**-aEdh`4zaKb} zIjRivr7%|&J{@h;3OY+cKS>`m%Y1DBI#~F5RsP2``MG|~U3tdM$v|YpAvbsuzB})B zwd}6`#An||PWR}?21ABOaVCyUVHbxXhaqc4TMR=0Ry~AtYMVW>t za#pELxkf9sTO3yWmSlvSENl4mjSL%+L!6x-=8!n-4|Bav@*plnVAw+CWKZ=VsYx<9 zhTBG2>-6krUF{1lqz=d^9K74I5!ewWudEy+BcluJzn#m8D^&G2zdkB$!19fM?O3HO zkf2L{kQ<{3Ss27r8dsLRb2b0{tYUQtQq+w`w`KR=_f9*a*Z zm0#07WL5~r4qs!!vp4hpDptCs`R2W3MB%|ha!;~=1GnF%$6ZgvJadRWw}P)=sDR(U z0I(vV$smXJ1iIiUYG*wCbmpkE`X7m_JI?9Pqj+?2RdX)l*tocB9EZL;@16S4I&P_K zg12+U$Hg%OSdfa=m{#JM)55=shTGIXOPhvbeB#?lj^9^;KqWG~yRNQ^*6Dly{UCAe zPh47q;bG5hsL}7?d730#Q{Tj625S|yi%24uT;}% zv)7z~9*BPA{^C=bWvX}nwIDJ=L>)t+?hR`vACv{AqGdJdfB&cs(1Jh{!ZK0cwtyR; z=xC-juJ!-^$QFqh;BAZGfS9}HTrWJ1aiumYnI1o%WZVn`PF)^9VM!Wt?QpUaDzP)oQ6%iJy9e}xE4!s-w_p{oHEmwl~@X|3LuLzveY)sIw z|2~RDZQPc?dQHh81oHQ|bai2H)z4S$pbz(}N=8Q-eii}xAxuDT$Clc-Ud#OTBd*WU z@p1m515A48v~cauO=YM%My4`w^@y5Te3%r|qc?20k`rg!;=doPWIQ9JcmfC$GwB+j zaeZ(#@d}jrY!l4QySpi8*wlX`_*l!jOCY*GO){seE;A_%4X<79hr-Q=4|f&@^MYHM zI^ji<-zc}H=ihJ;LRo?)=KX~UKw^(r32rm#y;f9zc0}FMOfCLi(OIn>aihmU%cJoA zQJYfp^!|E{cI|o(n0|=yC_d5yAilE!50y(4YgH;uQR(9TVymRGeHFZa-@dNHhtIBl z${Ki?V*9?ep+j^t6uqDG+SoF-5IXS0QFCWvdlYY^mp`n*#~x2O`>e-gF8u;`X-BknO3t#P_w zJ2EGOXYv70!_(N0cI#jCg(KUiz}@*)eT23pzQt{(TIvw$6Ul?;dl((HynzHTipS zNy%nOYCfCtr6Wdf+lrENkQl_)NS@TD1uNa$)-OA70qWc4@|rm9wYGibzR^8I`voQ% zQAZ$E3lsoypesc#@k+Bdr2gsj$4mX)mc+`sQyPwXmfW$UuC5O1GSg=>Z3ou>d9IjF z5`3$Fj!LuUS>bg*Wxg9ZKf!DBV;M8S!HzRKy2!0^E7RW$X$3+L<(@t+hqqHOoGLd8 zWf@{1e)q;UiT&wcWm-^p#fnk1fB5qKdE~tf3I>88vTOFfBo=S?^??cQaxmW+z|AJv zSPBC$T{uUT!zVloFhZK^Qyk%K28&fPa~NYE;Y7F`BnX* zES(Mx0aNfxaK}iEN@IZ#>jpKo3`LWJlYu4tK{|G1Nkz}D&wv$|^rrd=F1$K2F%Y!v zMCR5cw1N(XG9l?fBgy&|WgWtCStiq`Hz_K}Sw$UiT(1iFRM){)p^#ux}8u1O2}=uZ0=gKtwS}_N5f%+~hn> zEi4Ri$$4xJY=S~z3%+R%c3(X73`Uczl8Y00uaccZ9h|k4%oYV2R24NPOE{^WwW`CM4m}hEK&+Q4cCy$a3{-%D7VEIx>83Xp0}VjhrT5YXDiR|IZp?Y zM?%4bdF9fbhi8zA%H!GXNzo=c5&_6;9l>g3x&bt)k{ac95y&w0m83#IQSC-041>%y ztiu?q)cAOBx~nh_QRFaUF_tiqd-r0_XMW3mIyd1ze`RH7pFQ8cCi`i8d_4E-Mkose zhTZ!19T#E^9L`6U9CbL{T@&U{gmc)SDSJd&}t{VZNUuo0b8B5($8phvb!W>ED-TLrJed+gSr}0)0J- z`uB770*({$Q~ZqBlNRPz28vdpvomPQ2TAHnPZwfM!cEX6OKZSCY^{boYChKsq6Y!9 zz>pBlSjJyb+>`>%IFLSxOSmalwkf7%3>dPNE?m0Q-1YV#s!XZ9xNsS4A$d@jtDbns zSr1~|_DIxVE)p5G0F=OxMzq=zrNX!+u?R^&j{K9hZY!VZ{K?@d88mR>5{Cv6zYI%S zx;m;cU%I-ZBYgzDB9%t`39>qJb|>>()sO~1BO@~te%=6XR&qVj*tr&rb3Oy-UPB-8 zfVgWezxQCLshOEk=@Sbbw}Uv-6MEB)!_o^pKszL-xg>XpB_cmR>Cbm5y~lFR%8#<8 zN7U7{!F0er5#5_4w*cE-D=3&5SnfxWR&Il+S|sseH-l^l-B8^d68GV$s--l<;)_}j zv@g-`9EPzAvVvN!+!`!v8F!e7Ah^E6IG!NoWN05QHg5lzb+yf6Fo$rl1a2^7V~?bK z6 zNK}vjPFMiB)^**&XQ(r4fo4iK&St#W>;e5L=`Hv_^H|G{m<90QnA1-upc_zW*)mc( zlj6j2un;o!H;)WkOGGQw%cU|~nplcx-8uzCod#2fo-`*kDNMF>-f;HMU;={n&}lPAeA3dT(K#zZy3_okX(Qq=fMgm+%nW-49*=H$HYq7s z{2zcu@>{X6MDXv)m_z!Wzat;Lh~?RHx1~8msTvL?a&cuas|-v=y{GSXct17JF{pq^ zyj?46>s_=WW{?DCnf9uF0Ra&#Y{40!VsqIja~&@n5ghOl$0xb0{#anUyS4R2yB01; z9_{?;-&E?@H(7AaNC--dQHt&LxL@3in%;AL`Ct1&jht}XY#zdzqw4Q zZKh@Mj6>QHBZx35V=-VEPaKYhVUR;c3w|a6F5#csx7!-4J8fZ0?7>+u9udZ8fT|(i zejhqF@`g>PO5mRs9R@T)GH?T}z39E2;F zQ)>CP9lfwLbh3LOy}XI}IR?xauuh+&sPHJ|iX`yBP~gTafBv6tciJ&iMFz1_m?ORq zI66}hTM+>qfSRG_d~j;vKlW$Yh{Gh@n3W(2Bz^my-hXBE*Rvj!H+XZpu=lVA?ru4I zRs#XG#KI?(2A#<@S8?VF_9>Ac)aWZ$I4_bGiiP?4-Q!NUkwLfCmN~6y6&z<22~WV0 zpUK7jfkb%~tuc|@mz?7|V1sx|UCU2%>Z4)+HB19JEh(Ha3Z)fOH(a1oRB4anu77v2 zZkzmg&=``G$#GeZc2E>hC}+-vK6*aJw}XRgB4>%9-7iW?E>9Uo+EoJVv688xlwTQ% zUa+i~^WrGPdmBYZI2E*a)xPC2Ro>)VNgJJY?#VYiDpJNMZa#Wcv(MEiUk0Ju#~t8K zX_q(mZ!D-F^px@olM}8wKQzkA&F!j?Wesse+}3EaAiAQ$A7EsptKdw%8!imrIKJB; znm>W0(=#&i?Y4e=f6m1B!LkrK=gkQDvhwmi`rbdha^qjo0gO#O3U-lXX-6s5NEpn= zMa2Nujl3z5Uh7*=oVej#GKARa84F$)PQTlfKA{J`^E{5tws~FDut@xdSuU3==|!P6 za>WKm0cA&29WdAFN`<&>*De<~56M7URhH+=z1Mrhh)|A0E9`n}muV%1XM8zXS{|9q z?>fQ4N?2Mj;9z$B9#GfPnxLR0JCRqNkQip<>lt9b05o$MuJ; zUG1Y)n-NBglp0(2$-p14mu;V3<+5Z+A0eA4D11LZoklLc8RV4NM}`;3kxjO+NOVh{ zgz8CX62Kxvc&FMBu4Uh+Gp+ngUfjWT#`@p0_TXWgYil(f&T3;fL6X<{?YeAkBOL$SmacZ!1@5G9W7psBlAMMK#EQ*Yj$UiU5AYcVB;YeiJc9~BD{wrqI4 z1quG?GEVXRS6;%zHS*??shnlk-)<|%G;@z^&!(`?5mWVG_Siq!*)Fa>UM?NNqe-A> zyXaMSZoBsw_js)eY>4MO!{2lkMyo;vIe*q0uUh_&S#hTlS@C^}5)Uwg!PXKShkExd%M_r2-NncpIu2Yq=^ z$j|3M2})oTN4y+qb3DoubzgXPpwuQjHw0-0D4(-Y$F0e^`6GL;P z%-ryH33s+&Oz4Kl_g(Gf9b30H74QnbBv+Io6^>*l3tm!~zylqpUs{#|E(pSiNL`3 zj~r-duH)f2Vn>GJztLB&Fr5WzODZv{H6L@GYl}iX^P`g%z&}jBX;4i~jQ_7s)rO8f zenn+v%|P2&J;HF4nroBn8u583<=uoO@yo0$xsxh`qr$@#3M%+HhO3HsVggIRRL7kE zgCl~zy2;T4yk)KsXsLP7m)Rpu1RhV_5vLJHv34#o(K*+MQqhWV66Bu|@zT-+F$;|r zEteB_cEvZYcgm!}+x+|j`}HM%Qn3I9_w4B+6Y8#kz9Wi{r?bvzBon}O85?r`!PAdL z*BUCBazN)DtqNFW)uC(w4}vgF4OGn#z~cR=FCJ+ z#2}NNjJzP~2L(*NzT!1Ed5SxWghn^(pMSPN9=*A<^F?|21d51AvI0iGa#s`kgq zOB74p5z;A{0)a>J76Z|agPB`ey9QOcSL$$^@wp!q#k`fua0>}5o2U%osuCApBGRzr z-Mfh#=#kv3fhaXon4nb|IWhVZvPIA`4fHqax$%x-kL@=6_$po;bmGJ=8@`6Q6`)BO zMFEzl6UR)R>LQ<3H#vH;rq-m~q#B^j4FD{#i=HsEyLz*OAt8A%J0*qI42$K@SUnxb zG3g5N-Fs?eAj+3j<%RncIiMG&C>^^i@M%~;O_UTDkCJaiBb`f^Fo7#03UWeCA*Gws z{eIj0{T-KUQG#H`SBsgI9K>o^3|=LQ6h>yWfo>UO>@~G|Z{lOv`v0Sov7O{^`R?I9 zJ&N_a=%;MYFPrVN>(hd|9f@5*1Hc;6U?U6|s~lFGV9XUh3f2$(e0bmws6?43CMy|e zc#>skbftuI$s`#uv(Rg25C4yxC<}RPBK*Xjw|QsYDR{Clu?=GCBW@!mb_2emUE(7_ zKKth!vmVv~Lz{o){zthr$+Tm-v8c&W&Vu5QZJBcI6)Z(`z=uztZh%6p;FzE)H81@= zCWB^T1vM{)&7jxk_68Gi=_4p7Veb&Lc^&rId~esWqofQ-Gzx-{pl^QwW+jerMz@#(&xNb(^R`_2IrZ5HrNP}2UMqew*%+78_Qgt>hxV$hUXYCN@OT4N^FeSccF97cfTp1HBlRTPABTv+u+gOhgN zqD5P2eXpI14ekMY$AvjQ)Im%d_@lW1gQBSzJUA`9wt4|_m;A|yB~ zsQ`qK=(~0I<$g3_i0meowFL9EGv2uui_?bcvYwqy)@#bS2TCCFx+nV`?NE2f99(2R zk`hVj=rmaM7@Cz0E-r2#}NXH(rd2yVs-k2Zy-)CKfkr zu0;sKHnWqM<>8gfzq5Xv5{8fCJjLB^p#l3`2@GI z%iKp5+Hl(##8pB zr={g!hXj3@D7q3Z{z&kZFo#u(QBDn7^q@T!k2V=!-AM4z%hzO zrHle?Y2N0yF&Mc!PB{GgZlEAX@J6%DwSVz&kBcA%E5c~*_|HT=W8-LjFF#*JD`pf> zO&E_f4}*oWqO#&?=nocK{-LKAddQa3Dg<(o0-RZ8WjNZ*G98nU-d2+=AfAgsAl2J; z>}YE|Wjp4vNLr>n@RSX-xm;|otRIR=XJwr8{Qm<9fG917nRP?%k(_dW{lS(F<!DHE^tjit57b=O@3XW6O4d9Kk)`VrkRU;iJrVAGYl7s{C zML`xIu5iDwcBh>gp|!O1Dqdb*jT$vF)!8j`gQbClOnkB7TU)umlc`-DApF6%(y6B< z#c4;!!LUuLLYO03*#t>g4CoEDTGvQ@7PEm2Uge}Q zz^5*Q0_Yn@qI75%6vj|>^cJ!g7&sXK%yI+c;<#YFjYw1~{!TGvCH}$+q4Kn;%D8x2 zZ%-H10d{)|ehKW6fx>BN;gkQZPMnT2hG08WUKzk)_y}Tf8Y@J41CSYu%aN5O1U~nW z^5NG5R@CGrGG z!*z*-2BoA3qGD~OkTEBCZ8dSJf~Ui7u6yvFTtU&3}JpO@#3(OcwOu%AE8Zvaq zuo7HH{dHwCAHw zDtPo3+@C40&}NI+E3dy2?xo5rn#yYjZhcuKjLswgRmla?(h5M*!u>1hB=mOZONCRU z{)x!0fH9)rl7S=4#sT-b#`8jqtNHtKZAm6)W2k&>ALn(duj?ug#4!hHE`u~uz3S|s zQ54!bWpiF!rLDMcms!^@udb#l)FbC7CE@b#r~*|s4nrQZ8f07CuK!Q=vZllMmRutI pr>l08 threshold. - -Documentation -============= - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -Needed Modules -============== - -.. Do not edit this section. It was auto-generated from the -.. by the `update_README.py` script. - -.. image:: tree_dependency.png - -* `Psiref_Utils `_ - diff --git a/plugins/Psiref_threshold/psi_ref.irp.f b/plugins/Psiref_threshold/psi_ref.irp.f deleted file mode 100644 index 62321140..00000000 --- a/plugins/Psiref_threshold/psi_ref.irp.f +++ /dev/null @@ -1,66 +0,0 @@ -use bitmasks - -! BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] -!&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] -!&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] -!&BEGIN_PROVIDER [ integer, N_det_ref ] -! implicit none -! BEGIN_DOC -! ! Reference wave function, defined as determinants with amplitudes > 0.05 -! ! idx_ref gives the indice of the ref determinant in psi_det. -! END_DOC -! integer :: i, k, l -! logical :: good -! double precision, parameter :: threshold=0.01d0 -! double precision :: t(N_states) -! N_det_ref = 0 -! do l = 1, N_states -! t(l) = threshold * abs_psi_coef_max(l) -! enddo -! do i=1,N_det -! good = .False. -! do l=1, N_states -! psi_ref_coef(i,l) = 0.d0 -! good = good.or.(dabs(psi_coef(i,l)) > t(l)) -! enddo -! if (good) then -! N_det_ref = N_det_ref+1 -! do k=1,N_int -! psi_ref(k,1,N_det_ref) = psi_det(k,1,i) -! psi_ref(k,2,N_det_ref) = psi_det(k,2,i) -! enddo -! idx_ref(N_det_ref) = i -! do k=1,N_states -! psi_ref_coef(N_det_ref,k) = psi_coef(i,k) -! enddo -! endif -! enddo -! call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') -! -!END_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), psi_ref, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_ref_coef, (psi_det_size,n_states) ] -&BEGIN_PROVIDER [ integer, idx_ref, (psi_det_size) ] -&BEGIN_PROVIDER [ integer, N_det_ref ] - implicit none - BEGIN_DOC - ! Reference wave function, defined as determinants with amplitudes > 0.05 - ! idx_ref gives the indice of the ref determinant in psi_det. - END_DOC - integer :: i, k, l - double precision, parameter :: threshold=0.01d0 - - call find_reference(threshold, N_det_ref, idx_ref) - do l=1,N_states - do i=1,N_det_ref - psi_ref_coef(i,l) = psi_coef(idx_ref(i), l) - enddo - enddo - do i=1,N_det_ref - psi_ref(:,:,i) = psi_det(:,:,idx_ref(i)) - enddo - call write_int(output_determinants,N_det_ref, 'Number of determinants in the reference') - -END_PROVIDER - diff --git a/plugins/Psiref_threshold/tree_dependency.png b/plugins/Psiref_threshold/tree_dependency.png deleted file mode 100644 index 9c2088e1946aea55e4e7034ccb57865b43145554..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8479 zcmch7hd|~rGlKnxFkWNA+$=>6bnI~Du*4`~4HXH;(tq>wTW{exB#Pulu^LN4T!G+Bq^NG6X@+-BMS%3%_^aCxrwbUTb^m zvf&qzwWgX1a&r3ht|}`YLD-R7DmV0f-!7*<(baPpZB8F@F9@+UJH7oRM#)E}-64h}UtL|1}F-^p>W z;iam-91_b<`gEf*=xslv5}KWhCw5M(JsBH6_g8Mtzsn=d<0y_j1bJ$-7#mKHRxBm3 z^$amYM@FxaWviSuYEUFmQ&nBN5^BX1MU<}HA?9=s|0!C9bMWKZp1){vq|UmU zSyNLJ5fPE!lPAQ)#B^kh-Q85Ks6-9B)C;Vv#byMutTBz&`9=a6x-GV%_XX(FyXM>^ z1?VHN69e0Medc|A-o9*=?33$L!OPm22A{K73WmZVk+{_ROO*(y6X)Zn`=8pY%UvoCZhc z-5hXO0A{wc~Rp99xC*Qq$*WKOy?KDIb6cq3oY>x$)FrRxD`}+E1 zd{#V1rdCEOd{#%VF-7?j`EL-OIdg`PP(AZ!ZLMNu9vK-Kbwr~Ucf8RNYuo&Mc9BzU zOkh=26+EPG9&T(b#=)jwaN=KB?T}DX#zaNYkq|a4`cUhLmz(E3eDL4_3WaiZ{`2RL zGYU07KQEHffgluNG|bHWaq6%xoGywyj$f5?4SasT)8*aY-+z;ma*l`qLDyNT+`M_2 zi%UgSwW+z8hl{JBu`z$p`Tf12sq?CgWk`faEda~!#OiWA{ z{{;QR|MxGH zl$2idX@=loYinp|XlZHPzI|I=9cJm;H_MIj@$$N- zuis+({l||VFo*T^M{(+#Ygo$W=H{#qr_s>VbT?--FxO+jD&NT1#KcZCS&Q4r*|{?C zXn$=@BuZ6NL&Lbh{x*#5?d^?1Wiuy~cF#lVFbJDh`mS5wyLV4dk0#U#hr_`xEG#U* zYinyOifYouNZ=KG28e_aXB%1h+NyUp&8=qYvXi9PTgW_4fACN6f^jv9@+} zbhNhKukzcfH~(e9h@m`pE>%9D{KJRozcXz_!5s4P^4I?bKYv7{bw^EL!+*_|BKrFJ zZxw>7zkK;pR+ijhpJ!1MxYU;mPj)}nHPBqukeBxI<;#tYjdXN$uyO0nY$qeDfk`PT zOQa5iFB&yrkMG|f94v6?N>_N8Z}k29cc_ID*Ac!rb=Jzel0NPB8$M$JCEm-%qRH*{ z1?i7xli7j}@8tC>DBdG!AfNXvXM+u1$V#^_7_=3Y5)<1vSgm1WW`2VHG;6;(Iy$;D z`b0;7UXM2+*QA7=fq^-yi5Nxq^fe7p@Wga$JUnNHE-!WXbTFm7E-$Uer@H%?l9G~# zL&Z_57^tely{@2@#l<%j#)Q_@!&OgqQhi3(cXqOHC>ifRP#kXG$N#7r=IB4!{*%$O z(Dq7@pN|iAeIx#*Vmm{8>n5apQ)A;*#z=*u1)W`wR57vm(?S@);~_gIytKS=wa@T|%>2T^SdZPEg`Tcdmv_Zp@AN@R0hBd&l9- zf{k-ei!euj@#F0j0N0Ogvqr_Sjxkq5%rAWlbmc4d%GL*Y(E!7_{dg9&aTT1PYkqP z=%9!g-~PoS^;_~}trpw*X_>1dUmp*&~3R!h*2gvM}+-!?=$D6OXrA!M|8F)M+0`uo+@?^4J`?| z^w?CawA=e`aGTZy{_M8v|2i0DXJ`_5{K1)#sN|uKuCfyTFO;eEX3m=!w)7-*o_;L( z@*6D?v7Q_2UP~)aMvCh*I2c)Eugt9mt#Uy3+}_+=+dJGD3mOv&_^&iS|7uXs38lhe zcU1ky=82{PxeIpr?8usM&{KCQ7Up0+Isw7wWo7X%hkCga>kAw*w0BOz!zhk|puy?p zgs5Kn^6A-UgB!^B@lo{Bqr2Ol3mhEZ3TYk1zf~~1j*{b{o%%ZsKZq?^g?cL-GvXs> z@OQWR-Q1`sDC+a7pUJWkBJ}jqM%e)e?1+c}xp_6Ym$dH!HTk(M7Fd>({r;Mljn)+r zA@L2@#KjS0acOCU-adHKPG$w_$cb%yFaZdrfE;vy+t*PVxt)<4KT zctC~t&iwe$5KTdXL`Hj?#>9Wm(iG;eNdGxViib8`@xLiuz-o`WeuWetiD60BUtF^y zK}_@O>y#!sQl&f;JZ^=nT{xQUNI}rEv-U#`wI3LZPjE6h4<7pu~rS)IM~GkHryxk6r^ z3dz>jcJy?k!bg&|h|e}!DkATe<=#wK#fbVrzd_!8`t(EM(NCU*`uchVadC0k@cr8! z^~L<$@861cmw5%C{i3mWbDd95j>eK-4pb>eDU?ZF#pC8iLh;B6`W&PL>61{~>tzZG zdp)K*$)D97`hvxlh3JfpjS&R;aQxln?a+jTgo`rXrH^(}(#pK4cX7l0{f{1n73G@3 z@)Q-Fy+W|+nl*aU+o($^ywGlTOXS*lwsICZ=_}ZN3*pg>Hjgg3q&IIIlTgB6OG{s? zaHh)mbeeto=+Ni2GmrU}O|reI7;y$RI+&Q_TiNb>WY}8A6?&|4*m$Z;H!6gi#`(ch zi$GE_(YJ|KYKjOU!YU*2pisn2?kuOf_L7w&XP_t_Z9PUU<1T5UhVL{9EeX3(0uM&v zF9#XEqT{OlPg9dUz1vO9(M$REX-nMx3z<^C z3fMX43RypLztLL5sa^aPn;LLp|IH-AxzQmzw~~dPRxyY6Cn~lzgp_nGw`9B{ zrSr!(8(YHaZ6@-w!Q#K4T?nv`^Dw5Qpt;SxyWT8vg>-*ck(-A5a$PVnkKA9&q?!U6 zD3U?v`K7ZKj~kU;8IR@^PR^4M#>j2I9>igpq8pPtX6Mp_(lj!wp`}o6D-q*QNI-Xb zN&XP%(rGJdV{QF0+Lwxiaw5qhFg!fms$ejTk}Zv6NFXc)C`nd& z;2RZAI|m1vJuXa`$cW+~0mZO+3$PG(4-Y)#@#Dt@)sEA@W^*9*T3XoSTT`w-ln**S zY}Y9jwu{Bdp{Z`uR$DX`T=aDXupES8AAxa!69izoALplma;#+a*gw}Xh z8OeFH-}*v(x-alboy!k;25_Z0<5mJzwgV3TlcSxzy*(ha+F1&F)A2WN-o$v9OuV(PPXD0yxi?EEUH;Le%HzjU&y`x++Zz;A zOZ@l#?&(LY8M}^@-!nK3@0lNTWsF z4!)a1>vPx?#f&Std0q^o&j-W@9h72_p-V_eI6XZryFFk7t9h1Ay6JLy)XJYf0>b}- zpT7qs4t)ReWxM6yMY}xtcO*F)=I2p%b~AZ3$1j7VtMc+-s~sB z7h#G@OiTop24R?I-s@Q8Eb(OKMeWXJjf$Jvg~rQ3Ue-$Wx3;!Q9**@bZ6WA^fq~7<&0b)H=2g=2@}n*zELL^pplPm! zp0DO4Cn5+}c^MfQ8F3oeOBY}T1=!iqRL@D~E-*5p93342$l$qMPovsnjv^!$J0W0E zEqmokD-#x#fltvz7xO}c7^xNcg252PX!H*cN9KLU;qD-4MfMj_QH{B5=g&V?E2WKS z{E&J4F_IXch?Hq~Q(KJM)Pr57nrM`8thPg7G9 zD7}Y=nEa)rwyWd>hzMikw^kJum2o_;JCRX)HX@8`=yK3EMWMpLy%twinh2`z^3vw$ zJIXCKHJnCBXsDm_>QtGk&x=NDAjMyS87hZGsbaPvqd|6c75-EQXL;@%~Umn{L zXR_z@KAoYG7gLml3r z+{C(J8_pPD@Ta(BIdaQlm_@Hml#!ew3_G{6=P#eEMNdM=MNOJc_FQSH5`Z?o^{m(T zOdLvt9IFtNWAGUd+12xeTxATMsBwfuP{s5wx%k-dgMM$DnLH3XcCqsx^?sQp{KAs5 z*(7pBRywuw_mxk*j{d57{Z2*3!`=oP_ve<|9ZZ;ym%cc;LM%(1 z)_rA{IMjJ*C&f&K7|b$@2ri6_$ZoWYA?T^*7#hKb3L`SCFrl?UEbhEHo~U#^zoM#| z@0pf)l04+X#R)og%%w{F|MeRFZ*Jnl;lGj>6chxW&=*8ZM1&v!nSBYdv9X{o@e>}? zw9E^samOzYGc z?**%?t3iY7^GWNuOJ%G15bN`K4Hdh1KYhI5xev%2+crWVTAnfhmyk#YrlINS>kI8FEG(oFY>rS=W+?e?(@Y_q3Q3zKPm6ZD0^{+g zrlwNLZBilcs;cBfMgK!dnG=@3sEEz(b;N)$XDTwz)y`sOV{7i|urI)&8sF=IDMcCBZ zjjzYYfe6}2AZFsHinykSYdN!m$WS$PuP#Fw|-EPzm4zz7sVXtskkY ztLy6O+Wre8qt_!B@2@s2MS>_E#o-%S=ayhK5E)Tv7qQU}+Hqyb!qOaSZG{KwNeo$x{Q|pjaa97_~vy|jy zXe{c5KhM|$hFMyUgJ+N=Z1FWa8};Bporr*}tSmHJXqNnjU$t)Cx?w2t(Z<);h&$e_ zLJgi1oSKM;HZWFTTYvm8X8LH+pxWEz-^FVA`TDAL(28iGH zXM{8oG-isN`oEf28JnA%o0!PR%d@hvrKhG=0gV_QHf4=bE3759UB6J3nK|<-M-TiD zFgs|;F7xv{O+jP7?g~ziYL~aL00x5*P5uJrLuF;<`}g?RZ_r!eGAqrGkDEIb<>g_6 zW2~yFIjLB!mI3DC;vyJaXH*k-sz}oP|K7^c*C-Uvdk4lrVc}+bvRIOk851+J=Iz@7 zv&jzLe+JG|Q7IOR&!N+z2Az*VvZuj&_!9Z3NW52u@0*%_>0b)(o2i=L+K=basotH8 z@Rv_l#kh=CmVu|_EJ2g&L@(Pv?_TD=I$FgU_d+96e!YQ4;cyK*KhKMMPqlNEDQYa} z1(z0)bP3iVT3S~@v786Hmho{obx1Sl#Ek2WOo?(Qy&q+6{= z=SSK4d56xoq-1218+)*9q>GJ7h<(A{!=MA^nC5tm%u_vqb7$uoo(D(d4J-9%5i+jUMau8~0A_w@Hf6{@j`#bX*2+1Iq#yXn3rgu0B#;Qu6id z*No@SKLR0=Br(0Vf)}OwIXl~}diT(-@?fRHqdZ`u5|`S3Yutqf+A%%-tG92p-t~vy z{|k;CkS!pPWu_~O#m?8iwc3^k9{G8DOCaoGVm-aLho04N`2C%}#j~2*J~ppyFwa_E zUjF|5d#D^I(PWbIitYcc4i*5PxOV+|MMiE8Gh>WGopt_jcRAhRO=5EF+xD7;A(&|5qQ-le;^{ z`ou|`$s*`z3tAD`bL*oVfDAD4y5@QoHnX#{!Pbh7jI4doq)o~Ggh-BpKiz6xbc3@Z zS~-m3PLBSLr<*sG<)&GMx1dG!@Lsh`+JLKN!Jt3z+pVSkAqq3^<=@u~E2ih>hU~E- z?Gp~203T~RgR&j-V#42-YDENugjNy_%^!Iw>pd#LT_rzDLL%wA_HM}7v-GBmjw(3! z$hdIOUWBO-7VIpaFtN=+5hr#^b!Xr1%rivR>K@3@;Jf}Trz(rE=o!PR6f5xLH` zZ)busCg5R1GLlWy2C;JRYt*b~Bo7|uMK%T^@0m1K@dsw#P z*o1`X(9l2ZwexHNo9APiVdqZsFidWL9s`OGNEehb5bN=};M&Ie8bV1XMn?0Cp&ymdxL!vuXgo0ek)Gi%6dsbJzFWP97wOZ#7GEFr z#ahXY-v|=|cAp~Q^2T@w(9+eXbuu%_-2G!?j>7GdmakKd3>FFMTyQSbd+zr0*Cuu# zfZ5~JVJ@yHCxbAMXaK-6oSe^8F`#a9&8zk!gsZ>FyUcySafAS~gmaj?ISHzmtI6#l zAt5EBeoN3Fw12#QIp{0|TtHjf{`5dVOiHTk+c&pGn|5Ftc~#rSKqj{0wF>ysAIF(B z#9dNT=lXBt41dXu0l5hRVv6pCP3Q{LmyrqWz{7Plrl{@XgH@W#Xc3GJBUmdBb$JuO zGo-50DGW(|{d#vin6kz8FGzZlgd1xS3~Di~cKJrh$;oMl_m>T9S_;P)JZI7-xv&V)*$j{Am0W$1%mck>PwY-(x*uz7IBdrtD&h`@clc2 z@Ed#qw}ws51^f6F?vV)j!Az3H8p9~G846a}7xH~G`J3C@uq@5H&0fF`+>Q?)zo(OG zqKR_NEH3tj&jKc@kvTgvlbDe3F0a~`1lkR_{=3Z`CXS)V_BYO!^Q#~r2;k3iNf;BN**2? znVLy!EmGipKq~R@IKY_$I2^~v$10yw#3Fvq8)$L&fGr?wQSHC*GxN%VKH-HHcfNj8@fbt3oy7Yd!2Ot6g`Vy7Q+R)O{0t$#3DDL7S*b6W!H#fHm=N-6) zfYtT$+iw@v5#)Rojax=JIeo5D3kWy@27|BzRfaLIUOgWp#dP7qf?VBFf(DplJgnxM zaFP@i6$M%wskIdaMHA;26UOTI0+lIb)yg#T3Q`BGpz%1&y2~&a6g8;!sdeW|YH)-N za!E7uu6(*q;UcjL1_x>KW5#_5jRSpSoJ)@=X7wZqn$WYc)%fqZ%es52s1QPF8W**# zlVNo1{QWC?&P%6Kbk$ntKMM|qLuM~N>Tm!_IGy%tI!f{rA!lY~HOSE~?nz5ad-@a) z$o$xta8g^8>ZP>g=Bb<79Gsl>GQs+OIk+rk5RbHE!{TrT3+-rEKSMWLpRZuhIpunrfz0WGKh3(!2}UIvn>!~QHGJ{$uBPWsD-VUwL`p-sH+UxL%#Qw0_Us6iB5 zhZ0}(l+HDX82T-t5L`zUu5#nX4KO?S5-0VbVu7~P(oV}^L>&}W(+S}A-!cE>R_Qf0 zH8pSsjB}ghK>2$~j{uP}?{=0jkujDTa4z0*J)5Wj$MLePlw&4f3d&=r)+Jdesx1KT z?o(cImKeINS-pGXRM=~t2oOF+K;8@E{g1qVc0yoOdhv{PmQ4@L3AuGsTji^g<+J|> DeZzG2 diff --git a/plugins/mrcc_selected/EZFIO.cfg b/plugins/mrcc_selected/EZFIO.cfg deleted file mode 100644 index b64637e6..00000000 --- a/plugins/mrcc_selected/EZFIO.cfg +++ /dev/null @@ -1,33 +0,0 @@ -[lambda_type] -type: Positive_int -doc: lambda type -interface: ezfio,provider,ocaml -default: 0 - -[energy] -type: double precision -doc: Calculated energy -interface: ezfio - -[energy_pt2] -type: double precision -doc: Calculated energy with PT2 contribution -interface: ezfio - -[energy] -type: double precision -doc: Calculated energy -interface: ezfio - -[thresh_dressed_ci] -type: Threshold -doc: Threshold on the convergence of the dressed CI energy -interface: ezfio,provider,ocaml -default: 1.e-5 - -[n_it_max_dressed_ci] -type: Strictly_positive_int -doc: Maximum number of dressed CI iterations -interface: ezfio,provider,ocaml -default: 10 - diff --git a/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES b/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES deleted file mode 100644 index ea28c761..00000000 --- a/plugins/mrcc_selected/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Perturbation Selectors_full Generators_full Psiref_threshold MRCC_Utils ZMQ diff --git a/plugins/mrcc_selected/README.rst b/plugins/mrcc_selected/README.rst deleted file mode 100644 index 997d005e..00000000 --- a/plugins/mrcc_selected/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -======= -mrcepa0 -======= - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/mrcc_selected/dressing.irp.f b/plugins/mrcc_selected/dressing.irp.f deleted file mode 100644 index 23fedcee..00000000 --- a/plugins/mrcc_selected/dressing.irp.f +++ /dev/null @@ -1,1022 +0,0 @@ -use bitmasks - - - - BEGIN_PROVIDER [ double precision, delta_ij_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_mrcc, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_mrcc, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc - integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) - integer(bit_kind),allocatable :: buf(:,:,:) - logical :: ok - logical, external :: detEq - - delta_ij_mrcc = 0d0 - delta_ii_mrcc = 0d0 - delta_ij_s2_mrcc = 0d0 - delta_ii_s2_mrcc = 0d0 - PROVIDE dij - provide hh_shortcut psi_det_size! lambda_mrcc - !$OMP PARALLEL DO default(none) schedule(dynamic) & - !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & - !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & - !$OMP private(h, n, mask, omask, buf, ok, iproc) - do gen= 1, N_det_generators - allocate(buf(N_int, 2, N_det_non_ref)) - iproc = omp_get_thread_num() + 1 - if(mod(gen, 1000) == 0) print *, "mrcc ", gen, "/", N_det_generators - do h=1, hh_shortcut(0) - call apply_hole_local(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) - if(.not. ok) cycle - omask = 0_bit_kind - if(hh_exists(1, h) /= 0) omask = mask - n = 1 - do p=hh_shortcut(h), hh_shortcut(h+1)-1 - call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) - if(ok) n = n + 1 - if(n > N_det_non_ref) stop "MRCC..." - end do - n = n - 1 - - if(n /= 0) then - call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc, delta_ij_s2_mrcc, delta_ii_s2_mrcc, gen,n,buf,N_int,omask) - endif - - end do - deallocate(buf) - end do - !$OMP END PARALLEL DO -END_PROVIDER - - -! subroutine blit(b1, b2) -! double precision :: b1(N_states,N_det_non_ref,N_det_ref), b2(N_states,N_det_non_ref,N_det_ref) -! b1 = b1 + b2 -! end subroutine - - -subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_generator,n_selected,det_buffer,Nint,key_mask) - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - double precision, intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision, intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision, intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,l,m - integer,allocatable :: idx_alpha(:), degree_alpha(:) - logical :: good, fullMatch - - integer(bit_kind),allocatable :: tq(:,:,:) - integer :: N_tq, c_ref ,degree - - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) - double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) - double precision :: haj, phase, phase2 - double precision :: f(N_states), ci_inv(N_states) - integer :: exc(0:2,2,2) - integer :: h1,h2,p1,p2,s1,s2 - integer(bit_kind) :: tmp_det(Nint,2) - integer :: iint, ipos - integer :: i_state, k_sd, l_sd, i_I, i_alpha - - integer(bit_kind),allocatable :: miniList(:,:,:) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - integer,allocatable :: idx_miniList(:) - integer :: N_miniList, ni, leng - double precision, allocatable :: hij_cache(:), sij_cache(:) - - integer(bit_kind), allocatable :: microlist(:,:,:), microlist_zero(:,:,:) - integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) - integer :: mobiles(2), smallerlist - logical, external :: detEq, is_generable - !double precision, external :: get_dij, get_dij_index - - - leng = max(N_det_generators, N_det_non_ref) - allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) - allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) - !create_minilist_find_previous(key_mask, fullList, miniList, N_fullList, N_miniList, fullMatch, Nint) - call create_minilist_find_previous(key_mask, psi_det_generators, miniList, i_generator-1, N_miniList, fullMatch, Nint) - -! if(fullMatch) then -! return -! end if - - allocate(ptr_microlist(0:mo_tot_num*2+1), & - N_microlist(0:mo_tot_num*2) ) - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - - if(key_mask(1,1) /= 0) then - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - call filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - else - call filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_minilist) - end if - - - - deallocate(microlist, idx_microlist) - - allocate (dIa_hla(N_states,N_det_non_ref), dIa_sla(N_states,N_det_non_ref)) - - ! |I> - - ! |alpha> - - if(N_tq > 0) then - call create_minilist(key_mask, psi_non_ref, miniList, idx_minilist, N_det_non_ref, N_minilist, Nint) - if(N_minilist == 0) return - - - if(key_mask(1,1) /= 0) then !!!!!!!!!!! PAS GENERAL !!!!!!!!! - allocate(microlist_zero(Nint,2,N_minilist), idx_microlist_zero(N_minilist)) - - allocate( microlist(Nint,2,N_minilist*4), & - idx_microlist(N_minilist*4)) - call create_microlist(miniList, N_minilist, key_mask, microlist, idx_microlist, N_microlist, ptr_microlist, Nint) - - - do i=0,mo_tot_num*2 - do k=ptr_microlist(i),ptr_microlist(i+1)-1 - idx_microlist(k) = idx_minilist(idx_microlist(k)) - end do - end do - - do l=1,N_microlist(0) - do k=1,Nint - microlist_zero(k,1,l) = microlist(k,1,l) - microlist_zero(k,2,l) = microlist(k,2,l) - enddo - idx_microlist_zero(l) = idx_microlist(l) - enddo - end if - end if - - - do i_alpha=1,N_tq - if(key_mask(1,1) /= 0) then - call getMobiles(tq(1,1,i_alpha), key_mask, mobiles, Nint) - - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - - do l=0,N_microlist(smallerlist)-1 - microlist_zero(:,:,ptr_microlist(1) + l) = microlist(:,:,ptr_microlist(smallerlist) + l) - idx_microlist_zero(ptr_microlist(1) + l) = idx_microlist(ptr_microlist(smallerlist) + l) - end do - - call get_excitation_degree_vector(microlist_zero,tq(1,1,i_alpha),degree_alpha,Nint,N_microlist(smallerlist)+N_microlist(0),idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) - end do - - else - call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) - do j=1,idx_alpha(0) - idx_alpha(j) = idx_miniList(idx_alpha(j)) - end do - end if - - - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) - call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) - enddo - ! |I> - do i_I=1,N_det_ref - ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then - cycle - endif - - do i_state=1,N_states - dIa(i_state) = 0.d0 - enddo - - ! |alpha> - do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 - logical :: loop -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo -! if (loop) then -! cycle -! endif - - call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) - if (degree > 2) then - cycle - endif - - ! - ! - !hIk = hij_mrcc(idx_alpha(k_sd),i_I) - ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - - do i_state=1,N_states - dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) - !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) - enddo - - - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do k=1,N_int - tmp_det(k,1) = psi_ref(k,1,i_I) - tmp_det(k,2) = psi_ref(k,2,i_I) - enddo - logical :: ok - call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if(.not. ok) cycle - - ! - do i_state=1,N_states - dka(i_state) = 0.d0 - enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo - loop = .false. - if (.not.loop) then - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - hIl = hij_mrcc(idx_alpha(l_sd),i_I) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) - do i_state=1,N_states - dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 - !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 - enddo - endif - - exit - endif - enddo - do i_state=1,N_states - dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) - enddo - enddo - - do i_state=1,N_states - ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) - enddo - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - hla = hij_cache(k_sd) - sla = sij_cache(k_sd) -! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) - do i_state=1,N_states - dIa_hla(i_state,k_sd) = dIa(i_state) * hla - dIa_sla(i_state,k_sd) = dIa(i_state) * sla - enddo - enddo - call omp_set_lock( psi_ref_lock(i_I) ) - do i_state=1,N_states - if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) - delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) - delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) - enddo - else - delta_ii_(i_state,i_I) = 0.d0 - do l_sd=1,idx_alpha(0) - k_sd = idx_alpha(l_sd) - delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) - delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) - enddo - endif - enddo - call omp_unset_lock( psi_ref_lock(i_I) ) - enddo - enddo - deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) - deallocate(miniList, idx_miniList) -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii, (N_states, N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2, (N_states, N_det_ref) ] - use bitmasks - implicit none - integer :: i, j, i_state - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - - if(mrmode == 3) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_mrcc(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_mrcc(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_mrcc(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_mrcc(i_state,j,i) - enddo - end do - end do - - ! =-=-= BEGIN STATE AVERAGE -! do i = 1, N_det_ref -! delta_ii(:,i)= delta_ii_mrcc(1,i) -! delta_ii_s2(:,i)= delta_ii_s2_mrcc(1,i) -! do i_state = 2, N_states -! delta_ii(:,i) += delta_ii_mrcc(i_state,i) -! delta_ii_s2(:,i) += delta_ii_s2_mrcc(i_state,i) -! enddo -! do j = 1, N_det_non_ref -! delta_ij(:,j,i) = delta_ij_mrcc(1,j,i) -! delta_ij_s2(:,j,i) = delta_ij_s2_mrcc(1,j,i) -! do i_state = 2, N_states -! delta_ij(:,j,i) += delta_ij_mrcc(i_state,j,i) -! delta_ij_s2(:,j,i) += delta_ij_s2_mrcc(i_state,j,i) -! enddo -! end do -! end do -! delta_ij = delta_ij * (1.d0/dble(N_states)) -! delta_ii = delta_ii * (1.d0/dble(N_states)) - ! =-=-= END STATE AVERAGE - ! - ! do i = 1, N_det_ref - ! delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_sub_ii(i,i_state) - ! do j = 1, N_det_non_ref - ! delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_sub_ij(i,j,i_state) - ! end do - ! end do - else if(mrmode == 2) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_ii_old(i_state,i) - delta_ii_s2(i_state,i)= delta_ii_s2_old(i_state,i) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_ij_old(i_state,j,i) - delta_ij_s2(i_state,j,i) = delta_ij_s2_old(i_state,j,i) - enddo - end do - end do - else if(mrmode == 1) then - do i = 1, N_det_ref - do i_state = 1, N_states - delta_ii(i_state,i)= delta_mrcepa0_ii(i,i_state) - delta_ii_s2(i_state,i)= delta_mrcepa0_ii_s2(i,i_state) - enddo - do j = 1, N_det_non_ref - do i_state = 1, N_states - delta_ij(i_state,j,i) = delta_mrcepa0_ij(i,j,i_state) - delta_ij_s2(i_state,j,i) = delta_mrcepa0_ij_s2(i,j,i_state) - enddo - end do - end do - else - stop "invalid mrmode" - end if -END_PROVIDER - - -BEGIN_PROVIDER [ integer, HP, (2,N_det_non_ref) ] - integer :: i - do i=1,N_det_non_ref - call getHP(psi_non_ref(1,1,i), HP(1,i), HP(2,i), N_int) - end do -END_PROVIDER - - BEGIN_PROVIDER [ integer, cepa0_shortcut, (0:N_det_non_ref+1) ] -&BEGIN_PROVIDER [ integer, det_cepa0_idx, (N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0_active, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_ref_active, (N_int,2,N_det_ref) ] -&BEGIN_PROVIDER [ integer(bit_kind), active_sorb, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), det_cepa0, (N_int,2,N_det_non_ref) ] -&BEGIN_PROVIDER [ integer, nlink, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, linked, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ integer, blokMwen, (N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, searchance, (N_det_ref) ] -&BEGIN_PROVIDER [ integer, child_num, (N_det_non_ref,N_det_ref) ] - - use bitmasks - implicit none - - integer(bit_kind),allocatable :: det_noactive(:,:,:) - integer, allocatable :: shortcut(:), idx(:) - integer(bit_kind) :: nonactive_sorb(N_int,2), det(N_int, 2) - integer i, II, j, k, n, ni, blok, degree - logical, external :: detEq - - allocate(det_noactive(N_int, 2, N_det_non_ref)) - allocate(idx(N_det_non_ref), shortcut(0:N_det_non_ref+1)) - print *, "pre start" - active_sorb(:,:) = 0_8 - nonactive_sorb(:,:) = not(0_8) - - if(N_det_ref > 1) then - do i=1, N_det_ref - do k=1, N_int - active_sorb(k,1) = ior(psi_ref(k,1,i), active_sorb(k,1)) - active_sorb(k,2) = ior(psi_ref(k,2,i), active_sorb(k,2)) - nonactive_sorb(k,1) = iand(psi_ref(k,1,i), nonactive_sorb(k,1)) - nonactive_sorb(k,2) = iand(psi_ref(k,2,i), nonactive_sorb(k,2)) - end do - end do - do k=1, N_int - active_sorb(k,1) = iand(active_sorb(k,1), not(nonactive_sorb(k,1))) - active_sorb(k,2) = iand(active_sorb(k,2), not(nonactive_sorb(k,2))) - end do - end if - - - do i=1, N_det_non_ref - do k=1, N_int - det_noactive(k,1,i) = iand(psi_non_ref(k,1,i), not(active_sorb(k,1))) - det_noactive(k,2,i) = iand(psi_non_ref(k,2,i), not(active_sorb(k,2))) - end do - end do - - call sort_dets_ab(det_noactive, det_cepa0_idx, cepa0_shortcut, N_det_non_ref, N_int) - - do i=1,N_det_non_ref - det_cepa0(:,:,i) = psi_non_ref(:,:,det_cepa0_idx(i)) - end do - - cepa0_shortcut(0) = 1 - cepa0_shortcut(1) = 1 - do i=2,N_det_non_ref - if(.not. detEq(det_noactive(1,1,i), det_noactive(1,1,i-1), N_int)) then - cepa0_shortcut(0) += 1 - cepa0_shortcut(cepa0_shortcut(0)) = i - end if - end do - cepa0_shortcut(cepa0_shortcut(0)+1) = N_det_non_ref+1 - - if(.true.) then - do i=1,cepa0_shortcut(0) - n = cepa0_shortcut(i+1) - cepa0_shortcut(i) - call sort_dets_ab(det_cepa0(1,1,cepa0_shortcut(i)), idx, shortcut, n, N_int) - do k=1,n - idx(k) = det_cepa0_idx(cepa0_shortcut(i)-1+idx(k)) - end do - det_cepa0_idx(cepa0_shortcut(i):cepa0_shortcut(i)+n-1) = idx(:n) - end do - end if - - - do i=1,N_det_ref - do k=1, N_int - det_ref_active(k,1,i) = iand(psi_ref(k,1,i), active_sorb(k,1)) - det_ref_active(k,2,i) = iand(psi_ref(k,2,i), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - do k=1, N_int - det_cepa0_active(k,1,i) = iand(psi_non_ref(k,1,det_cepa0_idx(i)), active_sorb(k,1)) - det_cepa0_active(k,2,i) = iand(psi_non_ref(k,2,det_cepa0_idx(i)), active_sorb(k,2)) - end do - end do - - do i=1,N_det_non_ref - if(.not. detEq(psi_non_ref(1,1,det_cepa0_idx(i)), det_cepa0(1,1,i),N_int)) stop "STOOOP" - end do - - searchance = 0d0 - child_num = 0 - do J = 1, N_det_ref - nlink(J) = 0 - do blok=1,cepa0_shortcut(0) - do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) - if(degree <= 2) then - nlink(J) += 1 - linked(nlink(J),J) = k - child_num(k, J) = nlink(J) - blokMwen(nlink(J),J) = blok - searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) - end if - end do - end do - end do - print *, "pre done" -END_PROVIDER - - - - BEGIN_PROVIDER [ double precision, delta_ref, (N_det_ref, N_det_ref, N_states) ] -&BEGIN_PROVIDER [ double precision, delta_ref_s2, (N_det_ref, N_det_ref, N_states) ] - use bitmasks - implicit none - integer :: i,j,k - double precision :: Sjk,Hjk, Hki, Hij - !double precision, external :: get_dij - integer i_state, degree - - provide lambda_mrcc dIj - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Sjk,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_ref,delta_ref_s2,N_det_ref,dij) - do i=1,N_det_ref - do j=1,i - call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) - delta_ref(i,j,i_state) = 0d0 - delta_ref_s2(i,j,i_state) = 0d0 - do k=1,N_det_non_ref - - call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) - call get_s2(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Sjk) - - delta_ref(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k) - delta_ref_s2(i,j,i_state) += Sjk * dij(i, k, i_state) ! * Ski * lambda_mrcc(i_state, k) - end do - delta_ref(j,i,i_state) = delta_ref(i,j,i_state) - delta_ref_s2(j,i,i_state) = delta_ref_s2(i,j,i_state) - end do - end do - !$OMP END PARALLEL DO - end do - END_PROVIDER - - - - -logical function isInCassd(a,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - isInCassd = .false. - - deg = 0 - do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) return - end do - end do - - deg = 0 - do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) return - end do - end do - isInCassd = .true. -end function - - -subroutine getHP(a,h,p,Nint) - use bitmasks - implicit none - integer, intent(in) :: Nint - integer(bit_kind), intent(in) :: a(Nint,2) - integer, intent(out) :: h, p - integer(bit_kind) :: inac, virt - integer :: ni, i, deg - - - !isInCassd = .false. - h = 0 - p = 0 - - deg = 0 - lp : do i=1,2 - do ni=1,Nint - virt = iand(not(HF_bitmask(ni,i)), not(active_sorb(ni,i))) - deg += popcnt(iand(virt, a(ni,i))) - if(deg > 2) exit lp - end do - end do lp - p = deg - - deg = 0 - lh : do i=1,2 - do ni=1,Nint - inac = iand(HF_bitmask(ni,i), not(active_sorb(ni,i))) - deg += popcnt(xor(iand(inac,a(ni,i)), inac)) - if(deg > 2) exit lh - end do - end do lh - h = deg - !isInCassd = .true. -end function - - - BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii, (N_det_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij_s2, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_mrcepa0_ii_s2, (N_det_ref,N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, m, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_, sortRefIdx(N_det_ref) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_IJ, phase_al, diI, hIi, hJi, delta_JI, dkI(1), HkI, ci_inv(1), dia_hla(1) - double precision :: contrib, contrib2, contrib_s2, contrib2_s2, HIIi, HJk, wall - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), made_hole(N_int,2), made_particle(N_int,2), myActive(N_int,2) - integer(bit_kind),allocatable :: sortRef(:,:,:) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit, searchDet - logical, external :: is_in_wavefunction, detEq - !double precision, external :: get_dij - integer :: II, blok - integer*8, save :: notf = 0 - - call wall_time(wall) - allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) - - sortRef(:,:,:) = det_ref_active(:,:,:) - call sort_det(sortRef, sortRefIdx, N_det_ref, N_int) - - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - ! To provide everything - contrib = dij(1, 1, 1) - - delta_mrcepa0_ii(:,:) = 0d0 - delta_mrcepa0_ij(:,:,:) = 0d0 - delta_mrcepa0_ii_s2(:,:) = 0d0 - delta_mrcepa0_ij_s2(:,:,:) = 0d0 - - do i_state = 1, N_states - !$OMP PARALLEL DO default(none) schedule(dynamic) shared(delta_mrcepa0_ij, delta_mrcepa0_ii, delta_mrcepa0_ij_s2, delta_mrcepa0_ii_s2) & - !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib,contrib2,contrib_s2,contrib2_s2) & - !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & - !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_ref, delta_ref_s2) & - !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) - do blok=1,cepa0_shortcut(0) - do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 - do II=1,N_det_ref - call get_excitation_degree(psi_ref(1,1,II),psi_non_ref(1,1,det_cepa0_idx(i)),degree,N_int) - if (degree > 2 ) cycle - - do ni=1,N_int - made_hole(ni,1) = iand(det_ref_active(ni,1,II), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_hole(ni,2) = iand(det_ref_active(ni,2,II), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - - made_particle(ni,1) = iand(det_cepa0_active(ni,1,i), xor(det_cepa0_active(ni,1,i), det_ref_active(ni,1,II))) - made_particle(ni,2) = iand(det_cepa0_active(ni,2,i), xor(det_cepa0_active(ni,2,i), det_ref_active(ni,2,II))) - end do - - - kloop: do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 !i - !if(lambda_mrcc(i_state, det_cepa0_idx(k)) == 0d0) cycle - - do ni=1,N_int - if(iand(made_hole(ni,1), det_cepa0_active(ni,1,k)) /= 0) cycle kloop - if(iand(made_particle(ni,1), det_cepa0_active(ni,1,k)) /= made_particle(ni,1)) cycle kloop - if(iand(made_hole(ni,2), det_cepa0_active(ni,2,k)) /= 0) cycle kloop - if(iand(made_particle(ni,2), det_cepa0_active(ni,2,k)) /= made_particle(ni,2)) cycle kloop - end do - do ni=1,N_int - myActive(ni,1) = xor(det_cepa0_active(ni,1,k), made_hole(ni,1)) - myActive(ni,1) = xor(myActive(ni,1), made_particle(ni,1)) - myActive(ni,2) = xor(det_cepa0_active(ni,2,k), made_hole(ni,2)) - myActive(ni,2) = xor(myActive(ni,2), made_particle(ni,2)) - end do - - j = searchDet(sortRef, myActive, N_det_ref, N_int) - if(j == -1) then - cycle - end if - j = sortRefIdx(j) - !$OMP ATOMIC - notf = notf+1 - -! call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) - contrib = delta_ref(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - contrib_s2 = delta_ref_s2(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state) - - if(dabs(psi_ref_coef(J,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - contrib2_s2 = contrib_s2 / psi_ref_coef(J, i_state) * psi_non_ref_coef(det_cepa0_idx(i),i_state) - !$OMP ATOMIC - delta_mrcepa0_ii(J,i_state) -= contrib2 - delta_mrcepa0_ii_s2(J,i_state) -= contrib2_s2 - else - contrib = contrib * 0.5d0 - contrib_s2 = contrib_s2 * 0.5d0 - end if - !$OMP ATOMIC - delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib - delta_mrcepa0_ij_s2(J, det_cepa0_idx(i), i_state) += contrib_s2 - - end do kloop - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) - call wall_time(wall) - print *, "cepa0", wall, notf - -END_PROVIDER - - - BEGIN_PROVIDER [ double precision, delta_sub_ij, (N_det_ref,N_det_non_ref,N_states) ] -&BEGIN_PROVIDER [ double precision, delta_sub_ii, (N_det_ref, N_states) ] - use bitmasks - implicit none - - integer :: i_state, i, i_I, J, k, degree, degree2, l, deg, ni - integer :: p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_ - logical :: ok - double precision :: phase_Ji, phase_Ik, phase_Ii - double precision :: contrib, contrib2, delta_IJk, HJk, HIk, HIl - integer, dimension(0:2,2,2) :: exc_Ik, exc_Ji, exc_Ii - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2) - integer, allocatable :: idx_sorted_bit(:) - integer, external :: get_index_in_psi_det_sorted_bit - - integer :: II, blok - - provide delta_ref lambda_mrcc - allocate(idx_sorted_bit(N_det)) - idx_sorted_bit(:) = -1 - do i=1,N_det_non_ref - idx_sorted_bit(get_index_in_psi_det_sorted_bit(psi_non_ref(1,1,i), N_int)) = i - enddo - - do i_state = 1, N_states - delta_sub_ij(:,:,:) = 0d0 - delta_sub_ii(:,:) = 0d0 - - provide mo_bielec_integrals_in_map - - - !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & - !$OMP private(i, J, k, degree, degree2, l, deg, ni) & - !$OMP private(p1,p2,h1,h2,s1,s2, p1_,p2_,h1_,h2_,s1_,s2_) & - !$OMP private(ok, phase_Ji, phase_Ik, phase_Ii, contrib2, contrib, delta_IJk, HJk, HIk, HIl, exc_Ik, exc_Ji, exc_Ii) & - !$OMP private(det_tmp, det_tmp2, II, blok) & - !$OMP shared(idx_sorted_bit, N_det_non_ref, N_det_ref, N_int, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef) & - !$OMP shared(i_state,lambda_mrcc, hf_bitmask, active_sorb) - do i=1,N_det_non_ref - if(mod(i,1000) == 0) print *, i, "/", N_det_non_ref - do J=1,N_det_ref - call get_excitation(psi_ref(1,1,J),psi_non_ref(1,1,i),exc_Ji,degree,phase_Ji,N_int) - if(degree == -1) cycle - - - do II=1,N_det_ref - call apply_excitation(psi_ref(1,1,II),exc_Ji,det_tmp,ok,N_int) - - if(.not. ok) cycle - l = get_index_in_psi_det_sorted_bit(det_tmp, N_int) - if(l == 0) cycle - l = idx_sorted_bit(l) - - call i_h_j(psi_ref(1,1,II), det_tmp, N_int, HIl) - - do k=1,N_det_non_ref - if(lambda_mrcc(i_state, k) == 0d0) cycle - call get_excitation(psi_ref(1,1,II),psi_non_ref(1,1,k),exc_Ik,degree2,phase_Ik,N_int) - - det_tmp(:,:) = 0_bit_kind - det_tmp2(:,:) = 0_bit_kind - - ok = .true. - do ni=1,N_int - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,k)), not(active_sorb(ni,1))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,1), psi_non_ref(ni,1,i)), not(active_sorb(ni,1))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - - det_tmp(ni,1) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,k)), not(active_sorb(ni,2))) - det_tmp(ni,2) = iand(xor(HF_bitmask(ni,2), psi_non_ref(ni,2,i)), not(active_sorb(ni,2))) - ok = ok .and. (popcnt(det_tmp(ni,1)) + popcnt(det_tmp(ni,2)) == popcnt(xor(det_tmp(ni,1), det_tmp(ni,2)))) - end do - - if(ok) cycle - - - call i_h_j(psi_ref(1,1,J), psi_non_ref(1,1,k), N_int, HJk) - call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,k), N_int, HIk) - if(HJk == 0) cycle - !assert HIk == 0 - delta_IJk = HJk * HIk * lambda_mrcc(i_state, k) - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(ok) cycle - contrib = delta_IJk * HIl * lambda_mrcc(i_state,l) - if(dabs(psi_ref_coef(II,i_state)).ge.1.d-3) then - contrib2 = contrib / psi_ref_coef(II, i_state) * psi_non_ref_coef(l,i_state) - !$OMP ATOMIC - delta_sub_ii(II,i_state) -= contrib2 - else - contrib = contrib * 0.5d0 - endif - !$OMP ATOMIC - delta_sub_ij(II, i, i_state) += contrib - end do - end do - end do - end do - !$OMP END PARALLEL DO - end do - deallocate(idx_sorted_bit) -END_PROVIDER - - -subroutine set_det_bit(det, p, s) - implicit none - integer(bit_kind),intent(inout) :: det(N_int, 2) - integer, intent(in) :: p, s - integer :: ni, pos - - ni = (p-1)/bit_kind_size + 1 - pos = mod(p-1, bit_kind_size) - det(ni,s) = ibset(det(ni,s), pos) -end subroutine - - - BEGIN_PROVIDER [ double precision, h_cache, (N_det_ref,N_det_non_ref) ] -&BEGIN_PROVIDER [ double precision, s2_cache, (N_det_ref,N_det_non_ref) ] - implicit none - integer :: i,j - do i=1,N_det_ref - do j=1,N_det_non_ref - call i_h_j(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, h_cache(i,j)) - call get_s2(psi_ref(1,1,i), psi_non_ref(1,1,j), N_int, s2_cache(i,j)) - end do - end do -END_PROVIDER - - - -subroutine filter_tq(i_generator,n_selected,det_buffer,Nint,tq,N_tq,miniList,N_miniList) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: miniList(Nint,2,N_det_generators) - integer,intent(in) :: N_miniList - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - do k=1, N_minilist - if(is_generable(miniList(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retournĂ© par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - -subroutine filter_tq_micro(i_generator,n_selected,det_buffer,Nint,tq,N_tq,microlist,ptr_microlist,N_microlist,key_mask) - - use bitmasks - implicit none - - integer, intent(in) :: i_generator,n_selected, Nint - - integer(bit_kind), intent(in) :: det_buffer(Nint,2,n_selected) - integer :: i,j,k,m - logical :: is_in_wavefunction - integer,allocatable :: degree(:) - integer,allocatable :: idx(:) - logical :: good - - integer(bit_kind), intent(inout) :: tq(Nint,2,n_selected) !! intent(out) - integer, intent(out) :: N_tq - - integer :: nt,ni - logical, external :: is_connected_to, is_generable - - integer(bit_kind),intent(in) :: microlist(Nint,2,*) - integer,intent(in) :: ptr_microlist(0:*) - integer,intent(in) :: N_microlist(0:*) - integer(bit_kind),intent(in) :: key_mask(Nint, 2) - - integer :: mobiles(2), smallerlist - - - allocate(degree(psi_det_size)) - allocate(idx(0:psi_det_size)) - N_tq = 0 - - i_loop : do i=1,N_selected - call getMobiles(det_buffer(1,1,i), key_mask, mobiles, Nint) - if(N_microlist(mobiles(1)) < N_microlist(mobiles(2))) then - smallerlist = mobiles(1) - else - smallerlist = mobiles(2) - end if - - if(N_microlist(smallerlist) > 0) then - do k=ptr_microlist(smallerlist), ptr_microlist(smallerlist)+N_microlist(smallerlist)-1 - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - if(N_microlist(0) > 0) then - do k=1, N_microlist(0) - if(is_generable(microlist(1,1,k), det_buffer(1,1,i), Nint)) cycle i_loop - end do - end if - - ! Select determinants that are triple or quadruple excitations - ! from the ref - good = .True. - call get_excitation_degree_vector(psi_ref,det_buffer(1,1,i),degree,Nint,N_det_ref,idx) - !good=(idx(0) == 0) tant que degree > 2 pas retournĂ© par get_excitation_degree_vector - do k=1,idx(0) - if (degree(k) < 3) then - good = .False. - exit - endif - enddo - if (good) then - if (.not. is_in_wavefunction(det_buffer(1,1,i),Nint)) then - N_tq += 1 - do k=1,N_int - tq(k,1,N_tq) = det_buffer(k,1,i) - tq(k,2,N_tq) = det_buffer(k,2,i) - enddo - endif - endif - enddo i_loop -end - - - - diff --git a/plugins/mrcc_selected/dressing_slave.irp.f b/plugins/mrcc_selected/dressing_slave.irp.f deleted file mode 100644 index 8d488f36..00000000 --- a/plugins/mrcc_selected/dressing_slave.irp.f +++ /dev/null @@ -1,601 +0,0 @@ -subroutine mrsc2_dressing_slave_tcp(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(0,i) -end - - -subroutine mrsc2_dressing_slave_inproc(i) - implicit none - integer, intent(in) :: i - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - call mrsc2_dressing_slave(1,i) -end - -subroutine mrsc2_dressing_slave(thread,iproc) - use f77_zmq - - implicit none - BEGIN_DOC -! Task for parallel MR-SC2 - END_DOC - integer, intent(in) :: thread, iproc -! integer :: j,l - integer :: rc - - integer :: worker_id, task_id - character*(512) :: task - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_push_socket - integer(ZMQ_PTR) :: zmq_socket_push - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - - - integer :: i_state, i, i_I, J, k, k2, k1, kk, ll, degree, degree2, m, l, deg, ni, m2 - integer :: n(2) - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, kn - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al - double precision :: diI, hIi, hJi, delta_JI, dkI, HkI, ci_inv(N_states), cj_inv(N_states) - double precision :: contrib, contrib_s2, wall, iwall - double precision, allocatable :: dleat(:,:,:), dleat_s2(:,:,:) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - integer,allocatable :: komon(:) - logical :: komoned - !double precision, external :: get_dij - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_push = new_zmq_push_socket(thread) - - call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) - - allocate (dleat(N_states, N_det_non_ref, 2), delta(N_states,0:N_det_non_ref, 2)) - allocate (dleat_s2(N_states, N_det_non_ref, 2), delta_s2(N_states,0:N_det_non_ref, 2)) - allocate(komon(0:N_det_non_ref)) - - do - call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) - if (task_id == 0) exit - read (task,*) i_I, J, k1, k2 - do i_state=1, N_states - ci_inv(i_state) = 1.d0 / psi_ref_coef(i_I,i_state) - cj_inv(i_state) = 1.d0 / psi_ref_coef(J,i_state) - end do - n = 0 - delta(:,0,:) = 0d0 - delta(:,:nlink(J),1) = 0d0 - delta(:,:nlink(i_I),2) = 0d0 - delta_s2(:,0,:) = 0d0 - delta_s2(:,:nlink(J),1) = 0d0 - delta_s2(:,:nlink(i_I),2) = 0d0 - komon(0) = 0 - komoned = .false. - - - - - do kk = k1, k2 - k = det_cepa0_idx(linked(kk, i_I)) - blok = blokMwen(kk, i_I) - - call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,k),exc_Ik,degree,phase_Ik,N_int) - - if(J /= i_I) then - call apply_excitation(psi_ref(1,1,J),exc_Ik,det_tmp2,ok,N_int) - if(.not. ok) cycle - - l = searchDet(det_cepa0(1,1,cepa0_shortcut(blok)), det_tmp2, cepa0_shortcut(blok+1)-cepa0_shortcut(blok), N_int) - if(l == -1) cycle - ll = cepa0_shortcut(blok)-1+l - l = det_cepa0_idx(ll) - ll = child_num(ll, J) - else - l = k - ll = kk - end if - - - if(.not. komoned) then - m = 0 - m2 = 0 - - do while(m < nlink(i_I) .and. m2 < nlink(J)) - m += 1 - m2 += 1 - if(linked(m, i_I) < linked(m2, J)) then - m2 -= 1 - cycle - else if(linked(m, i_I) > linked(m2, J)) then - m -= 1 - cycle - end if - i = det_cepa0_idx(linked(m, i_I)) - - if(h_cache(J,i) == 0.d0) cycle - if(h_cache(i_I,i) == 0.d0) cycle - - komon(0) += 1 - kn = komon(0) - komon(kn) = i - - do i_state = 1,N_states - dkI = h_cache(J,i) * dij(i_I, i, i_state) - dleat(i_state, kn, 1) = dkI - dleat(i_state, kn, 2) = dkI - - dkI = s2_cache(J,i) * dij(i_I, i, i_state) - dleat_s2(i_state, kn, 1) = dkI - dleat_s2(i_state, kn, 2) = dkI - end do - - end do - - komoned = .true. - end if - - integer :: hpmin(2) - hpmin(1) = 2 - HP(1,k) - hpmin(2) = 2 - HP(2,k) - - do m = 1, komon(0) - - i = komon(m) - if(HP(1,i) <= hpmin(1) .and. HP(2,i) <= hpmin(2) ) then - cycle - end if - - call apply_excitation(psi_non_ref(1,1,i),exc_Ik,det_tmp,ok,N_int) - if(.not. ok) cycle - - do i_state = 1, N_states - contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2) - contrib_s2 = dij(i_I, k, i_state) * dleat_s2(i_state, m, 2) - delta(i_state,ll,1) += contrib - delta_s2(i_state,ll,1) += contrib_s2 - if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then - delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - delta_s2(i_state,0,1) -= contrib_s2 * ci_inv(i_state) * psi_non_ref_coef(l,i_state) - endif - - if(I_i == J) cycle - contrib = dij(J, l, i_state) * dleat(i_state, m, 1) - contrib_s2 = dij(J, l, i_state) * dleat_s2(i_state, m, 1) - delta(i_state,kk,2) += contrib - delta_s2(i_state,kk,2) += contrib_s2 - if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then - delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - delta_s2(i_state,0,2) -= contrib_s2 * cj_inv(i_state) * psi_non_ref_coef(k,i_state) - end if - enddo !i_state - end do ! while - end do ! kk - - - call push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) - -! end if - - enddo - - deallocate(delta) - - call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_push_socket(zmq_socket_push,thread) - -end - - -subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer, intent(in) :: i_I, J - integer(ZMQ_PTR), intent(in) :: zmq_socket_push - double precision,intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision,intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(in) :: task_id - integer :: rc , i_state, i, kk, li - integer,allocatable :: idx(:,:) - integer :: n(2) - logical :: ok - - allocate(idx(N_det_non_ref,2)) - rc = f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - - do kk=1,2 - n(kk)=0 - if(kk == 1) li = nlink(j) - if(kk == 2) li = nlink(i_I) - do i=1, li - ok = .false. - do i_state=1,N_states - if(delta(i_state, i, kk) /= 0d0) then - ok = .true. - exit - end if - end do - - if(ok) then - n(kk) += 1 -! idx(n,kk) = i - if(kk == 1) then - idx(n(1),1) = det_cepa0_idx(linked(i, J)) - else - idx(n(2),2) = det_cepa0_idx(linked(i, i_I)) - end if - - do i_state=1, N_states - delta(i_state, n(kk), kk) = delta(i_state, i, kk) - end do - end if - end do - - rc = f77_zmq_send( zmq_socket_push, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_send( zmq_socket_push, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta(1,0,1) = delta_I delta(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) ! delta_s2(1,0,1) = delta_I delta_s2(1,0,2) = delta_J - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_send( zmq_socket_push, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, delta, 8*n(kk), ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - - rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' - stop 'error' - endif - -! ! Activate is zmq_socket_push is a REQ - integer :: idummy - rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' - stop 'error' - endif -end - - - -subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - use f77_zmq - implicit none - BEGIN_DOC -! Push integrals in the push socket - END_DOC - - integer(ZMQ_PTR), intent(in) :: zmq_socket_pull - integer, intent(out) :: i_I, J, n(2) - double precision, intent(inout) :: delta(N_states, 0:N_det_non_ref, 2) - double precision, intent(inout) :: delta_s2(N_states, 0:N_det_non_ref, 2) - integer, intent(out) :: task_id - integer :: rc , i, kk - integer,intent(inout) :: idx(N_det_non_ref,2) - logical :: ok - - rc = f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_I, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, J, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - do kk = 1, 2 - rc = f77_zmq_recv( zmq_socket_pull, n(kk), 4, ZMQ_SNDMORE) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n, 4, ZMQ_SNDMORE)' - stop 'error' - endif - - if(n(kk) /= 0) then - rc = f77_zmq_recv( zmq_socket_pull, delta(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, delta_s2(1,0,kk), (n(kk)+1)*8*N_states, ZMQ_SNDMORE) - if (rc /= (n(kk)+1)*8*N_states) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, delta_s2, (n(kk)+1)*8*N_states, ZMQ_SNDMORE)' - stop 'error' - endif - - rc = f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE) - if (rc /= n(kk)*4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, idx(1,kk), n(kk)*4, ZMQ_SNDMORE)' - stop 'error' - endif - end if - end do - - rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' - stop 'error' - endif - - -! ! Activate is zmq_socket_pull is a REP - integer :: idummy - rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) - if (rc /= 4) then - print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' - stop 'error' - endif -end - - - -subroutine mrsc2_dressing_collector(delta_ii_,delta_ij_,delta_ii_s2_,delta_ij_s2_) - use f77_zmq - implicit none - BEGIN_DOC -! Collects results from the AO integral calculation - END_DOC - - double precision,intent(inout) :: delta_ij_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_(N_states,N_det_ref) - double precision,intent(inout) :: delta_ij_s2_(N_states,N_det_non_ref,N_det_ref) - double precision,intent(inout) :: delta_ii_s2_(N_states,N_det_ref) - -! integer :: j,l - integer :: rc - - double precision, allocatable :: delta(:,:,:), delta_s2(:,:,:) - - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer*8 :: control, accu - integer :: task_id, more - - integer :: I_i, J, l, i_state, n(2), kk - integer,allocatable :: idx(:,:) - - delta_ii_(:,:) = 0d0 - delta_ij_(:,:,:) = 0d0 - delta_ii_s2_(:,:) = 0d0 - delta_ij_s2_(:,:,:) = 0d0 - - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - - allocate ( delta(N_states,0:N_det_non_ref,2), delta_s2(N_states,0:N_det_non_ref,2) ) - - allocate(idx(N_det_non_ref,2)) - more = 1 - do while (more == 1) - - call pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, task_id) - - - do l=1, n(1) - do i_state=1,N_states - delta_ij_(i_state,idx(l,1),i_I) += delta(i_state,l,1) - delta_ij_s2_(i_state,idx(l,1),i_I) += delta_s2(i_state,l,1) - end do - end do - - do l=1, n(2) - do i_state=1,N_states - delta_ij_(i_state,idx(l,2),J) += delta(i_state,l,2) - delta_ij_s2_(i_state,idx(l,2),J) += delta_s2(i_state,l,2) - end do - end do - - - if(n(1) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,i_I) += delta(i_state,0,1) - delta_ii_s2_(i_state,i_I) += delta_s2(i_state,0,1) - end do - end if - - if(n(2) /= 0) then - do i_state=1,N_states - delta_ii_(i_state,J) += delta(i_state,0,2) - delta_ii_s2_(i_state,J) += delta_s2(i_state,0,2) - end do - end if - - - if (task_id /= 0) then - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) - endif - - - enddo - deallocate( delta, delta_s2 ) - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - -end - - - - - BEGIN_PROVIDER [ double precision, delta_ij_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_old, (N_states,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ij_s2_old, (N_states,N_det_non_ref,N_det_ref) ] -&BEGIN_PROVIDER [ double precision, delta_ii_s2_old, (N_states,N_det_ref) ] - implicit none - - integer :: i_state, i, i_I, J, k, kk, degree, degree2, m, l, deg, ni, m2 - integer :: p1,p2,h1,h2,s1,s2, blok, I_s, J_s, nex, nzer, ntot -! integer, allocatable :: linked(:,:), blokMwen(:, :), nlink(:) - logical :: ok - double precision :: phase_iI, phase_Ik, phase_Jl, phase_Ji, phase_al, diI, hIi, hJi, delta_JI, dkI(N_states), HkI, ci_inv(N_states), dia_hla(N_states) - double precision :: contrib, wall, iwall ! , searchance(N_det_ref) - integer, dimension(0:2,2,2) :: exc_iI, exc_Ik, exc_IJ - integer(bit_kind) :: det_tmp(N_int, 2), det_tmp2(N_int, 2), inac, virt - integer, external :: get_index_in_psi_det_sorted_bit, searchDet, detCmp - logical, external :: is_in_wavefunction, isInCassd, detEq - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer :: KKsize = 1000000 - - - call new_parallel_job(zmq_to_qp_run_socket,'mrsc2') - - - call wall_time(iwall) -! allocate(linked(N_det_non_ref, N_det_ref), blokMwen(N_det_non_ref, N_det_ref), nlink(N_det_ref)) - - -! searchance = 0d0 -! do J = 1, N_det_ref -! nlink(J) = 0 -! do blok=1,cepa0_shortcut(0) -! do k=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 -! call get_excitation_degree(psi_ref(1,1,J),det_cepa0(1,1,k),degree,N_int) -! if(degree <= 2) then -! nlink(J) += 1 -! linked(nlink(J),J) = k -! blokMwen(nlink(J),J) = blok -! searchance(J) += 1d0 + log(dfloat(cepa0_shortcut(blok+1) - cepa0_shortcut(blok))) -! end if -! end do -! end do -! end do - - - -! stop - nzer = 0 - ntot = 0 - do nex = 3, 0, -1 - print *, "los ",nex - do I_s = N_det_ref, 1, -1 -! if(mod(I_s,1) == 0) then -! call wall_time(wall) -! wall = wall-iwall -! print *, I_s, "/", N_det_ref, wall * (dfloat(N_det_ref) / dfloat(I_s)), wall, wall * (dfloat(N_det_ref) / dfloat(I_s))-wall -! end if - - - do J_s = 1, I_s - - call get_excitation_degree(psi_ref(1,1,J_s), psi_ref(1,1,I_s), degree, N_int) - if(degree /= nex) cycle - if(nex == 3) nzer = nzer + 1 - ntot += 1 -! if(degree > 3) then -! deg += 1 -! cycle -! else if(degree == -10) then -! KKsize = 100000 -! else -! KKsize = 1000000 -! end if - - - - if(searchance(I_s) < searchance(J_s)) then - i_I = I_s - J = J_s - else - i_I = J_s - J = I_s - end if - - KKsize = nlink(1) - if(nex == 0) KKsize = int(float(nlink(1)) / float(nlink(i_I)) * (float(nlink(1)) / 64d0)) - - !if(KKsize == 0) stop "ZZEO" - - do kk = 1 , nlink(i_I), KKsize - write(task,*) I_i, J, kk, int(min(kk+KKsize-1, nlink(i_I))) - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - ! do kk = 1 , nlink(i_I) - ! k = linked(kk,i_I) - ! blok = blokMwen(kk,i_I) - ! write(task,*) I_i, J, k, blok - ! call add_task_to_taskserver(zmq_to_qp_run_socket,task) - ! - ! enddo !kk - enddo !J - - enddo !I - end do ! nex - print *, "tasked" -! integer(ZMQ_PTR) ∷ collector_thread -! external ∷ ao_bielec_integrals_in_map_collector -! rc = pthread_create(collector_thread, mrsc2_dressing_collector) - print *, nzer, ntot, float(nzer) / float(ntot) - provide nproc - !$OMP PARALLEL DEFAULT(none) SHARED(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call mrsc2_dressing_collector(delta_ii_old,delta_ij_old,delta_ii_s2_old,delta_ij_s2_old) - else - call mrsc2_dressing_slave_inproc(i) - endif - !$OMP END PARALLEL - -! rc = pthread_join(collector_thread) - call end_parallel_job(zmq_to_qp_run_socket, 'mrsc2') - - -END_PROVIDER - - - diff --git a/plugins/mrcc_selected/ezfio_interface.irp.f b/plugins/mrcc_selected/ezfio_interface.irp.f deleted file mode 100644 index 54d993fe..00000000 --- a/plugins/mrcc_selected/ezfio_interface.irp.f +++ /dev/null @@ -1,61 +0,0 @@ -! DO NOT MODIFY BY HAND -! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py -! from file /panfs/panasas/cnt0024/cpq1738/scemama/workdir/quantum_package/src/mrcc_selected/EZFIO.cfg - - -BEGIN_PROVIDER [ double precision, thresh_dressed_ci ] - implicit none - BEGIN_DOC -! Threshold on the convergence of the dressed CI energy - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_thresh_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_thresh_dressed_ci(thresh_dressed_ci) - else - print *, 'mrcc_selected/thresh_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, n_it_max_dressed_ci ] - implicit none - BEGIN_DOC -! Maximum number of dressed CI iterations - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_n_it_max_dressed_ci(has) - if (has) then - call ezfio_get_mrcc_selected_n_it_max_dressed_ci(n_it_max_dressed_ci) - else - print *, 'mrcc_selected/n_it_max_dressed_ci not found in EZFIO file' - stop 1 - endif - -END_PROVIDER - -BEGIN_PROVIDER [ integer, lambda_type ] - implicit none - BEGIN_DOC -! lambda type - END_DOC - - logical :: has - PROVIDE ezfio_filename - - call ezfio_has_mrcc_selected_lambda_type(has) - if (has) then - call ezfio_get_mrcc_selected_lambda_type(lambda_type) - else - print *, 'mrcc_selected/lambda_type not found in EZFIO file' - stop 1 - endif - -END_PROVIDER diff --git a/plugins/mrcc_selected/mrcc_selected.irp.f b/plugins/mrcc_selected/mrcc_selected.irp.f deleted file mode 100644 index b64f968d..00000000 --- a/plugins/mrcc_selected/mrcc_selected.irp.f +++ /dev/null @@ -1,18 +0,0 @@ -program mrsc2sub - implicit none - double precision, allocatable :: energy(:) - allocate (energy(N_states)) - - !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc - mrmode = 3 - - read_wf = .True. - SOFT_TOUCH read_wf - call set_generators_bitmasks_as_holes_and_particles - call run(N_states,energy) - if(do_pt2_end)then - call run_pt2(N_states,energy) - endif - deallocate(energy) -end - diff --git a/plugins/mrcc_selected/mrcepa0_general.irp.f b/plugins/mrcc_selected/mrcepa0_general.irp.f deleted file mode 100644 index 812aeef0..00000000 --- a/plugins/mrcc_selected/mrcepa0_general.irp.f +++ /dev/null @@ -1,246 +0,0 @@ - - -subroutine run(N_st,energy) - implicit none - - integer, intent(in) :: N_st - double precision, intent(out) :: energy(N_st) - - integer :: i,j - - double precision :: E_new, E_old, delta_e - integer :: iteration - double precision :: E_past(4) - - integer :: n_it_mrcc_max - double precision :: thresh_mrcc - double precision, allocatable :: lambda(:) - allocate (lambda(N_states)) - - - thresh_mrcc = thresh_dressed_ci - n_it_mrcc_max = n_it_max_dressed_ci - - if(n_it_mrcc_max == 1) then - do j=1,N_states_diag - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_dressed(i,j) - enddo - enddo - SOFT_TOUCH psi_coef ci_energy_dressed - call write_double(6,ci_energy_dressed(1),"Final MRCC energy") - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - call save_wavefunction - energy(:) = ci_energy_dressed(:) - else - E_new = 0.d0 - delta_E = 1.d0 - iteration = 0 - lambda = 1.d0 - do while (delta_E > thresh_mrcc) - iteration += 1 - print *, '===========================' - print *, 'MRCEPA0 Iteration', iteration - print *, '===========================' - print *, '' - E_old = sum(ci_energy_dressed) - call write_double(6,ci_energy_dressed(1),"MRCEPA0 energy") - call diagonalize_ci_dressed(lambda) - E_new = sum(ci_energy_dressed) - delta_E = dabs(E_new - E_old) - call save_wavefunction - call ezfio_set_mrcepa0_energy(ci_energy_dressed(1)) - if (iteration >= n_it_mrcc_max) then - exit - endif - enddo - call write_double(6,ci_energy_dressed(1),"Final MRCEPA0 energy") - energy(:) = ci_energy_dressed(:) - endif -end - - -subroutine print_ref_coefs - implicit none - - integer :: i,j - print *, 'Reference' - print *, '=========' - do i=1,N_det_ref - print *, (psi_ref_coef(i,j), j=1,N_states) - call debug_det(psi_ref(1,1,i),N_int) - enddo - print *, '' - call write_double(6,ci_energy(1),"Initial CI energy") - -end - - - - -subroutine run_pt2_old(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2_redundant(N_st), pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2_redundant = 0.d0 - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - print * ,'Computing the redundant PT2 contribution' - - if (mrmode == 1) then - - N_det_generators = lambda_mrcc_kept(0) - N_det_selectors = lambda_mrcc_kept(0) - - do i=1,N_det_generators - j = lambda_mrcc_kept(i) - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - else - - N_det_generators = N_det_non_ref - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - j = i - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - endif - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2_redundant, norm_pert, H_pert_diag, N_st) - - print * ,'Computing the remaining contribution' - - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - - N_det_generators = N_det_non_ref + N_det_ref - N_det_selectors = N_det_non_ref + N_det_ref - - psi_det_generators(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_selectors(:,:,:N_det_ref) = psi_ref(:,:,:N_det_ref) - psi_coef_generators(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - psi_selectors_coef(:N_det_ref,:) = psi_ref_coef(:N_det_ref,:) - - do i=N_det_ref+1,N_det_generators - j = i-N_det_ref - do k=1,N_int - psi_det_generators(k,1,i) = psi_non_ref(k,1,j) - psi_det_generators(k,2,i) = psi_non_ref(k,2,j) - psi_selectors(k,1,i) = psi_non_ref(k,1,j) - psi_selectors(k,2,i) = psi_non_ref(k,2,j) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_non_ref_coef(j,k) - psi_selectors_coef(i,k) = psi_non_ref_coef(j,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - - - print *, "Redundant PT2 :",pt2_redundant - print *, "Full PT2 :",pt2 - print *, lambda_mrcc_kept(0), N_det, N_det_ref, psi_coef(1,1), psi_ref_coef(1,1) - pt2 = pt2 - pt2_redundant - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - -subroutine run_pt2(N_st,energy) - implicit none - integer :: i,j,k - integer, intent(in) :: N_st - double precision, intent(in) :: energy(N_st) - double precision :: pt2(N_st) - double precision :: norm_pert(N_st),H_pert_diag(N_st) - - pt2 = 0d0 - !if(lambda_mrcc_pt2(0) == 0) return - - print*,'Last iteration only to compute the PT2' - - N_det_generators = N_det_ref - N_det_selectors = N_det_non_ref - - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_ref(k,1,i) - psi_det_generators(k,2,i) = psi_ref(k,2,i) - enddo - do k=1,N_st - psi_coef_generators(i,k) = psi_ref_coef(i,k) - enddo - enddo - do i=1,N_det - do k=1,N_int - psi_selectors(k,1,i) = psi_det_sorted(k,1,i) - psi_selectors(k,2,i) = psi_det_sorted(k,2,i) - enddo - do k=1,N_st - psi_selectors_coef(i,k) = psi_coef_sorted(i,k) - enddo - enddo - - SOFT_TOUCH N_det_selectors psi_selectors_coef psi_selectors N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed - SOFT_TOUCH psi_ref_coef_diagonalized psi_ref_energy_diagonalized - - call H_apply_mrcepa_PT2(pt2, norm_pert, H_pert_diag, N_st) - -! call ezfio_set_full_ci_energy_pt2(energy+pt2) - - print *, 'Final step' - print *, 'N_det = ', N_det - print *, 'N_states = ', N_states - print *, 'PT2 = ', pt2 - print *, 'E = ', energy - print *, 'E+PT2 = ', energy+pt2 - print *, '-----' - - call ezfio_set_mrcepa0_energy_pt2(energy(1)+pt2(1)) - -end - diff --git a/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES b/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES deleted file mode 100644 index f04fe3b0..00000000 --- a/plugins/mrsc2_no_amp/NEEDED_CHILDREN_MODULES +++ /dev/null @@ -1 +0,0 @@ -Psiref_CAS Determinants Davidson diff --git a/plugins/mrsc2_no_amp/README.rst b/plugins/mrsc2_no_amp/README.rst deleted file mode 100644 index b24848f7..00000000 --- a/plugins/mrsc2_no_amp/README.rst +++ /dev/null @@ -1,12 +0,0 @@ -============ -mrsc2_no_amp -============ - -Needed Modules -============== -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. -Documentation -============= -.. Do not edit this section It was auto-generated -.. by the `update_README.py` script. diff --git a/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f b/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f deleted file mode 100644 index e4555d8c..00000000 --- a/plugins/mrsc2_no_amp/mrsc2_no_amp.irp.f +++ /dev/null @@ -1,129 +0,0 @@ - BEGIN_PROVIDER [double precision, CI_eigenvectors_sc2_no_amp, (N_det,N_states_diag)] -&BEGIN_PROVIDER [double precision, CI_eigenvectors_s2_sc2_no_amp, (N_states_diag)] -&BEGIN_PROVIDER [double precision, CI_electronic_energy_sc2_no_amp, (N_states_diag)] - implicit none - integer :: i,j,k,l - integer, allocatable :: idx(:) - integer, allocatable :: holes_part(:,:) - double precision, allocatable :: e_corr(:,:) - double precision, allocatable :: accu(:) - double precision, allocatable :: ihpsi_current(:) - double precision, allocatable :: H_jj(:),H_jj_total(:),S2_jj(:) - integer :: number_of_particles, number_of_holes, n_h,n_p - allocate(e_corr(N_det_non_ref,N_states),ihpsi_current(N_states),accu(N_states),H_jj(N_det_non_ref),idx(0:N_det_non_ref)) - allocate(H_jj_total(N_det),S2_jj(N_det)) - allocate(holes_part(N_det,2)) - accu = 0.d0 - do i = 1, N_det_non_ref - holes_part(i,1) = number_of_holes(psi_non_ref(1,1,i)) - holes_part(i,2) = number_of_particles(psi_non_ref(1,1,i)) - call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& - size(psi_ref_coef_interm_norm,1), N_states,ihpsi_current) - do j = 1, N_states - e_corr(i,j) = psi_non_ref_coef(i,j) * ihpsi_current(j) * inv_norm_psi_ref(j) - accu(j) += e_corr(i,j) - enddo - enddo - print *, 'accu = ',accu - double precision :: hjj,diag_h_mat_elem - do i = 1, N_det_non_ref - H_jj(i) = 0.d0 - n_h = holes_part(i,1) - n_p = holes_part(i,2) - integer :: degree -! do j = 1, N_det_non_ref -! call get_excitation_degree(psi_non_ref(1,1,i),psi_non_ref(1,1,j),degree,N_int) -! if(degree .gt. 2)then -! if(n_h + holes_part(j,1) .gt. 2 .or. n_p + holes_part(j,2) .gt. 2 ) then -! H_jj(i) += e_corr(j,1) -! endif -! endif -! enddo - call filter_not_connected(psi_non_ref,psi_non_ref(1,1,i),N_int,N_det_non_ref,idx) - do j = 1, idx(0) - if(n_h + holes_part(idx(j),1) .gt. 2 .or. n_p + holes_part(idx(j),2) .gt. 2 ) then - H_jj(i) += e_corr(idx(j),1) - endif - enddo - enddo - - do i=1,N_Det - H_jj_total(i) = diag_h_mat_elem(psi_det(1,1,i),N_int) - call get_s2(psi_det(1,1,i),psi_det(1,1,i),N_int,S2_jj(i)) - enddo - do i = 1, N_det_non_ref - H_jj_total(idx_non_ref(i)) += H_jj(i) - enddo - - - print *, 'coef' - call davidson_diag_hjj_sjj(psi_det,CI_eigenvectors_sc2_no_amp,H_jj_total,S2_jj,CI_electronic_energy_sc2_no_amp,size(CI_eigenvectors_sc2_no_amp,1),N_Det,N_states,N_states_diag,N_int,6) - do i = 1, N_det - hjj = diag_h_mat_elem(psi_det(1,1,i),N_int) - ! if(hjj<-210.d0)then - ! call debug_det(psi_det(1,1,i),N_int) - ! print *, CI_eigenvectors_sc2_no_amp((i),1),hjj, H_jj_total(i) - ! endif - enddo - - - - - - print *, 'ref',N_det_ref - do i =1, N_det_ref - call debug_det(psi_det(1,1,idx_ref(i)),N_int) - print *, CI_eigenvectors_sc2_no_amp(idx_ref(i),1), H_jj_total(idx_ref(i)) - enddo - print *, 'non ref',N_det_non_ref - do i=1, N_det_non_ref - hjj = diag_h_mat_elem(psi_non_ref(1,1,i),N_int) -! print *, CI_eigenvectors_sc2_no_amp(idx_non_ref(i),1),H_jj_total(idx_non_ref(i)), H_jj(i) -! if(dabs(CI_eigenvectors_sc2_no_amp(idx_non_ref(i),1)).gt.1.d-1)then -! if(hjj<-210.d0)then -! call debug_det(psi_det(1,1,idx_non_ref(i)),N_int) -! write(*,'(10(F16.10,X))') CI_eigenvectors_sc2_no_amp(idx_non_ref(i),1),hjj, H_jj(i),H_jj_total(idx_non_ref(i)) -! endif - enddo -! do i = 1, N_det -! print *, CI_eigenvectors_sc2_no_amp(i,1) -! enddo - do i=1,N_states_diag - CI_eigenvectors_s2_sc2_no_amp(i) = S2_jj(i) - enddo - - deallocate(e_corr,ihpsi_current,accu,H_jj,idx,H_jj_total,s2_jj,holes_part) -END_PROVIDER - -BEGIN_PROVIDER [ double precision, CI_energy_sc2_no_amp, (N_states_diag) ] - implicit none - BEGIN_DOC - ! N_states lowest eigenvalues of the CI matrix - END_DOC - - integer :: j - character*(8) :: st - call write_time(output_determinants) - do j=1,min(N_det,N_states_diag) - CI_energy_sc2_no_amp(j) = CI_electronic_energy_sc2_no_amp(j) + nuclear_repulsion - enddo - do j=1,min(N_det,N_states) - write(st,'(I4)') j - call write_double(output_determinants,CI_energy_sc2_no_amp(j),'Energy of state '//trim(st)) - call write_double(output_determinants,CI_eigenvectors_s2_sc2_no_amp(j),'S^2 of state '//trim(st)) - enddo - -END_PROVIDER - -subroutine diagonalize_CI_sc2_no_amp - implicit none - integer :: i,j - do j=1,N_states - do i=1,N_det - psi_coef(i,j) = CI_eigenvectors_sc2_no_amp(i,j) - enddo - enddo - SOFT_TOUCH ci_eigenvectors_s2_sc2_no_amp ci_eigenvectors_sc2_no_amp ci_electronic_energy_sc2_no_amp ci_energy_sc2_no_amp psi_coef - -end - diff --git a/plugins/mrsc2_no_amp/sc2_no_amp.irp.f b/plugins/mrsc2_no_amp/sc2_no_amp.irp.f deleted file mode 100644 index f557783b..00000000 --- a/plugins/mrsc2_no_amp/sc2_no_amp.irp.f +++ /dev/null @@ -1,14 +0,0 @@ -program pouet - provide ao_bielec_integrals_in_map - call bla -end -subroutine bla - implicit none - integer :: i - do i = 1, 10 - call diagonalize_CI_sc2_no_amp - TOUCH psi_coef - enddo - print *, "E+PT2 = ", ci_energy_sc2_no_amp(:) - -end diff --git a/src/Integrals_Monoelec/check_orthonormality.irp.f b/src/Integrals_Monoelec/check_orthonormality.irp.f index 749e74f0..44294023 100644 --- a/src/Integrals_Monoelec/check_orthonormality.irp.f +++ b/src/Integrals_Monoelec/check_orthonormality.irp.f @@ -11,10 +11,10 @@ end subroutine do_print implicit none integer :: i,j - real :: off_diag, diag + double precision :: off_diag, diag - off_diag = 0. - diag = 0. + off_diag = 0.d0 + diag = 0.d0 do j=1,mo_tot_num do i=1,mo_tot_num off_diag += abs(mo_overlap(i,j)) From 98f3692f4c75f29ab1ee8fd09ef9e97416eefdc5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 20 Apr 2017 19:07:03 +0200 Subject: [PATCH 48/48] Merged scemama-master --- README.md | 10 +- config/gfortran_debug.cfg | 2 +- ocaml/Basis.ml | 14 +- ocaml/Basis.mli | 2 +- ocaml/Input_determinants_by_hand.ml | 86 +- ocaml/Makefile | 1 + ocaml/Message.ml | 175 +- ocaml/Message_lexer.mll | 265 ++ ocaml/Symmetry.ml | 2 +- ocaml/TaskServer.ml | 111 +- ocaml/qp_create_ezfio_from_xyz.ml | 51 +- ocaml/qptypes_generator.ml | 8 +- plugins/All_singles/.gitignore | 5 - plugins/CAS_SD/.gitignore | 34 - plugins/CAS_SD_ZMQ/EZFIO.cfg | 9 +- plugins/CAS_SD_ZMQ/cassd_zmq.irp.f | 121 - plugins/CAS_SD_ZMQ/run_selection_slave.irp.f | 14 +- plugins/CAS_SD_ZMQ/selection.irp.f | 3 +- .../CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f | 109 + plugins/CID/.gitignore | 28 - plugins/CID_SC2_selected/.gitignore | 31 - plugins/CID_selected/.gitignore | 30 - plugins/CIS/.gitignore | 28 - plugins/CISD/.gitignore | 29 - plugins/CISD_SC2_selected/.gitignore | 31 - plugins/CISD_selected/.gitignore | 31 - plugins/Casino/.gitignore | 23 - plugins/Casino/save_for_casino.irp.f | 2 +- plugins/DDCI_selected/.gitignore | 29 - plugins/DensityMatrix/.gitignore | 13 - plugins/FCIdump/.gitignore | 24 - plugins/Full_CI/.gitignore | 34 - plugins/Full_CI_ZMQ/.gitignore | 5 - plugins/Full_CI_ZMQ/energy.irp.f | 16 +- plugins/Full_CI_ZMQ/fci_zmq.irp.f | 137 +- plugins/Full_CI_ZMQ/pt2_slave.irp.f | 70 + plugins/Full_CI_ZMQ/pt2_stoch.irp.f | 38 + plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f | 4 +- plugins/Full_CI_ZMQ/run_pt2_slave.irp.f | 172 ++ plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 15 +- plugins/Full_CI_ZMQ/selection.irp.f | 2312 ++++++++--------- plugins/Full_CI_ZMQ/selection_slave.irp.f | 24 +- plugins/Full_CI_ZMQ/selection_types.f90 | 6 +- .../Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f | 109 + plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f | 95 + plugins/Generators_CAS/.gitignore | 23 - plugins/Generators_full/.gitignore | 25 - plugins/Generators_restart/.gitignore | 13 - plugins/Hartree_Fock/.gitignore | 25 - plugins/Hartree_Fock/localize_mos.irp.f | 75 + plugins/MP2/.gitignore | 31 - plugins/MRCC_Utils/.gitignore | 33 - plugins/MRCC_Utils/H_apply.irp.f | 2 +- plugins/MRCC_Utils/amplitudes.irp.f | 85 +- plugins/MRCC_Utils/davidson.irp.f | 71 +- plugins/MRCC_Utils/mrcc_utils.irp.f | 319 ++- plugins/MRPT_Utils/energies_cas.irp.f | 24 +- plugins/MRPT_Utils/excitations_cas.irp.f | 2 +- .../new_way_second_order_coef.irp.f | 4 +- plugins/Molden/.gitignore | 18 - plugins/Perturbation/.gitignore | 26 - plugins/Properties/.gitignore | 25 - plugins/Properties/delta_rho.irp.f | 2 +- plugins/Properties/hyperfine_constants.irp.f | 2 +- plugins/Properties/mulliken.irp.f | 4 +- plugins/Psiref_CAS/.gitignore | 26 - plugins/Psiref_CAS/psi_ref.irp.f | 34 + plugins/Psiref_Utils/.gitignore | 29 - plugins/Psiref_Utils/psi_ref_utils.irp.f | 3 +- plugins/QmcChem/.gitignore | 25 - plugins/Selectors_full/.gitignore | 25 - plugins/Selectors_no_sorted/.gitignore | 13 - plugins/SingleRefMethod/.gitignore | 19 - plugins/analyze_wf/NEEDED_CHILDREN_MODULES | 1 + plugins/analyze_wf/README.rst | 12 + plugins/analyze_wf/analyze_wf.irp.f | 70 + plugins/analyze_wf/occupation.irp.f | 23 + plugins/loc_cele/.gitignore | 18 - plugins/mrcepa0/.gitignore | 5 - plugins/mrcepa0/EZFIO.cfg | 6 + plugins/mrcepa0/dressing.irp.f | 113 +- plugins/mrcepa0/dressing_slave.irp.f | 28 +- plugins/mrcepa0/mrcc.irp.f | 2 +- promela/integrals.pml | 272 ++ scripts/ezfio_interface/qp_edit_template | 71 +- scripts/module/module_handler.py | 4 +- src/.gitignore | 28 - src/AO_Basis/.gitignore | 15 - src/AO_Basis/aos.irp.f | 5 +- src/Bitmask/.gitignore | 18 - src/Bitmask/bitmasks.irp.f | 14 +- src/Davidson/EZFIO.cfg | 6 + src/Davidson/davidson_parallel.irp.f | 1 - src/Davidson/davidson_slave.irp.f | 1 - src/Davidson/diagonalization.irp.f | 4 +- src/Davidson/find_reference.irp.f | 41 + src/Davidson/parameters.irp.f | 5 + src/Determinants/EZFIO.cfg | 2 +- src/Determinants/Fock_diag.irp.f | 9 + src/Determinants/H_apply.irp.f | 22 +- src/Determinants/H_apply_zmq.template.f | 2 +- src/Determinants/density_matrix.irp.f | 219 +- src/Determinants/determinants.irp.f | 4 +- src/Determinants/filter_connected.irp.f | 98 + src/Determinants/occ_pattern.irp.f | 44 +- src/Determinants/print_wf.irp.f | 46 +- src/Determinants/s2.irp.f | 9 +- src/Determinants/spindeterminants.irp.f | 4 +- ...ull_for_ovb.irp.f => useful_for_ovb.irp.f} | 9 +- src/Electrons/.gitignore | 13 - src/Ezfio_files/.gitignore | 13 - src/Integrals_Bielec/.gitignore | 22 - src/Integrals_Bielec/ao_bi_integrals.irp.f | 13 +- .../ao_bielec_integrals_in_map_slave.irp.f | 22 +- src/Integrals_Bielec/map_integrals.irp.f | 4 +- src/Integrals_Bielec/mo_bi_integrals.irp.f | 2 + src/Integrals_Monoelec/.gitignore | 20 - .../check_orthonormality.irp.f | 6 +- .../pot_ao_pseudo_ints.irp.f | 32 +- src/Integrals_Monoelec/pseudopot.f90 | 46 +- src/MOGuess/.gitignore | 20 - src/MO_Basis/.gitignore | 17 - src/MO_Basis/EZFIO.cfg | 8 +- src/MO_Basis/ao_ortho_canonical.irp.f | 2 +- src/MO_Basis/cholesky_mo.irp.f | 80 +- src/MO_Basis/mos.irp.f | 1 + src/MO_Basis/utils.irp.f | 6 +- src/Nuclei/.gitignore | 14 - src/Nuclei/nuclei.irp.f | 49 +- src/Pseudo/.gitignore | 15 - src/Pseudo/EZFIO.cfg | 12 - src/Utils/.gitignore | 12 - src/Utils/LinearAlgebra.irp.f | 10 +- src/Utils/constants.include.F | 1 + src/Utils/map_functions.irp.f | 23 +- src/Utils/map_module.f90 | 18 +- src/ZMQ/utils.irp.f | 1 - tests/bats/cassd.bats | 6 +- tests/bats/fci.bats | 6 +- tests/bats/mrcepa0.bats | 8 +- tests/input/h2o.xyz | 2 +- 141 files changed, 3833 insertions(+), 3243 deletions(-) create mode 100644 ocaml/Message_lexer.mll delete mode 100644 plugins/All_singles/.gitignore delete mode 100644 plugins/CAS_SD/.gitignore create mode 100644 plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f delete mode 100644 plugins/CID/.gitignore delete mode 100644 plugins/CID_SC2_selected/.gitignore delete mode 100644 plugins/CID_selected/.gitignore delete mode 100644 plugins/CIS/.gitignore delete mode 100644 plugins/CISD/.gitignore delete mode 100644 plugins/CISD_SC2_selected/.gitignore delete mode 100644 plugins/CISD_selected/.gitignore delete mode 100644 plugins/Casino/.gitignore delete mode 100644 plugins/DDCI_selected/.gitignore delete mode 100644 plugins/DensityMatrix/.gitignore delete mode 100644 plugins/FCIdump/.gitignore delete mode 100644 plugins/Full_CI/.gitignore delete mode 100644 plugins/Full_CI_ZMQ/.gitignore create mode 100644 plugins/Full_CI_ZMQ/pt2_slave.irp.f create mode 100644 plugins/Full_CI_ZMQ/pt2_stoch.irp.f create mode 100644 plugins/Full_CI_ZMQ/run_pt2_slave.irp.f create mode 100644 plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f create mode 100644 plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f delete mode 100644 plugins/Generators_CAS/.gitignore delete mode 100644 plugins/Generators_full/.gitignore delete mode 100644 plugins/Generators_restart/.gitignore delete mode 100644 plugins/Hartree_Fock/.gitignore create mode 100644 plugins/Hartree_Fock/localize_mos.irp.f delete mode 100644 plugins/MP2/.gitignore delete mode 100644 plugins/MRCC_Utils/.gitignore delete mode 100644 plugins/Molden/.gitignore delete mode 100644 plugins/Perturbation/.gitignore delete mode 100644 plugins/Properties/.gitignore delete mode 100644 plugins/Psiref_CAS/.gitignore delete mode 100644 plugins/Psiref_Utils/.gitignore delete mode 100644 plugins/QmcChem/.gitignore delete mode 100644 plugins/Selectors_full/.gitignore delete mode 100644 plugins/Selectors_no_sorted/.gitignore delete mode 100644 plugins/SingleRefMethod/.gitignore create mode 100644 plugins/analyze_wf/NEEDED_CHILDREN_MODULES create mode 100644 plugins/analyze_wf/README.rst create mode 100644 plugins/analyze_wf/analyze_wf.irp.f create mode 100644 plugins/analyze_wf/occupation.irp.f delete mode 100644 plugins/loc_cele/.gitignore delete mode 100644 plugins/mrcepa0/.gitignore create mode 100644 promela/integrals.pml delete mode 100644 src/.gitignore delete mode 100644 src/AO_Basis/.gitignore delete mode 100644 src/Bitmask/.gitignore create mode 100644 src/Davidson/find_reference.irp.f rename src/Determinants/{usefull_for_ovb.irp.f => useful_for_ovb.irp.f} (97%) delete mode 100644 src/Electrons/.gitignore delete mode 100644 src/Ezfio_files/.gitignore delete mode 100644 src/Integrals_Bielec/.gitignore delete mode 100644 src/Integrals_Monoelec/.gitignore delete mode 100644 src/MOGuess/.gitignore delete mode 100644 src/MO_Basis/.gitignore delete mode 100644 src/Nuclei/.gitignore delete mode 100644 src/Pseudo/.gitignore delete mode 100644 src/Utils/.gitignore diff --git a/README.md b/README.md index c9e1b12d..b15654aa 100644 --- a/README.md +++ b/README.md @@ -82,11 +82,11 @@ If you have set the `--developement` flag you can go in any module directory and ### 4) Compiling the OCaml - make -C ocaml + make -C $QP_ROOT/ocaml ### 5) Testing if all is ok - cd tests ; bats bats/qp.bats + cd tests ; ./run_tests.sh @@ -137,10 +137,6 @@ interface: ezfio #FAQ -### Opam error: cryptokit - -You need to install `gmp-dev`. - ### Error: ezfio_* is already defined. #### Why ? @@ -166,5 +162,5 @@ It's caused when we call the DGEMM routine of LAPACK. ##### Fix -Set `ulimit -s unlimited`, before runing `qp_run`. It seem to fix the problem. +Set `ulimit -s unlimited`, before runing `qp_run`. It seems to fix the problem. diff --git a/config/gfortran_debug.cfg b/config/gfortran_debug.cfg index 4b06c5e9..f0c6e320 100644 --- a/config/gfortran_debug.cfg +++ b/config/gfortran_debug.cfg @@ -51,7 +51,7 @@ FCFLAGS : -Ofast # -g : Extra debugging information # [DEBUG] -FCFLAGS : -g -msse4.2 +FCFLAGS : -g -msse4.2 -fcheck=all -Waliasing -Wampersand -Wconversion -Wsurprising -Wintrinsics-std -Wno-tabs -Wintrinsic-shadow -Wline-truncation -Wreal-q-constant # OpenMP flags ################# diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml index 869fb132..797d53f2 100644 --- a/ocaml/Basis.ml +++ b/ocaml/Basis.ml @@ -36,9 +36,11 @@ let read_element in_channel at_number element = -let to_string_general ~fmt ~atom_sep b = +let to_string_general ~fmt ~atom_sep ?ele_array b = let new_nucleus n = - Printf.sprintf "Atom %d" n + match ele_array with + | None -> Printf.sprintf "Atom %d" n + | Some x -> Printf.sprintf "%s" (Element.to_string x.(n-1)) in let rec do_work accu current_nucleus = function | [] -> List.rev accu @@ -56,12 +58,12 @@ let to_string_general ~fmt ~atom_sep b = do_work [new_nucleus 1] 1 b |> String.concat ~sep:"\n" -let to_string_gamess = - to_string_general ~fmt:Gto.Gamess ~atom_sep:"" +let to_string_gamess ?ele_array = + to_string_general ?ele_array ~fmt:Gto.Gamess ~atom_sep:"" -let to_string_gaussian b = +let to_string_gaussian ?ele_array b = String.concat ~sep:"\n" - [ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] + [ to_string_general ?ele_array ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ] let to_string ?(fmt=Gto.Gamess) = match fmt with diff --git a/ocaml/Basis.mli b/ocaml/Basis.mli index 249c14f9..41ddc184 100644 --- a/ocaml/Basis.mli +++ b/ocaml/Basis.mli @@ -14,7 +14,7 @@ val read_element : in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list (** Convert the basis to a string *) -val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string +val to_string : ?fmt:Gto.fmt -> ?ele_array:Element.t array -> (Gto.t * Nucl_number.t) list -> string (** Convert the basis to an MD5 hash *) val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t diff --git a/ocaml/Input_determinants_by_hand.ml b/ocaml/Input_determinants_by_hand.ml index 76080b02..6cc83745 100644 --- a/ocaml/Input_determinants_by_hand.ml +++ b/ocaml/Input_determinants_by_hand.ml @@ -7,6 +7,7 @@ module Determinants_by_hand : sig { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; + n_states : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -18,11 +19,14 @@ module Determinants_by_hand : sig val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option val read_n_int : unit -> N_int_number.t + val update_ndet : Det_number.t -> unit + val extract_state : States_number.t -> unit end = struct type t = { n_int : N_int_number.t; bit_kind : Bit_kind.t; n_det : Det_number.t; + n_states : States_number.t; expected_s2 : Positive_float.t; psi_coef : Det_coef.t array; psi_det : Determinant.t array; @@ -129,12 +133,12 @@ end = struct |> Array.map ~f:Det_coef.of_float ;; - let write_psi_coef ~n_det c = + let write_psi_coef ~n_det ~n_states c = let n_det = Det_number.to_int n_det and c = Array.to_list c |> List.map ~f:Det_coef.to_float and n_states = - read_n_states () |> States_number.to_int + States_number.to_int n_states in Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c |> Ezfio.set_determinants_psi_coef @@ -200,6 +204,7 @@ end = struct expected_s2 = read_expected_s2 () ; psi_coef = read_psi_coef () ; psi_det = read_psi_det () ; + n_states = read_n_states () ; } else failwith "No molecular orbitals, so no determinants" @@ -222,12 +227,14 @@ end = struct expected_s2 ; psi_coef ; psi_det ; + n_states ; } = write_n_int n_int ; write_bit_kind bit_kind; write_n_det n_det; + write_n_states n_states; write_expected_s2 expected_s2; - write_psi_coef ~n_det:n_det psi_coef ; + write_psi_coef ~n_det:n_det ~n_states:n_states psi_coef ; write_psi_det ~n_int:n_int ~n_det:n_det psi_det; ;; @@ -298,6 +305,7 @@ Determinants :: n_int = %s bit_kind = %s n_det = %s +n_states = %s expected_s2 = %s psi_coef = %s psi_det = %s @@ -305,6 +313,7 @@ psi_det = %s (b.n_int |> N_int_number.to_string) (b.bit_kind |> Bit_kind.to_string) (b.n_det |> Det_number.to_string) + (b.n_states |> States_number.to_string) (b.expected_s2 |> Positive_float.to_string) (b.psi_coef |> Array.to_list |> List.map ~f:Det_coef.to_string |> String.concat ~sep:", ") @@ -433,14 +442,83 @@ psi_det = %s |> Bit_kind.to_int) and n_int = Printf.sprintf "(n_int %d)" (N_int_number.get_max ()) + and n_states = + Printf.sprintf "(n_states %d)" (States_number.to_int @@ read_n_states ()) in let s = - String.concat [ header ; bitkind ; n_int ; psi_coef ; psi_det] + String.concat [ header ; bitkind ; n_int ; n_states ; psi_coef ; psi_det] in + + + Generic_input_of_rst.evaluate_sexp t_of_sexp s ;; + let update_ndet n_det_new = + Printf.printf "Reducing n_det to %d\n" (Det_number.to_int n_det_new); + let n_det_new = + Det_number.to_int n_det_new + in + let det = + read () + in + let n_det_old, n_states = + Det_number.to_int det.n_det, + States_number.to_int det.n_states + in + if n_det_new = n_det_old then + () + ; + if n_det_new > n_det_new then + failwith @@ Printf.sprintf "Requested n_det should be less than %d" n_det_old + ; + for j=0 to (n_states-1) do + let ishift_old, ishift_new = + j*n_det_old, + j*n_det_new + in + for i=0 to (n_det_new-1) do + det.psi_coef.(i+ishift_new) <- det.psi_coef.(i+ishift_old) + done + done + ; + let new_det = + { det with n_det = (Det_number.of_int n_det_new) } + in + write new_det + ;; + + let extract_state istate = + Printf.printf "Extracting state %d\n" (States_number.to_int istate); + let det = + read () + in + let n_det, n_states = + Det_number.to_int det.n_det, + States_number.to_int det.n_states + in + if (States_number.to_int istate) > n_states then + failwith "State to extract should not be greater than n_states" + ; + let j = + (States_number.to_int istate) - 1 + in + begin + if (j>0) then + let ishift = + j*n_det + in + for i=0 to (n_det-1) do + det.psi_coef.(i) <- det.psi_coef.(i+ishift) + done + end; + let new_det = + { det with n_states = (States_number.of_int 1) } + in + write new_det + ;; + end diff --git a/ocaml/Makefile b/ocaml/Makefile index 7d51986f..8519c973 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -13,6 +13,7 @@ LIBS= PKGS= OCAMLCFLAGS="-g -warn-error A" OCAMLBUILD=ocamlbuild -j 0 -syntax camlp4o -cflags $(OCAMLCFLAGS) -lflags $(OCAMLCFLAGS) +MLLFILES=$(wildcard *.mll) MLFILES=$(wildcard *.ml) ezfio.ml Qptypes.ml Input_auto_generated.ml qp_edit.ml MLIFILES=$(wildcard *.mli) git ALL_TESTS=$(patsubst %.ml,%.byte,$(wildcard test_*.ml)) diff --git a/ocaml/Message.ml b/ocaml/Message.ml index 68b866d5..2ed38864 100644 --- a/ocaml/Message.ml +++ b/ocaml/Message.ml @@ -110,7 +110,7 @@ module Disconnect_msg : sig { client_id: Id.Client.t ; state: State.t ; } - val create : state:string -> client_id:string -> t + val create : state:string -> client_id:int -> t val to_string : t -> string end = struct type t = @@ -118,7 +118,7 @@ end = struct state: State.t ; } let create ~state ~client_id = - { client_id = Id.Client.of_string client_id ; state = State.of_string state } + { client_id = Id.Client.of_int client_id ; state = State.of_string state } let to_string x = Printf.sprintf "disconnect %s %d" (State.to_string x.state) @@ -150,18 +150,18 @@ end module AddTask_msg : sig type t = { state: State.t; - task: string; + tasks: string list; } - val create : state:string -> task:string -> t + val create : state:string -> tasks:string list -> t val to_string : t -> string end = struct type t = { state: State.t; - task: string; + tasks: string list; } - let create ~state ~task = { state = State.of_string state ; task } + let create ~state ~tasks = { state = State.of_string state ; tasks } let to_string x = - Printf.sprintf "add_task %s %s" (State.to_string x.state) x.task + Printf.sprintf "add_task %s %s" (State.to_string x.state) (String.concat ~sep:"|" x.tasks) end @@ -182,44 +182,44 @@ end module DelTask_msg : sig type t = { state: State.t; - task_id: Id.Task.t + task_ids: Id.Task.t list } - val create : state:string -> task_id:string -> t + val create : state:string -> task_ids:int list -> t val to_string : t -> string end = struct type t = { state: State.t; - task_id: Id.Task.t + task_ids: Id.Task.t list } - let create ~state ~task_id = + let create ~state ~task_ids = { state = State.of_string state ; - task_id = Id.Task.of_string task_id + task_ids = List.map ~f:Id.Task.of_int task_ids } let to_string x = - Printf.sprintf "del_task %s %d" + Printf.sprintf "del_task %s %s" (State.to_string x.state) - (Id.Task.to_int x.task_id) + (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end (** DelTaskReply : Reply to the DelTask message *) module DelTaskReply_msg : sig type t - val create : task_id:Id.Task.t -> more:bool -> t + val create : task_ids:Id.Task.t list -> more:bool -> t val to_string : t -> string end = struct type t = { - task_id : Id.Task.t ; + task_ids : Id.Task.t list; more : bool; } - let create ~task_id ~more = { task_id ; more } + let create ~task_ids ~more = { task_ids ; more } let to_string x = let more = if x.more then "more" else "done" in - Printf.sprintf "del_task_reply %s %d" - more (Id.Task.to_int x.task_id) + Printf.sprintf "del_task_reply %s %s" + more (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end @@ -230,7 +230,7 @@ module GetTask_msg : sig { client_id: Id.Client.t ; state: State.t ; } - val create : state:string -> client_id:string -> t + val create : state:string -> client_id:int -> t val to_string : t -> string end = struct type t = @@ -238,7 +238,7 @@ end = struct state: State.t ; } let create ~state ~client_id = - { client_id = Id.Client.of_string client_id ; state = State.of_string state } + { client_id = Id.Client.of_int client_id ; state = State.of_string state } let to_string x = Printf.sprintf "get_task %s %d" (State.to_string x.state) @@ -269,14 +269,14 @@ module GetPsi_msg : sig type t = { client_id: Id.Client.t ; } - val create : client_id:string -> t + val create : client_id:int -> t val to_string : t -> string end = struct type t = { client_id: Id.Client.t ; } let create ~client_id = - { client_id = Id.Client.of_string client_id } + { client_id = Id.Client.of_int client_id } let to_string x = Printf.sprintf "get_psi %d" (Id.Client.to_int x.client_id) @@ -365,14 +365,14 @@ module PutPsi_msg : sig n_det_selectors : Strictly_positive_int.t option; psi : Psi.t option } val create : - client_id:string -> - n_state:string -> - n_det:string -> - psi_det_size:string -> + client_id:int -> + n_state:int -> + n_det:int -> + psi_det_size:int -> psi_det:string option -> psi_coef:string option -> - n_det_generators: string option -> - n_det_selectors:string option -> + n_det_generators: int option -> + n_det_selectors:int option -> energy:string option -> t val to_string_list : t -> string list val to_string : t -> string @@ -388,20 +388,17 @@ end = struct let create ~client_id ~n_state ~n_det ~psi_det_size ~psi_det ~psi_coef ~n_det_generators ~n_det_selectors ~energy = let n_state, n_det, psi_det_size = - Int.of_string n_state - |> Strictly_positive_int.of_int , - Int.of_string n_det - |> Strictly_positive_int.of_int , - Int.of_string psi_det_size - |> Strictly_positive_int.of_int + Strictly_positive_int.of_int n_state, + Strictly_positive_int.of_int n_det, + Strictly_positive_int.of_int psi_det_size in assert (Strictly_positive_int.to_int psi_det_size >= Strictly_positive_int.to_int n_det); let n_det_generators, n_det_selectors = match n_det_generators, n_det_selectors with | Some x, Some y -> - Some (Strictly_positive_int.of_int @@ Int.of_string x), - Some (Strictly_positive_int.of_int @@ Int.of_string y) + Some (Strictly_positive_int.of_int x), + Some (Strictly_positive_int.of_int y) | _ -> None, None in let psi = @@ -411,7 +408,7 @@ end = struct ~psi_coef ~n_det_generators ~n_det_selectors ~energy) | _ -> None in - { client_id = Id.Client.of_string client_id ; + { client_id = Id.Client.of_int client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors ; psi } @@ -463,48 +460,48 @@ module TaskDone_msg : sig type t = { client_id: Id.Client.t ; state: State.t ; - task_id: Id.Task.t ; + task_ids: Id.Task.t list ; } - val create : state:string -> client_id:string -> task_id:string -> t + val create : state:string -> client_id:int -> task_ids:int list -> t val to_string : t -> string end = struct type t = { client_id: Id.Client.t ; state: State.t ; - task_id: Id.Task.t; + task_ids: Id.Task.t list; } - let create ~state ~client_id ~task_id = - { client_id = Id.Client.of_string client_id ; + let create ~state ~client_id ~task_ids = + { client_id = Id.Client.of_int client_id ; state = State.of_string state ; - task_id = Id.Task.of_string task_id; + task_ids = List.map ~f:Id.Task.of_int task_ids; } let to_string x = - Printf.sprintf "task_done %s %d %d" + Printf.sprintf "task_done %s %d %s" (State.to_string x.state) (Id.Client.to_int x.client_id) - (Id.Task.to_int x.task_id) + (String.concat ~sep:"|" @@ List.map ~f:Id.Task.to_string x.task_ids) end (** Terminate *) module Terminate_msg : sig type t - val create : unit -> t + val create : t val to_string : t -> string end = struct type t = Terminate - let create () = Terminate + let create = Terminate let to_string x = "terminate" end (** OK *) module Ok_msg : sig type t - val create : unit -> t + val create : t val to_string : t -> string end = struct type t = Ok - let create () = Ok + let create = Ok let to_string x = "ok" end @@ -551,45 +548,45 @@ type t = let of_string s = - let l = - String.split ~on:' ' s - |> List.filter ~f:(fun x -> (String.strip x) <> "") - |> List.map ~f:String.lowercase - in - match l with - | "add_task" :: state :: task -> - AddTask (AddTask_msg.create ~state ~task:(String.concat ~sep:" " task) ) - | "del_task" :: state :: task_id :: [] -> - DelTask (DelTask_msg.create ~state ~task_id) - | "get_task" :: state :: client_id :: [] -> - GetTask (GetTask_msg.create ~state ~client_id) - | "task_done" :: state :: client_id :: task_id :: [] -> - TaskDone (TaskDone_msg.create ~state ~client_id ~task_id) - | "disconnect" :: state :: client_id :: [] -> - Disconnect (Disconnect_msg.create ~state ~client_id) - | "connect" :: t :: [] -> - Connect (Connect_msg.create t) - | "new_job" :: state :: push_address_tcp :: push_address_inproc :: [] -> - Newjob (Newjob_msg.create push_address_tcp push_address_inproc state) - | "end_job" :: state :: [] -> - Endjob (Endjob_msg.create state) - | "terminate" :: [] -> - Terminate (Terminate_msg.create () ) - | "get_psi" :: client_id :: [] -> - GetPsi (GetPsi_msg.create ~client_id) - | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: n_det_generators :: n_det_selectors :: [] -> - PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size - ~n_det_generators:(Some n_det_generators) ~n_det_selectors:(Some n_det_selectors) - ~psi_det:None ~psi_coef:None ~energy:None ) - | "put_psi" :: client_id :: n_state :: n_det :: psi_det_size :: [] -> - PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size ~n_det_generators:None - ~n_det_selectors:None ~psi_det:None ~psi_coef:None ~energy:None) - | "ok" :: [] -> Ok (Ok_msg.create ()) - | "error" :: rest -> Error (Error_msg.create (String.concat ~sep:" " rest)) - | "set_stopped" :: [] -> SetStopped - | "set_running" :: [] -> SetRunning - | "set_waiting" :: [] -> SetWaiting - | _ -> failwith "Message not understood" + let open Message_lexer in + match parse s with + | AddTask_ { state ; tasks } -> + AddTask (AddTask_msg.create ~state ~tasks) + | DelTask_ { state ; task_ids } -> + DelTask (DelTask_msg.create ~state ~task_ids) + | GetTask_ { state ; client_id } -> + GetTask (GetTask_msg.create ~state ~client_id) + | TaskDone_ { state ; task_ids ; client_id } -> + TaskDone (TaskDone_msg.create ~state ~client_id ~task_ids) + | Disconnect_ { state ; client_id } -> + Disconnect (Disconnect_msg.create ~state ~client_id) + | Connect_ socket -> + Connect (Connect_msg.create socket) + | NewJob_ { state ; push_address_tcp ; push_address_inproc } -> + Newjob (Newjob_msg.create push_address_tcp push_address_inproc state) + | EndJob_ state -> + Endjob (Endjob_msg.create state) + | GetPsi_ client_id -> + GetPsi (GetPsi_msg.create ~client_id) + | PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } -> + begin + match n_det_selectors, n_det_generators with + | Some s, Some g -> + PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size + ~n_det_generators:(Some g) ~n_det_selectors:(Some s) + ~psi_det:None ~psi_coef:None ~energy:None ) + | _ -> + PutPsi (PutPsi_msg.create ~client_id ~n_state ~n_det ~psi_det_size + ~n_det_generators:None ~n_det_selectors:None + ~psi_det:None ~psi_coef:None ~energy:None ) + end + | Terminate_ -> Terminate (Terminate_msg.create ) + | SetWaiting_ -> SetWaiting + | SetStopped_ -> SetStopped + | SetRunning_ -> SetRunning + | Ok_ -> Ok (Ok_msg.create) + | Error_ m -> Error (Error_msg.create m) + let to_string = function diff --git a/ocaml/Message_lexer.mll b/ocaml/Message_lexer.mll new file mode 100644 index 00000000..c67f4528 --- /dev/null +++ b/ocaml/Message_lexer.mll @@ -0,0 +1,265 @@ +{ + +type kw_type = + | TEXT of string + | WORD of string + | INTEGER of int + | FLOAT of float + | NONE + | ADD_TASK + | DEL_TASK + | GET_TASK + | TASK_DONE + | DISCONNECT + | CONNECT + | NEW_JOB + | END_JOB + | TERMINATE + | GET_PSI + | PUT_PSI + | OK + | ERROR + | SET_STOPPED + | SET_RUNNING + | SET_WAITING + +type state_tasks = { state : string ; tasks : string list ; } +type state_taskids = { state : string ; task_ids : int list ; } +type state_taskids_clientid = { state : string ; task_ids : int list ; client_id : int ; } +type state_clientid = { state : string ; client_id : int ; } +type state_tcp_inproc = { state : string ; push_address_tcp : string ; push_address_inproc : string ; } +type psi = { client_id: int ; n_state: int ; n_det: int ; psi_det_size: int ; + n_det_generators: int option ; n_det_selectors: int option } + +type msg = + | AddTask_ of state_tasks + | DelTask_ of state_taskids + | GetTask_ of state_clientid + | TaskDone_ of state_taskids_clientid + | Disconnect_ of state_clientid + | Connect_ of string + | NewJob_ of state_tcp_inproc + | EndJob_ of string + | Terminate_ + | GetPsi_ of int + | PutPsi_ of psi + | Ok_ + | Error_ of string + | SetStopped_ + | SetRunning_ + | SetWaiting_ +} + +let word = [^' ' '\t' '\n']+ +let text = [^ ' ' '|']+[^ '|']+ +let integer = ['0'-'9']+ +let real = '-'? integer '.' integer (['e' 'E'] '-'? integer)? + +let white = [' ' '\t']+ + + +rule get_text = parse + | text as t { TEXT t } + | eof { TERMINATE } + | _ { NONE } + +and get_int = parse + | integer as i { INTEGER (int_of_string i) } + | eof { TERMINATE } + | _ { NONE } + +and get_word = parse + | word as w { WORD w } + | eof { TERMINATE } + | _ { NONE } + +and kw = parse + | "add_task" { ADD_TASK } + | "del_task" { DEL_TASK } + | "get_task" { GET_TASK } + | "task_done" { TASK_DONE } + | "disconnect" { DISCONNECT } + | "connect" { CONNECT } + | "new_job" { NEW_JOB } + | "end_job" { END_JOB } + | "terminate" { TERMINATE } + | "get_psi" { GET_PSI } + | "put_psi" { PUT_PSI } + | "ok" { OK } + | "error" { ERROR } + | "set_stopped" { SET_STOPPED } + | "set_running" { SET_RUNNING } + | "set_waiting" { SET_WAITING } + | _ { NONE } + + +{ + let rec read_text ?(accu=[]) lexbuf = + let token = + get_text lexbuf + in + match token with + | TEXT t -> read_text ~accu:(t::accu) lexbuf + | TERMINATE -> List.rev accu + | NONE -> read_text ~accu lexbuf + | _ -> failwith "Error in MessageLexer (2)" + + and read_word lexbuf = + let token = + get_word lexbuf + in + match token with + | WORD w -> w + | NONE -> read_word lexbuf + | _ -> failwith "Error in MessageLexer (3)" + + and read_int lexbuf = + let token = + get_int lexbuf + in + match token with + | INTEGER i -> i + | NONE -> read_int lexbuf + | _ -> failwith "Error in MessageLexer (4)" + + and read_ints ?(accu=[]) lexbuf = + let token = + get_int lexbuf + in + match token with + | INTEGER i -> read_ints ~accu:(i::accu) lexbuf + | TERMINATE -> List.rev accu + | NONE -> read_ints ~accu lexbuf + | _ -> failwith "Error in MessageLexer (4)" + + and parse_rec lexbuf = + let token = + kw lexbuf + in + match token with + | ADD_TASK -> + let state = read_word lexbuf in + let tasks = read_text lexbuf in + AddTask_ { state ; tasks } + + | DEL_TASK -> + let state = read_word lexbuf in + let task_ids = read_ints lexbuf in + DelTask_ { state ; task_ids } + + | GET_TASK -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + GetTask_ { state ; client_id } + + | TASK_DONE -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + let task_ids = read_ints lexbuf in + TaskDone_ { state ; task_ids ; client_id } + + | DISCONNECT -> + let state = read_word lexbuf in + let client_id = read_int lexbuf in + Disconnect_ { state ; client_id } + + | GET_PSI -> + let client_id = read_int lexbuf in + GetPsi_ client_id + + | PUT_PSI -> + let client_id = read_int lexbuf in + let n_state = read_int lexbuf in + let n_det = read_int lexbuf in + let psi_det_size = read_int lexbuf in + let n_det_generators, n_det_selectors = + try + (Some (read_int lexbuf), Some (read_int lexbuf)) + with (Failure _) -> (None, None) + in + PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } + + | CONNECT -> + let socket = read_word lexbuf in + Connect_ socket + + | NEW_JOB -> + let state = read_word lexbuf in + let push_address_tcp = read_word lexbuf in + let push_address_inproc = read_word lexbuf in + NewJob_ { state ; push_address_tcp ; push_address_inproc } + + | END_JOB -> + let state = read_word lexbuf in + EndJob_ state + + | ERROR -> + let message = List.hd (read_text lexbuf) in + Error_ message + + | OK -> Ok_ + | SET_WAITING -> SetWaiting_ + | SET_RUNNING -> SetRunning_ + | SET_STOPPED -> SetStopped_ + | TERMINATE -> Terminate_ + | NONE -> parse_rec lexbuf + | _ -> failwith "Error in MessageLexer" + + let parse message = + let lexbuf = + Lexing.from_string message + in + parse_rec lexbuf + + + let debug () = + let l = [ + "add_task state_pouet Task pouet zob" ; + "add_task state_pouet Task pouet zob |Task2 zob | Task3 prout" ; + "del_task state_pouet 12345" ; + "del_task state_pouet 12345 | 6789 | 10 | 11" ; + "get_task state_pouet 12" ; + "task_done state_pouet 12 12345"; + "task_done state_pouet 12 12345 | 678 | 91011"; + "connect tcp"; + "disconnect state_pouet 12"; + "new_job state_pouet tcp://test.com:12345 ipc:///dev/shm/x.socket"; + "end_job state_pouet"; + "terminate" ; + "set_running" ; + "set_stopped" ; + "set_waiting" ; + "ok" ; + "error my_error" ; + "get_psi 12" ; + "put_psi 12 2 1000 10000 800 900" ; + "put_psi 12 2 1000 10000" + ] + |> List.map parse + in + List.map (function + | AddTask_ { state ; tasks } -> Printf.sprintf "ADD_TASK state:\"%s\" tasks:{\"%s\"}" state (String.concat "\"}|{\"" tasks) + | DelTask_ { state ; task_ids } -> Printf.sprintf "DEL_TASK state:\"%s\" task_ids:{%s}" state (String.concat "|" @@ List.map string_of_int task_ids) + | GetTask_ { state ; client_id } -> Printf.sprintf "GET_TASK state:\"%s\" task_id:%d" state client_id + | TaskDone_ { state ; task_ids ; client_id } -> Printf.sprintf "TASK_DONE state:\"%s\" task_ids:{%s} client_id:%d" state (String.concat "|" @@ List.map string_of_int task_ids) client_id + | Disconnect_ { state ; client_id } -> Printf.sprintf "DISCONNECT state:\"%s\" client_id:%d" state client_id + | Connect_ socket -> Printf.sprintf "CONNECT socket:\"%s\"" socket + | NewJob_ { state ; push_address_tcp ; push_address_inproc } -> Printf.sprintf "NEW_JOB state:\"%s\" tcp:\"%s\" inproc:\"%s\"" state push_address_tcp push_address_inproc + | EndJob_ state -> Printf.sprintf "END_JOB state:\"%s\"" state + | GetPsi_ client_id -> Printf.sprintf "GET_PSI client_id:%d" client_id + | PutPsi_ { client_id ; n_state ; n_det ; psi_det_size ; n_det_generators ; n_det_selectors } -> + begin + match n_det_selectors, n_det_generators with + | Some s, Some g -> Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d n_det_generators:%d n_det_selectors:%d" client_id n_state n_det psi_det_size g s + | _ -> Printf.sprintf "PUT_PSI client_id:%d n_state:%d n_det:%d psi_det_size:%d" client_id n_state n_det psi_det_size + end + | Terminate_ -> "TERMINATE" + | SetWaiting_ -> "SET_WAITING" + | SetStopped_ -> "SET_STOPPED" + | SetRunning_ -> "SET_RUNNING" + | Ok_ -> "OK" + | Error_ s -> Printf.sprintf "ERROR: \"%s\"" s + ) l + |> List.iter print_endline + +} diff --git a/ocaml/Symmetry.ml b/ocaml/Symmetry.ml index 5849e116..8647ae99 100644 --- a/ocaml/Symmetry.ml +++ b/ocaml/Symmetry.ml @@ -85,7 +85,7 @@ module Xyz = struct let of_string s = let flush state accu number = let n = - if (number = "") then 0 + if (number = "") then 1 else (Int.of_string number) in match state with diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 6edc8122..abc2de1d 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -47,6 +47,14 @@ let debug str = let zmq_context = ZMQ.Context.create () +let () = + let nproc = + match Sys.getenv "OMP_NUM_THREADS" with + | Some m -> int_of_string m + | None -> 2 + in + ZMQ.Context.set_io_threads zmq_context nproc + let bind_socket ~socket_type ~socket ~port = let rec loop = function @@ -62,7 +70,15 @@ let bind_socket ~socket_type ~socket ~port = | Unix.Unix_error _ -> (Time.pause @@ Time.Span.of_float 1. ; loop (i-1) ) | other_exception -> raise other_exception in loop 60; - ZMQ.Socket.bind socket @@ Printf.sprintf "ipc:///tmp/qp_run:%d" port + let filename = + Printf.sprintf "/tmp/qp_run:%d" port + in + begin + match Sys.file_exists filename with + | `Yes -> Sys.remove filename + | _ -> () + end; + ZMQ.Socket.bind socket ("ipc://"^filename) let hostname = lazy ( @@ -99,7 +115,7 @@ let ip_address = lazy ( let reply_ok rep_socket = - Message.Ok_msg.create () + Message.Ok_msg.create |> Message.Ok_msg.to_string |> ZMQ.Socket.send rep_socket @@ -121,7 +137,7 @@ let stop ~port = ZMQ.Socket.set_linger_period req_socket 1_000_000; ZMQ.Socket.connect req_socket address; - Message.Terminate (Message.Terminate_msg.create ()) + Message.Terminate (Message.Terminate_msg.create) |> Message.to_string |> ZMQ.Socket.send req_socket ; @@ -289,9 +305,9 @@ let disconnect msg program_state rep_socket = let del_task msg program_state rep_socket = - let state, task_id = + let state, task_ids = msg.Message.DelTask_msg.state, - msg.Message.DelTask_msg.task_id + msg.Message.DelTask_msg.task_ids in let failure () = @@ -302,13 +318,14 @@ let del_task msg program_state rep_socket = let new_program_state = { program_state with - queue = Queuing_system.del_task ~task_id program_state.queue + queue = List.fold ~f:(fun queue task_id -> Queuing_system.del_task ~task_id queue) + ~init:program_state.queue task_ids } in let more = (Queuing_system.number_of_tasks new_program_state.queue > 0) in - Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_id ~more) + Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more) |> Message.to_string |> ZMQ.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *) new_program_state @@ -329,9 +346,9 @@ let del_task msg program_state rep_socket = let add_task msg program_state rep_socket = - let state, task = + let state, tasks = msg.Message.AddTask_msg.state, - msg.Message.AddTask_msg.task + msg.Message.AddTask_msg.tasks in let increment_progress_bar = function @@ -339,59 +356,17 @@ let add_task msg program_state rep_socket = | None -> None in - let rec add_task_triangle program_state imax = function - | 0 -> program_state - | i -> - let task = - Printf.sprintf "%d %d" i imax - in - let new_program_state = - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - add_task_triangle new_program_state imax (i-1) - in - - let rec add_task_range program_state i = function - | j when (j < i) -> program_state - | j -> - let task = - Printf.sprintf "%d" j - in - let new_program_state = - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - add_task_range new_program_state i (j-1) - in - - let new_program_state = function - | "triangle" :: i_str :: [] -> - let imax = - Int.of_string i_str - in - add_task_triangle program_state imax imax - | "range" :: i_str :: j_str :: [] -> - let i, j = - Int.of_string i_str, - Int.of_string j_str - in - add_task_range program_state i j - | _ -> - { program_state with - queue = Queuing_system.add_task ~task program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; - } - in - let result = - String.split ~on:' ' task - |> List.filter ~f:(fun x -> x <> "") - |> new_program_state + let new_queue, new_bar = + List.fold ~f:(fun (queue, bar) task -> + Queuing_system.add_task ~task queue, + increment_progress_bar bar) + ~init:(program_state.queue, program_state.progress_bar) tasks + in + { program_state with + queue = new_queue; + progress_bar = new_bar + } in reply_ok rep_socket; result @@ -448,10 +423,10 @@ let get_task msg program_state rep_socket pair_socket = let task_done msg program_state rep_socket = - let state, client_id, task_id = + let state, client_id, task_ids = msg.Message.TaskDone_msg.state, msg.Message.TaskDone_msg.client_id, - msg.Message.TaskDone_msg.task_id + msg.Message.TaskDone_msg.task_ids in let increment_progress_bar = function @@ -464,10 +439,16 @@ let task_done msg program_state rep_socket = program_state and success () = + let new_queue, new_bar = + List.fold ~f:(fun (queue, bar) task_id -> + Queuing_system.end_task ~task_id ~client_id queue, + increment_progress_bar bar) + ~init:(program_state.queue, program_state.progress_bar) task_ids + in let result = { program_state with - queue = Queuing_system.end_task ~task_id ~client_id program_state.queue ; - progress_bar = increment_progress_bar program_state.progress_bar ; + queue = new_queue; + progress_bar = new_bar } in reply_ok rep_socket; diff --git a/ocaml/qp_create_ezfio_from_xyz.ml b/ocaml/qp_create_ezfio_from_xyz.ml index c79bf550..7c07ffe5 100644 --- a/ocaml/qp_create_ezfio_from_xyz.ml +++ b/ocaml/qp_create_ezfio_from_xyz.ml @@ -21,6 +21,9 @@ let spec = ~doc:" Compute AOs in the Cartesian basis set (6d, 10f, ...)" +> anon ("(xyz_file|zmt_file)" %: file ) +type element = +| Element of Element.t +| Int_elem of (Nucl_number.t * Element.t) (** Handle dummy atoms placed on bonds *) let dummy_centers ~threshold ~molecule ~nuclei = @@ -115,17 +118,14 @@ let run ?o b c d m p cart xyz_file = (* Open basis set channels *) let basis_channel element = let key = - Element.to_string element + match element with + | Element e -> Element.to_string e + | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in match Hashtbl.find basis_table key with | Some in_channel -> in_channel - | None -> - let msg = - Printf.sprintf "%s is not defined in basis %s.%!" - (Element.to_long_string element) b ; - in - failwith msg + | None -> raise Not_found in let temp_filename = @@ -189,12 +189,21 @@ let run ?o b c d m p cart xyz_file = | Some (key, basis) -> (*Aux basis *) begin let elem = - Element.of_string key + try + Element (Element.of_string key) + with Element.ElementError _ -> + let result = + match (String.split ~on:',' key) with + | i :: k :: [] -> (Nucl_number.of_int @@ int_of_string i, Element.of_string k) + | _ -> failwith "Expected format is int,Element:basis" + in Int_elem result and basis = String.lowercase basis in let key = - Element.to_string elem + match elem with + | Element e -> Element.to_string e + | Int_elem (i,e) -> Printf.sprintf "%d,%s" (Nucl_number.to_int i) (Element.to_string e) in let new_channel = fetch_channel basis @@ -202,7 +211,13 @@ let run ?o b c d m p cart xyz_file = begin match Hashtbl.add basis_table ~key:key ~data:new_channel with | `Ok -> () - | `Duplicate -> failwith ("Duplicate definition of basis for "^(Element.to_long_string elem)) + | `Duplicate -> + let e = + match elem with + | Element e -> e + | Int_elem (_,e) -> e + in + failwith ("Duplicate definition of basis for "^(Element.to_long_string e)) end end end; @@ -537,7 +552,20 @@ let run ?o b c d m p cart xyz_file = | Element.X -> Element.H | e -> e in - Basis.read_element (basis_channel x.Atom.element) i e + let key = + Int_elem (i,x.Atom.element) + in + try + Basis.read_element (basis_channel key) i e + with Not_found -> + let key = + Element x.Atom.element + in + try + Basis.read_element (basis_channel key) i e + with Not_found -> + failwith (Printf.sprintf "Basis not found for atom %d (%s)" (Nucl_number.to_int i) + (Element.to_string x.Atom.element) ) with | End_of_file -> failwith ("Element "^(Element.to_string x.Atom.element)^" not found in basis set.") @@ -647,6 +675,7 @@ atoms are taken from the same basis set, otherwise specific elements can be defined as follows: -b \"cc-pcvdz | H:cc-pvdz | C:6-31g\" + -b \"cc-pvtz | 1,H:sto-3g | 3,H:6-31g\" If a file with the same name as the basis set exists, this file will be read. Otherwise, the basis set is obtained from the database. diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index ee988ccb..160a07d0 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -42,8 +42,8 @@ let input_data = " * Det_number_max : int assert (x > 0) ; - if (x > 100000000) then - warning \"More than 100 million determinants\"; + if (x > 10000000000) then + warning \"More than 10 billion determinants\"; * States_number : int assert (x > 0) ; @@ -140,8 +140,8 @@ let input_ezfio = " * Det_number : int determinants_n_det - 1 : 100000000 - More than 100 million of determinants + 1 : 10000000000 + More than 10 billion of determinants " ;; diff --git a/plugins/All_singles/.gitignore b/plugins/All_singles/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/All_singles/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD/.gitignore b/plugins/CAS_SD/.gitignore deleted file mode 100644 index 57b1926f..00000000 --- a/plugins/CAS_SD/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_CAS -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ZMQ -cas_s -cas_s_selected -cas_sd -cas_sd_selected -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CAS_SD_ZMQ/EZFIO.cfg b/plugins/CAS_SD_ZMQ/EZFIO.cfg index 7425c8ba..43905f9e 100644 --- a/plugins/CAS_SD_ZMQ/EZFIO.cfg +++ b/plugins/CAS_SD_ZMQ/EZFIO.cfg @@ -1,10 +1,15 @@ [energy] type: double precision -doc: "Calculated CAS-SD energy" +doc: Calculated CAS-SD energy interface: ezfio [energy_pt2] type: double precision -doc: "Calculated selected CAS-SD energy with PT2 correction" +doc: Calculated selected CAS-SD energy with PT2 correction interface: ezfio +[do_ddci] +type: logical +doc: If true, remove purely inactive double excitations +interface: ezfio,provider,ocaml +default: False diff --git a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f index 881f74c3..5b364400 100644 --- a/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f +++ b/plugins/CAS_SD_ZMQ/cassd_zmq.irp.f @@ -132,124 +132,3 @@ program fci_zmq call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) end - - - - -subroutine ZMQ_selection(N_in, pt2) - use f77_zmq - use selection_types - - implicit none - - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, intent(in) :: N_in - type(selection_buffer) :: b - integer :: i, N - integer, external :: omp_get_thread_num - double precision, intent(out) :: pt2(N_states) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - integer :: i_generator, i_generator_start, i_generator_max, step -! step = int(max(1.,10*elec_num/mo_tot_num) - - step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) - step = max(1,step) - do i= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - write(task,*) i_generator_start, i_generator_max, 1, N - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif - !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') - if (N_in > 0) then - call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN - call copy_H_apply_buffer_to_wf() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -end - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) - done = 0 - more = 1 - pt2(:) = 0d0 - call CPU_TIME(time0) - do while (more == 1) - call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) - pt2 += pt2_mwen - do i=1, N - call add_to_selection_buffer(b, det(1,1,i), val(i)) - end do - - do i=1, ntask - if(task_id(i) == 0) then - print *, "Error in collector" - endif - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) - end do - done += ntask - call CPU_TIME(time) -! print *, "DONE" , done, time - time0 - end do - - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - call sort_selection_buffer(b) -end subroutine - diff --git a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f index dfaee629..ff5dd509 100644 --- a/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f +++ b/plugins/CAS_SD_ZMQ/run_selection_slave.irp.f @@ -41,8 +41,8 @@ subroutine run_selection_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, i_generator_start, i_generator_max, step, N - read (task,*) i_generator_start, i_generator_max, step, N + integer :: i_generator, N + read (task,*) i_generator, N if(buf%N == 0) then ! Only first time call create_selection_buffer(N, N*2, buf) @@ -50,11 +50,7 @@ subroutine run_selection_slave(thread,iproc,energy) else if(N /= buf%N) stop "N changed... wtf man??" end if - !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) - !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) - do i_generator=i_generator_start,i_generator_max,step - call select_connected(i_generator,energy,pt2,buf) - enddo + call select_connected(i_generator,energy,pt2,buf) endif if(done .or. ctask == size(task_id)) then @@ -115,7 +111,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) if(rc /= 4*ntask) stop "push" ! Activate is zmq_socket_push is a REQ -! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) + rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) end subroutine @@ -149,7 +145,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt if(rc /= 4*ntask) stop "pull" ! Activate is zmq_socket_pull is a REP -! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) + rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) end subroutine diff --git a/plugins/CAS_SD_ZMQ/selection.irp.f b/plugins/CAS_SD_ZMQ/selection.irp.f index cca17d71..3692710d 100644 --- a/plugins/CAS_SD_ZMQ/selection.irp.f +++ b/plugins/CAS_SD_ZMQ/selection.irp.f @@ -112,7 +112,7 @@ double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 get_phase_bi = res(iand(np,1_1)) -end function +end subroutine @@ -670,6 +670,7 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if(banned(p1,p2)) cycle if(mat(1, p1, p2) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + logical, external :: is_in_wavefunction if (do_ddci) then logical, external :: is_a_two_holes_two_particles diff --git a/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f b/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f new file mode 100644 index 00000000..cf934a46 --- /dev/null +++ b/plugins/CAS_SD_ZMQ/target_pt2_ratio_cassd.irp.f @@ -0,0 +1,109 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref + + double precision, allocatable :: psi_coef_ref(:,:) + integer(bit_kind), allocatable :: psi_det_ref(:,:,:) + + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + ! Stopping criterion is the PT2max + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = 2 + allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2))) + allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3))) + psi_coef_ref = psi_coef_sorted + psi_det_ref = psi_det_sorted + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + do while (Nmax-Nmin > 1) + psi_coef = psi_coef_ref + psi_det = psi_det_ref + TOUCH psi_det psi_coef + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + if (ratio < var_pt2_ratio) then + Nmin = N_det + else + Nmax = N_det + psi_coef_ref = psi_coef + psi_det_ref = psi_det + TOUCH psi_det psi_coef + endif + N_det = Nmin + (Nmax-Nmin)/2 + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + call save_wavefunction + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + print *, 'E+PT2 = ', CI_energy(1)+pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + call save_wavefunction + call ezfio_set_cas_sd_zmq_energy(CI_energy(1)) + call ezfio_set_cas_sd_zmq_energy_pt2(E_CI_before(1)+pt2(1)) +end + + + + diff --git a/plugins/CID/.gitignore b/plugins/CID/.gitignore deleted file mode 100644 index 62ef7631..00000000 --- a/plugins/CID/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -cid -cid_lapack -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CID_SC2_selected/.gitignore b/plugins/CID_SC2_selected/.gitignore deleted file mode 100644 index 5761c0d3..00000000 --- a/plugins/CID_SC2_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CID -CID_selected -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cid_sc2_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CID_selected/.gitignore b/plugins/CID_selected/.gitignore deleted file mode 100644 index 0da32ffe..00000000 --- a/plugins/CID_selected/.gitignore +++ /dev/null @@ -1,30 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CID -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cid_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CIS/.gitignore b/plugins/CIS/.gitignore deleted file mode 100644 index 9b9257d3..00000000 --- a/plugins/CIS/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -cis -ezfio_interface.irp.f -irpf90.make -irpf90_entities -super_ci -tags \ No newline at end of file diff --git a/plugins/CISD/.gitignore b/plugins/CISD/.gitignore deleted file mode 100644 index 2630f994..00000000 --- a/plugins/CISD/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -cisd -cisd_lapack -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CISD_SC2_selected/.gitignore b/plugins/CISD_SC2_selected/.gitignore deleted file mode 100644 index 2f0e8bdd..00000000 --- a/plugins/CISD_SC2_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CISD -CISD_selected -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -cisd_sc2_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/CISD_selected/.gitignore b/plugins/CISD_selected/.gitignore deleted file mode 100644 index 6145158a..00000000 --- a/plugins/CISD_selected/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -CISD -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -cisd_selection -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Casino/.gitignore b/plugins/Casino/.gitignore deleted file mode 100644 index 14f48469..00000000 --- a/plugins/Casino/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_for_casino -tags \ No newline at end of file diff --git a/plugins/Casino/save_for_casino.irp.f b/plugins/Casino/save_for_casino.irp.f index 35c0c3a7..5522e578 100644 --- a/plugins/Casino/save_for_casino.irp.f +++ b/plugins/Casino/save_for_casino.irp.f @@ -5,7 +5,7 @@ subroutine save_casino integer :: getUnitAndOpen, iunit integer, allocatable :: itmp(:) integer :: n_ao_new - real, allocatable :: rtmp(:) + double precision, allocatable :: rtmp(:) PROVIDE ezfio_filename iunit = getUnitAndOpen('gwfn.data','w') diff --git a/plugins/DDCI_selected/.gitignore b/plugins/DDCI_selected/.gitignore deleted file mode 100644 index d114cb7b..00000000 --- a/plugins/DDCI_selected/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_CAS -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ddci -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/DensityMatrix/.gitignore b/plugins/DensityMatrix/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/DensityMatrix/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/FCIdump/.gitignore b/plugins/FCIdump/.gitignore deleted file mode 100644 index ec4d9d34..00000000 --- a/plugins/FCIdump/.gitignore +++ /dev/null @@ -1,24 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -fcidump -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI/.gitignore b/plugins/Full_CI/.gitignore deleted file mode 100644 index 70d637ea..00000000 --- a/plugins/Full_CI/.gitignore +++ /dev/null @@ -1,34 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -full_ci -full_ci_no_skip -irpf90.make -irpf90_entities -tags -target_pt2 -var_pt2_ratio \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/.gitignore b/plugins/Full_CI_ZMQ/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/Full_CI_ZMQ/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Full_CI_ZMQ/energy.irp.f b/plugins/Full_CI_ZMQ/energy.irp.f index db1e7d1a..5f9baf46 100644 --- a/plugins/Full_CI_ZMQ/energy.irp.f +++ b/plugins/Full_CI_ZMQ/energy.irp.f @@ -1,11 +1,23 @@ +BEGIN_PROVIDER [ logical, initialize_pt2_E0_denominator ] + implicit none + BEGIN_DOC + ! If true, initialize pt2_E0_denominator + END_DOC + initialize_pt2_E0_denominator = .True. +END_PROVIDER + BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ] implicit none BEGIN_DOC ! E0 in the denominator of the PT2 END_DOC - pt2_E0_denominator(1:N_states) = CI_electronic_energy(1:N_states) + if (initialize_pt2_E0_denominator) then + pt2_E0_denominator(1:N_states) = psi_energy(1:N_states) ! pt2_E0_denominator(1:N_states) = HF_energy - nuclear_repulsion ! pt2_E0_denominator(1:N_states) = barycentric_electronic_energy(1:N_states) - call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') + call write_double(6,pt2_E0_denominator(1)+nuclear_repulsion, 'PT2 Energy denominator') + else + pt2_E0_denominator = -huge(1.d0) + endif END_PROVIDER diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index ae0d7989..fcc38954 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -68,8 +68,8 @@ program fci_zmq call ezfio_set_full_ci_zmq_energy(CI_energy(1)) n_det_before = N_det - to_select = 2*N_det - to_select = max(64-to_select, to_select) + to_select = N_det + to_select = max(N_det, to_select) to_select = min(to_select, N_det_max-n_det_before) call ZMQ_selection(to_select, pt2) @@ -96,11 +96,17 @@ program fci_zmq if(do_pt2_end)then print*,'Last iteration only to compute the PT2' - threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) - threshold_generators = max(threshold_generators,threshold_generators_pt2) - TOUCH threshold_selectors threshold_generators + !threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + !threshold_generators = max(threshold_generators,threshold_generators_pt2) + !TOUCH threshold_selectors threshold_generators + threshold_selectors = 1.d0 + threshold_generators = 1d0 E_CI_before(1:N_states) = CI_energy(1:N_states) - call ZMQ_selection(0, pt2) + double precision :: relative_error + relative_error=1.d-3 + pt2 = 0.d0 + call ZMQ_pt2(pt2,relative_error) + !call ZMQ_selection(0, pt2)! pour non-stochastic print *, 'Final step' print *, 'N_det = ', N_det print *, 'N_states = ', N_states @@ -119,122 +125,3 @@ program fci_zmq end - - -subroutine ZMQ_selection(N_in, pt2) - use f77_zmq - use selection_types - - implicit none - - character*(512) :: task - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - integer, intent(in) :: N_in - type(selection_buffer) :: b - integer :: i, N - integer, external :: omp_get_thread_num - double precision, intent(out) :: pt2(N_states) - - - if (.True.) then - PROVIDE pt2_e0_denominator - N = max(N_in,1) - provide nproc - call new_parallel_job(zmq_to_qp_run_socket,"selection") - call zmq_put_psi(zmq_to_qp_run_socket,1,pt2_e0_denominator,size(pt2_e0_denominator)) - call zmq_set_running(zmq_to_qp_run_socket) - call create_selection_buffer(N, N*2, b) - endif - - integer :: i_generator, i_generator_start, i_generator_max, step -! step = int(max(1.,10*elec_num/mo_tot_num) - - step = int(5000000.d0 / dble(N_int * N_states * elec_num * elec_num * mo_tot_num * mo_tot_num )) - step = max(1,step) - do i= 1, N_det_generators,step - i_generator_start = i - i_generator_max = min(i+step-1,N_det_generators) - write(task,*) i_generator_start, i_generator_max, 1, N - call add_task_to_taskserver(zmq_to_qp_run_socket,task) - end do - - !$OMP PARALLEL DEFAULT(shared) SHARED(b, pt2) PRIVATE(i) NUM_THREADS(nproc+1) - i = omp_get_thread_num() - if (i==0) then - call selection_collector(b, pt2) - else - call selection_slave_inproc(i) - endif - !$OMP END PARALLEL - call end_parallel_job(zmq_to_qp_run_socket, 'selection') - if (N_in > 0) then - call fill_H_apply_buffer_no_selection(b%cur,b%det,N_int,0) !!! PAS DE ROBIN - call copy_H_apply_buffer_to_wf() - if (s2_eig) then - call make_s2_eigenfunction - endif - endif -end subroutine - - -subroutine selection_slave_inproc(i) - implicit none - integer, intent(in) :: i - - call run_selection_slave(1,i,pt2_e0_denominator) -end - -subroutine selection_collector(b, pt2) - use f77_zmq - use selection_types - use bitmasks - implicit none - - - type(selection_buffer), intent(inout) :: b - double precision, intent(out) :: pt2(N_states) - double precision :: pt2_mwen(N_states) - integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket - integer(ZMQ_PTR) :: zmq_to_qp_run_socket - - integer(ZMQ_PTR), external :: new_zmq_pull_socket - integer(ZMQ_PTR) :: zmq_socket_pull - - integer :: msg_size, rc, more - integer :: acc, i, j, robin, N, ntask - double precision, allocatable :: val(:) - integer(bit_kind), allocatable :: det(:,:,:) - integer, allocatable :: task_id(:) - integer :: done - real :: time, time0 - zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() - zmq_socket_pull = new_zmq_pull_socket() - allocate(val(b%N), det(N_int, 2, b%N), task_id(N_det)) - done = 0 - more = 1 - pt2(:) = 0d0 - call CPU_TIME(time0) - do while (more == 1) - call pull_selection_results(zmq_socket_pull, pt2_mwen, val(1), det(1,1,1), N, task_id, ntask) - pt2 += pt2_mwen - do i=1, N - call add_to_selection_buffer(b, det(1,1,i), val(i)) - end do - - do i=1, ntask - if(task_id(i) == 0) then - print *, "Error in collector" - endif - call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id(i),more) - end do - done += ntask - call CPU_TIME(time) -! print *, "DONE" , done, time - time0 - end do - - - call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) - call end_zmq_pull_socket(zmq_socket_pull) - call sort_selection_buffer(b) -end subroutine - diff --git a/plugins/Full_CI_ZMQ/pt2_slave.irp.f b/plugins/Full_CI_ZMQ/pt2_slave.irp.f new file mode 100644 index 00000000..c112e040 --- /dev/null +++ b/plugins/Full_CI_ZMQ/pt2_slave.irp.f @@ -0,0 +1,70 @@ +program pt2_slave + implicit none + BEGIN_DOC +! Helper program to compute the PT2 in distributed mode. + END_DOC + + read_wf = .False. + SOFT_TOUCH read_wf + call provide_everything + call switch_qp_run_to_master + call run_wf +end + +subroutine provide_everything + PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context +end + +subroutine run_wf + use f77_zmq + implicit none + + integer(ZMQ_PTR), external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + double precision :: energy(N_states_diag) + character*(64) :: states(1) + integer :: rc, i + + call provide_everything + + zmq_context = f77_zmq_ctx_new () + states(1) = 'pt2' + + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + + do + + call wait_for_states(states,zmq_state,1) + + if(trim(zmq_state) == 'Stopped') then + + exit + + else if (trim(zmq_state) == 'pt2') then + + ! Selection + ! --------- + + print *, 'PT2' + call zmq_get_psi(zmq_to_qp_run_socket,1,energy,N_states) + + !$OMP PARALLEL PRIVATE(i) + i = omp_get_thread_num() + call pt2_slave_tcp(i, energy) + !$OMP END PARALLEL + print *, 'PT2 done' + + endif + + end do +end + +subroutine pt2_slave_tcp(i,energy) + implicit none + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: i + logical :: lstop + lstop = .False. + call run_pt2_slave(0,i,energy,lstop) +end + diff --git a/plugins/Full_CI_ZMQ/pt2_stoch.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f new file mode 100644 index 00000000..914e7138 --- /dev/null +++ b/plugins/Full_CI_ZMQ/pt2_stoch.irp.f @@ -0,0 +1,38 @@ +program pt2_stoch + implicit none + read_wf = .True. + SOFT_TOUCH read_wf + PROVIDE mo_bielec_integrals_in_map + call run +end + +subroutine run + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: degree + integer :: n_det_before, to_select + double precision :: threshold_davidson_in + + double precision :: E_CI_before, relative_error + + allocate (pt2(N_states)) + pt2 = 0.d0 + + E_CI_before = pt2_E0_denominator(1) + nuclear_repulsion + threshold_selectors = 1.d0 + threshold_generators = 1d0 + relative_error = 1.d-3 + call ZMQ_pt2(pt2, relative_error) + print *, 'Final step' + print *, 'N_det = ', N_det + print *, 'PT2 = ', pt2 + print *, 'E = ', E_CI_before + print *, 'E+PT2 = ', E_CI_before+pt2 + print *, '-----' + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before+pt2(1)) +end + + diff --git a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f index d78a9705..9a5f2fa8 100644 --- a/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f +++ b/plugins/Full_CI_ZMQ/pt2_stoch_routines.irp.f @@ -217,7 +217,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su actually_computed(tbc(i)) = .false. end do - orgTBDcomb = Nabove(1) + orgTBDcomb = int(Nabove(1)) firstTBDcomb = 1 zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() @@ -264,7 +264,7 @@ subroutine pt2_collector(b, tbc, comb, Ncomb, computed, pt2_detail, sumabove, su double precision :: E0, avg, eqt, prop call do_carlo(tbc, Ncomb+1-firstTBDcomb, comb(firstTBDcomb), pt2_detail, actually_computed, sumabove, sum2above, Nabove) - firstTBDcomb = Nabove(1) - orgTBDcomb + 1 + firstTBDcomb = int(Nabove(1)) - orgTBDcomb + 1 if(Nabove(1) < 2d0) cycle call get_first_tooth(actually_computed, tooth) diff --git a/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f new file mode 100644 index 00000000..5a246319 --- /dev/null +++ b/plugins/Full_CI_ZMQ/run_pt2_slave.irp.f @@ -0,0 +1,172 @@ + +subroutine run_pt2_slave(thread,iproc,energy) + use f77_zmq + use selection_types + implicit none + + double precision, intent(in) :: energy(N_states_diag) + integer, intent(in) :: thread, iproc + integer :: rc, i + + integer :: worker_id, task_id(1), ctask, ltask + character*(512) :: task + + integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket + integer(ZMQ_PTR) :: zmq_to_qp_run_socket + + integer(ZMQ_PTR), external :: new_zmq_push_socket + integer(ZMQ_PTR) :: zmq_socket_push + + type(selection_buffer) :: buf, buf2 + logical :: done + + double precision :: pt2(N_states) + double precision,allocatable :: pt2_detail(:,:) + integer :: index + integer :: Nindex + + allocate(pt2_detail(N_states, N_det_generators)) + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() + zmq_socket_push = new_zmq_push_socket(thread) + call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) + if(worker_id == -1) then + print *, "WORKER -1" + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) + return + end if + buf%N = 0 + ctask = 1 + Nindex=1 + pt2 = 0d0 + pt2_detail = 0d0 + do + call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id(ctask), task) + + done = task_id(ctask) == 0 + if (done) then + ctask = ctask - 1 + else + integer :: i_generator, i_i_generator, N, subset + read (task,*) subset, index + + !!!!! + N=1 + !!!!! + if(buf%N == 0) then + ! Only first time + call create_selection_buffer(N, N*2, buf) + call create_selection_buffer(N, N*3, buf2) + else + if(N /= buf%N) stop "N changed... wtf man??" + end if + do i_i_generator=1, Nindex + i_generator = index + call select_connected(i_generator,energy,pt2_detail(1, i_i_generator),buf,subset) + pt2(:) += pt2_detail(:, i_generator) + enddo + endif + + if(done .or. ctask == size(task_id)) then + if(buf%N == 0 .and. ctask > 0) stop "uninitialized selection_buffer" + do i=1, ctask + call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id(i)) + end do + if(ctask > 0) then + call push_pt2_results(zmq_socket_push, Nindex, index, pt2_detail, task_id(1), ctask) + do i=1,buf%cur + call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + enddo + call sort_selection_buffer(buf2) + buf%mini = buf2%mini + pt2 = 0d0 + pt2_detail(:,:Nindex) = 0d0 + buf%cur = 0 + end if + ctask = 0 + end if + + if(done) exit + ctask = ctask + 1 + end do + call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) + call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) + call end_zmq_push_socket(zmq_socket_push,thread) +end subroutine + + +subroutine push_pt2_results(zmq_socket_push, N, index, pt2_detail, task_id, ntask) + use f77_zmq + use selection_types + implicit none + + integer(ZMQ_PTR), intent(in) :: zmq_socket_push + double precision, intent(in) :: pt2_detail(N_states, N_det_generators) + integer, intent(in) :: ntask, N, index, task_id(*) + integer :: rc + + + rc = f77_zmq_send( zmq_socket_push, N, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, index, 4, ZMQ_SNDMORE) + if(rc /= 4*N) stop "push" + + + rc = f77_zmq_send( zmq_socket_push, pt2_detail, 8*N_states*N, ZMQ_SNDMORE) + if(rc /= 8*N_states*N) stop "push" + + rc = f77_zmq_send( zmq_socket_push, ntask, 4, ZMQ_SNDMORE) + if(rc /= 4) stop "push" + + rc = f77_zmq_send( zmq_socket_push, task_id, ntask*4, 0) + if(rc /= 4*ntask) stop "push" + +! Activate is zmq_socket_push is a REQ + character*(2) :: ok + rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0) +end subroutine + + +subroutine pull_pt2_results(zmq_socket_pull, N, index, pt2_detail, task_id, ntask) + use f77_zmq + use selection_types + implicit none + integer(ZMQ_PTR), intent(in) :: zmq_socket_pull + double precision, intent(inout) :: pt2_detail(N_states, N_det_generators) + integer, intent(out) :: index + integer, intent(out) :: N, ntask, task_id(*) + integer :: rc, rn, i + + rc = f77_zmq_recv( zmq_socket_pull, N, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, index, 4, 0) + if(rc /= 4*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, pt2_detail, N_states*8*N, 0) + if(rc /= 8*N_states*N) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, ntask, 4, 0) + if(rc /= 4) stop "pull" + + rc = f77_zmq_recv( zmq_socket_pull, task_id, ntask*4, 0) + if(rc /= 4*ntask) stop "pull" + +! Activate is zmq_socket_pull is a REP + rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0) + + do i=N+1,N_det_generators + pt2_detail(1:N_states,i) = 0.d0 + enddo +end subroutine + + +BEGIN_PROVIDER [ double precision, pt2_workload, (N_det_generators) ] + integer :: i + do i=1,N_det_generators + pt2_workload(i) = dfloat(N_det_generators - i + 1)**2 + end do + pt2_workload = pt2_workload / sum(pt2_workload) +END_PROVIDER + diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 50e44901..bfc099e2 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -26,7 +26,6 @@ subroutine run_selection_slave(thread,iproc,energy) call connect_to_taskserver(zmq_to_qp_run_socket,worker_id,thread) if(worker_id == -1) then print *, "WORKER -1" - !call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_push_socket(zmq_socket_push,thread) return @@ -41,8 +40,8 @@ subroutine run_selection_slave(thread,iproc,energy) if (done) then ctask = ctask - 1 else - integer :: i_generator, i_generator_start, i_generator_max, step, N - read (task,*) i_generator_start, i_generator_max, step, N + integer :: i_generator, N + read(task,*) i_generator, N if(buf%N == 0) then ! Only first time call create_selection_buffer(N, N*2, buf) @@ -50,11 +49,7 @@ subroutine run_selection_slave(thread,iproc,energy) else if(N /= buf%N) stop "N changed... wtf man??" end if - !print *, "psi_selectors_coef ", psi_selectors_coef(N_det_selectors-5:N_det_selectors, 1) - !call debug_det(psi_selectors(1,1,N_det_selectors), N_int) - do i_generator=i_generator_start,i_generator_max,step - call select_connected(i_generator,energy,pt2,buf) - enddo + call select_connected(i_generator,energy,pt2,buf,0) endif if(done .or. ctask == size(task_id)) then @@ -117,7 +112,7 @@ subroutine push_selection_results(zmq_socket_push, pt2, b, task_id, ntask) if(rc /= 4*ntask) stop "push" ! Activate is zmq_socket_push is a REQ -! rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) + rc = f77_zmq_recv( zmq_socket_push, task_id(1), ntask*4, 0) end subroutine @@ -151,7 +146,7 @@ subroutine pull_selection_results(zmq_socket_pull, pt2, val, det, N, task_id, nt if(rc /= 4*ntask) stop "pull" ! Activate is zmq_socket_pull is a REP -! rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) + rc = f77_zmq_send( zmq_socket_pull, task_id(1), ntask*4, 0) end subroutine diff --git a/plugins/Full_CI_ZMQ/selection.irp.f b/plugins/Full_CI_ZMQ/selection.irp.f index 6cd0cbe2..c277cf58 100644 --- a/plugins/Full_CI_ZMQ/selection.irp.f +++ b/plugins/Full_CI_ZMQ/selection.irp.f @@ -1,1202 +1,1110 @@ -use bitmasks - - -double precision function integral8(i,j,k,l) - implicit none - - integer, intent(in) :: i,j,k,l - double precision, external :: get_mo_bielec_integral - integer :: ii - ii = l-mo_integrals_cache_min - ii = ior(ii, k-mo_integrals_cache_min) - ii = ior(ii, j-mo_integrals_cache_min) - ii = ior(ii, i-mo_integrals_cache_min) - if (iand(ii, -64) /= 0) then - integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) - else - ii = l-mo_integrals_cache_min - ii = ior( ishft(ii,6), k-mo_integrals_cache_min) - ii = ior( ishft(ii,6), j-mo_integrals_cache_min) - ii = ior( ishft(ii,6), i-mo_integrals_cache_min) - integral8 = mo_integrals_cache(ii) - endif -end function - - -BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] - use bitmasks - implicit none - - integer :: i - do i=1, N_det - call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) - end do -END_PROVIDER - - -subroutine assert(cond, msg) - character(*), intent(in) :: msg - logical, intent(in) :: cond - - if(.not. cond) then - print *, "assert fail: "//msg - stop - end if -end subroutine - - -subroutine get_mask_phase(det, phasemask) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: det(N_int, 2) - integer(1), intent(out) :: phasemask(N_int*bit_kind_size, 2) - integer :: s, ni, i - logical :: change - - phasemask = 0_1 - do s=1,2 - change = .false. - do ni=1,N_int - do i=0,bit_kind_size-1 - if(BTEST(det(ni, s), i)) change = .not. change - if(change) phasemask((ni-1)*bit_kind_size + i + 1, s) = 1_1 - end do - end do - end do -end subroutine - - -subroutine select_connected(i_generator,E0,pt2,b) - use bitmasks - use selection_types - implicit none - integer, intent(in) :: i_generator - type(selection_buffer), intent(inout) :: b - double precision, intent(inout) :: pt2(N_states) - integer :: k,l - double precision, intent(in) :: E0(N_states) - - integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision :: fock_diag_tmp(2,mo_tot_num+1) - - call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) - - do l=1,N_generators_bitmask - do k=1,N_int - hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) - hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) - particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) - particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) - - enddo - call select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - call select_singles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b) - enddo -end subroutine - - -double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) - use bitmasks - implicit none - - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - integer, intent(in) :: s1, s2, h1, h2, p1, p2 - logical :: change - integer(1) :: np - double precision, parameter :: res(0:1) = (/1d0, -1d0/) - - np = phasemask(h1,s1) + phasemask(p1,s1) + phasemask(h2,s2) + phasemask(p2,s2) - if(p1 < h1) np = np + 1_1 - if(p2 < h2) np = np + 1_1 - - if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1_1 - get_phase_bi = res(iand(np,1_1)) -end function - - - -! Selection single -! ---------------- - -subroutine select_singles(i_gen,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - BEGIN_DOC -! Select determinants connected to i_det by H - END_DOC - integer, intent(in) :: i_gen - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: vect(N_states, mo_tot_num) - logical :: bannedOrb(mo_tot_num) - integer :: i, j, k - integer :: h1,h2,s1,s2,i1,i2,ib,sp - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2) - logical :: fullMatch, ok - - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_gen), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_gen), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_gen)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_gen)), particle_mask(k,2)) - enddo - - ! Create lists of holes and particles - ! ----------------------------------- - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - do sp=1,2 - do i=1, N_holes(sp) - h1 = hole_list(i,sp) - call apply_hole(psi_det_generators(1,1,i_gen), sp, h1, mask, ok, N_int) - bannedOrb = .true. - do j=1,N_particles(sp) - bannedOrb(particle_list(j, sp)) = .false. - end do - call spot_hasBeen(mask, sp, psi_det_sorted, i_gen, N_det, bannedOrb, fullMatch) - if(fullMatch) cycle - vect = 0d0 - call splash_p(mask, sp, psi_selectors(1,1,i_gen), psi_phasemask(1,1,i_gen), psi_selectors_coef_transp(1,i_gen), N_det_selectors - i_gen + 1, bannedOrb, vect) - call fill_buffer_single(i_gen, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - end do - enddo -end subroutine - - -subroutine fill_buffer_single(i_generator, sp, h1, bannedOrb, fock_diag_tmp, E0, pt2, vect, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1 - double precision, intent(in) :: vect(N_states, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert, tmp - double precision, external :: diag_H_mat_elem_fock - - - call apply_hole(psi_det_generators(1,1,i_generator), sp, h1, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1)) cycle - if(vect(1, p1) == 0d0) cycle - call apply_particle(mask, sp, p1, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - val = vect(istate, p1) + vect(istate, p1) - delta_E = E0(istate) - Hii - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) += e_pert - if(dabs(e_pert) > dabs(max_e_pert)) max_e_pert = e_pert - end do - - if(dabs(max_e_pert) > buf%mini) call add_to_selection_buffer(buf, det, max_e_pert) - end do -end subroutine - - -subroutine splash_p(mask, sp, det, phasemask, coefs, N_sel, bannedOrb, vect) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int,2,N_sel) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2, N_sel) - double precision, intent(in) :: coefs(N_states, N_sel) - integer, intent(in) :: sp, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - - integer :: i, j, h(0:2,2), p(0:3,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 3) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(nt == 3) then - call get_m2(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else if(nt == 2) then - call get_m1(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - else - call get_m0(det(1,1,i), phasemask(1,1,i), bannedOrb, vect, mask, h, p, sp, coefs(1, i)) - end if - end do -end subroutine - - -subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - integer, parameter :: turn2(2) = (/2,1/) - - if(h(0,sp) == 2) then - h1 = h(1, sp) - h2 = h(2, sp) - do i=1,3 - puti = p(i, sp) - if(bannedOrb(puti)) cycle - p1 = p(turn3_2(1,i), sp) - p2 = p(turn3_2(2,i), sp) - hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) - hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end do - else if(h(0,sp) == 1) then - sfix = turn2(sp) - hfix = h(1,sfix) - pfix = p(1,sfix) - hmob = h(1,sp) - do j=1,2 - puti = p(j, sp) - if(bannedOrb(puti)) cycle - pmob = p(turn2(j), sp) - hij = integral8(pfix, pmob, hfix, hmob) - hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) - vect(:, puti) += hij * coefs - end do - else - puti = p(1,sp) - if(.not. bannedOrb(puti)) then - sfix = turn2(sp) - p1 = p(1,sfix) - p2 = p(2,sfix) - h1 = h(1,sfix) - h2 = h(2,sfix) - hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) - hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) - vect(:, puti) += hij * coefs - end if - end if -end subroutine - - - -subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i, hole, p1, p2, sh - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - double precision, external :: get_phase_bi, integral8 - - lbanned = bannedOrb - sh = 1 - if(h(0,2) == 1) sh = 2 - hole = h(1, sh) - lbanned(p(1,sp)) = .true. - if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. - !print *, "SPm1", sp, sh - - p1 = p(1, sp) - - if(sp == sh) then - p2 = p(2, sp) - lbanned(p2) = .true. - - do i=1,hole-1 - if(lbanned(i)) cycle - hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) - hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - do i=hole+1,mo_tot_num - if(lbanned(i)) cycle - hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) - hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) - vect(:,i) += hij * coefs - end do - - call apply_particle(mask, sp, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p2) += hij * coefs - else - p2 = p(1, sh) - do i=1,mo_tot_num - if(lbanned(i)) cycle - hij = integral8(p1, p2, i, hole) - hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) - vect(:,i) += hij * coefs - end do - end if - - call apply_particle(mask, sp, p1, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, p1) += hij * coefs -end subroutine - - -subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: vect(N_states, mo_tot_num) - integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) - integer :: i - logical :: ok, lbanned(mo_tot_num) - integer(bit_kind) :: det(N_int, 2) - double precision :: hij - - lbanned = bannedOrb - lbanned(p(1,sp)) = .true. - do i=1,mo_tot_num - if(lbanned(i)) cycle - call apply_particle(mask, sp, i, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - vect(:, i) += hij * coefs - end do -end subroutine - - -subroutine spot_hasBeen(mask, sp, det, i_gen, N, banned, fullMatch) - use bitmasks - implicit none - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N, sp - logical, intent(inout) :: banned(mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3), nt - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - nt = 0 - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - nt += popcnt(myMask(j, 1)) + popcnt(myMask(j, 2)) - end do - - if(nt > 3) cycle - - if(nt <= 2 .and. i < i_gen) then - fullMatch = .true. - return - end if - - call bitstring_to_list(myMask(1,sp), list(1), na, N_int) - - if(nt == 3 .and. i < i_gen) then - do j=1,na - banned(list(j)) = .true. - end do - else if(nt == 1 .and. na == 1) then - banned(list(1)) = .true. - end if - end do genl -end subroutine - - - - -! Selection double -! ---------------- - -subroutine select_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator - integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - - double precision :: mat(N_states, mo_tot_num, mo_tot_num) - integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii - integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) - logical :: fullMatch, ok - - integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) - integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) - integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) - - allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) - allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) - - do k=1,N_int - hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) - hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) - particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) - particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) - enddo - - integer :: N_holes(2), N_particles(2) - integer :: hole_list(N_int*bit_kind_size,2) - integer :: particle_list(N_int*bit_kind_size,2) - - call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) - call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) - - - preinteresting(0) = 0 - prefullinteresting(0) = 0 - - do i=1,N_int - negMask(i,1) = not(psi_det_generators(i,1,i_generator)) - negMask(i,2) = not(psi_det_generators(i,2,i_generator)) - end do - - do i=1,N_det - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - if(i <= N_det_selectors) then - preinteresting(0) += 1 - preinteresting(preinteresting(0)) = i - else if(nt <= 2) then - prefullinteresting(0) += 1 - prefullinteresting(prefullinteresting(0)) = i - end if - end if - end do - - - do s1=1,2 - do i1=N_holes(s1),1,-1 ! Generate low excitations first - h1 = hole_list(i1,s1) - call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) - - do i=1,N_int - negMask(i,1) = not(pmask(i,1)) - negMask(i,2) = not(pmask(i,2)) - end do - - interesting(0) = 0 - fullinteresting(0) = 0 - - do ii=1,preinteresting(0) - i = preinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 4) then - interesting(0) += 1 - interesting(interesting(0)) = i - minilist(:,:,interesting(0)) = psi_det_sorted(:,:,i) - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end if - end do - - do ii=1,prefullinteresting(0) - i = prefullinteresting(ii) - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt <= 2) then - fullinteresting(0) += 1 - fullinteresting(fullinteresting(0)) = i - fullminilist(:,:,fullinteresting(0)) = psi_det_sorted(:,:,i) - end if - end do - - do s2=s1,2 - sp = s1 - if(s1 /= s2) sp = 3 - - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=N_holes(s2),ib,-1 ! Generate low excitations first - - h2 = hole_list(i2,s2) - call apply_hole(pmask, s2,h2, mask, ok, N_int) - - logical :: banned(mo_tot_num, mo_tot_num,2) - logical :: bannedOrb(mo_tot_num, 2) - - banned = .false. - - call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) - - if(fullMatch) cycle - - bannedOrb(1:mo_tot_num, 1:2) = .true. - do s3=1,2 - do i=1,N_particles(s3) - bannedOrb(particle_list(i,s3), s3) = .false. - enddo - enddo - - mat = 0d0 - call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - enddo - enddo - enddo - enddo -end subroutine - - -subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) - double precision, intent(in) :: fock_diag_tmp(mo_tot_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp - double precision, external :: diag_H_mat_elem_fock - - logical, external :: detEq - - - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - - do p1=1,mo_tot_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - do p2=ib,mo_tot_num - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - if(mat(1, p1, p2) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - max_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii - val = mat(istate, p1, p2) + mat(istate, p1, p2) - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * ( tmp - delta_E) - pt2(istate) = pt2(istate) + e_pert - max_e_pert = min(e_pert,max_e_pert) - end do - - if(dabs(max_e_pert) > buf%mini) then - call add_to_selection_buffer(buf, det, max_e_pert) - end if - end do - end do -end subroutine - - -subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N_sel) - - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) - integer, intent(in) :: sp, i_gen, N_sel - logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - - integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt - integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) -! logical :: bandon -! -! bandon = .false. - mat = 0d0 - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - do i=1, N_sel ! interesting(0) - !i = interesting(ii) - - nt = 0 - do j=1,N_int - mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) - mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) - nt += popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) - end do - - if(nt > 4) cycle - - do j=1,N_int - perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) - perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) - end do - - call bitstring_to_list(perMask(1,1), h(1,1), h(0,1), N_int) - call bitstring_to_list(perMask(1,2), h(1,2), h(0,2), N_int) - - call bitstring_to_list(mobMask(1,1), p(1,1), p(0,1), N_int) - call bitstring_to_list(mobMask(1,2), p(1,2), p(0,2), N_int) - - if(interesting(i) < i_gen) then - if(nt == 4) call past_d2(banned, p, sp) - if(nt == 3) call past_d1(bannedOrb, p) - else - if(interesting(i) == i_gen) then -! bandon = .true. - if(sp == 3) then - banned(:,:,2) = transpose(banned(:,:,1)) - else - do k=1,mo_tot_num - do l=k+1,mo_tot_num - banned(l,k,1) = banned(k,l,1) - end do - end do - end if - end if - if(nt == 4) then - call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else if(nt == 3) then - call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - else - call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) - end if - end if - end do -end subroutine - - -subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - double precision, external :: get_phase_bi, integral8 - - integer :: i, j, tip, ma, mi, puti, putj - integer :: h1, h2, p1, p2, i1, i2 - double precision :: hij, phase - - integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) - integer, parameter :: turn2(2) = (/2, 1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - bant = 1 - - tip = p(0,1) * p(0,2) - - ma = sp - if(p(0,1) > p(0,2)) ma = 1 - if(p(0,1) < p(0,2)) ma = 2 - mi = mod(ma, 2) + 1 - - if(sp == 3) then - if(ma == 2) bant = 2 - - if(tip == 3) then - puti = p(1, mi) - do i = 1, 3 - putj = p(i, ma) - if(banned(putj,puti,bant)) cycle - i1 = turn3(1,i) - i2 = turn3(2,i) - p1 = p(i1, ma) - p2 = p(i2, ma) - h1 = h(1, ma) - h2 = h(2, ma) - - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - if(ma == 1) then - mat(:, putj, puti) += coefs * hij - else - mat(:, puti, putj) += coefs * hij - end if - end do - else - do i = 1,2 - do j = 1,2 - puti = p(i, 1) - putj = p(j, 2) - - if(banned(puti,putj,bant)) cycle - p1 = p(turn2(i), 1) - p2 = p(turn2(j), 2) - h1 = h(1,1) - h2 = h(1,2) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - end if - - else - if(tip == 0) then - h1 = h(1, ma) - h2 = h(2, ma) - do i=1,3 - puti = p(i, ma) - do j=i+1,4 - putj = p(j, ma) - if(banned(puti,putj,1)) cycle - - i1 = turn2d(1, i, j) - i2 = turn2d(2, i, j) - p1 = p(i1, ma) - p2 = p(i2, ma) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end do - end do - else if(tip == 3) then - h1 = h(1, mi) - h2 = h(1, ma) - p1 = p(1, mi) - do i=1,3 - puti = p(turn3(1,i), ma) - putj = p(turn3(2,i), ma) - if(banned(puti,putj,1)) cycle - p2 = p(i, ma) - - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) - mat(:, min(puti, putj), max(puti, putj)) += coefs * hij - end do - else ! tip == 4 - puti = p(1, sp) - putj = p(2, sp) - if(.not. banned(puti,putj,1)) then - p1 = p(1, mi) - p2 = p(2, mi) - h1 = h(1, mi) - h2 = h(2, mi) - hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) - mat(:, puti, putj) += coefs * hij - end if - end if - end if -end subroutine - - -subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) - integer(1),intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) - double precision, external :: get_phase_bi, integral8 - - logical :: lbanned(mo_tot_num, 2), ok - integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib - - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer, parameter :: turn2(2) = (/2,1/) - integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) - - integer :: bant - - - lbanned = bannedOrb - - do i=1, p(0,1) - lbanned(p(i,1), 1) = .true. - end do - do i=1, p(0,2) - lbanned(p(i,2), 2) = .true. - end do - - ma = 1 - if(p(0,2) >= 2) ma = 2 - mi = turn2(ma) - - bant = 1 - - if(sp == 3) then - !move MA - if(ma == 2) bant = 2 - puti = p(1,mi) - hfix = h(1,ma) - p1 = p(1,ma) - p2 = p(2,ma) - if(.not. bannedOrb(puti, mi)) then - tmp_row = 0d0 - do putj=1, hfix-1 - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - do putj=hfix+1, mo_tot_num - if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(1:N_states,putj) += hij * coefs(1:N_states) - end do - - if(ma == 1) then - mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) - else - mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) - end if - end if - - !MOVE MI - pfix = p(1,mi) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,mi)) cycle - !p1 fixed - putj = p1 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) - tmp_row(:,puti) += hij * coefs - end if - - putj = p2 - if(.not. banned(putj,puti,bant)) then - hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) - tmp_row2(:,puti) += hij * coefs - end if - end do - - if(mi == 1) then - mat(:,:,p1) += tmp_row(:,:) - mat(:,:,p2) += tmp_row2(:,:) - else - mat(:,p1,:) += tmp_row(:,:) - mat(:,p2,:) += tmp_row2(:,:) - end if - else - if(p(0,ma) == 3) then - do i=1,3 - hfix = h(1,ma) - puti = p(i, ma) - p1 = p(turn3(1,i), ma) - p2 = p(turn3(2,i), ma) - tmp_row = 0d0 - do putj=1,hfix-1 - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) - tmp_row(:,putj) += hij * coefs - end do - do putj=hfix+1,mo_tot_num - if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle - hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) - tmp_row(:,putj) += hij * coefs - end do - - mat(:, :puti-1, puti) += tmp_row(:,:puti-1) - mat(:, puti, puti:) += tmp_row(:,puti:) - end do - else - hfix = h(1,mi) - pfix = p(1,mi) - p1 = p(1,ma) - p2 = p(2,ma) - tmp_row = 0d0 - tmp_row2 = 0d0 - do puti=1,mo_tot_num - if(lbanned(puti,ma)) cycle - putj = p2 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) - tmp_row(:,puti) += hij * coefs - end if - - putj = p1 - if(.not. banned(puti,putj,1)) then - hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) - tmp_row2(:,puti) += hij * coefs - end if - end do - mat(:,:p2-1,p2) += tmp_row(:,:p2-1) - mat(:,p2,p2:) += tmp_row(:,p2:) - mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) - mat(:,p1,p1:) += tmp_row2(:,p1:) - end if - end if - - !! MONO - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - - do i1=1,p(0,s1) - ib = 1 - if(s1 == s2) ib = i1+1 - do i2=ib,p(0,s2) - p1 = p(i1,s1) - p2 = p(i2,s2) - if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - mat(:, p1, p2) += coefs * hij - end do - end do -end subroutine - - - - -subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) - use bitmasks - implicit none - - integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) - integer(1), intent(in) :: phasemask(N_int*bit_kind_size, 2) - logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) - integer(bit_kind) :: det(N_int, 2) - double precision, intent(in) :: coefs(N_states) - double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) - integer, intent(in) :: h(0:2,2), p(0:4,2), sp - - integer :: i, j, s, h1, h2, p1, p2, puti, putj - double precision :: hij, phase - double precision, external :: get_phase_bi, integral8 - logical :: ok - - integer :: bant - bant = 1 - - - if(sp == 3) then ! AB - h1 = p(1,1) - h2 = p(1,2) - do p1=1, mo_tot_num - if(bannedOrb(p1, 1)) cycle - do p2=1, mo_tot_num - if(bannedOrb(p2,2)) cycle - if(banned(p1, p2, bant)) cycle ! rentable? - if(p1 == h1 .or. p2 == h2) then - call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) - end if - mat(:, p1, p2) += coefs(:) * hij - end do - end do - else ! AA BB - p1 = p(1,sp) - p2 = p(2,sp) - do puti=1, mo_tot_num - if(bannedOrb(puti, sp)) cycle - do putj=puti+1, mo_tot_num - if(bannedOrb(putj, sp)) cycle - if(banned(puti, putj, bant)) cycle ! rentable? - if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then - call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) - call i_h_j(gen, det, N_int, hij) - else - hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) - end if - mat(:, puti, putj) += coefs(:) * hij - end do - end do - end if -end subroutine - - -subroutine past_d1(bannedOrb, p) - use bitmasks - implicit none - - logical, intent(inout) :: bannedOrb(mo_tot_num, 2) - integer, intent(in) :: p(0:4, 2) - integer :: i,s - - do s = 1, 2 - do i = 1, p(0, s) - bannedOrb(p(i, s), s) = .true. - end do - end do -end subroutine - - -subroutine past_d2(banned, p, sp) - use bitmasks - implicit none - - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - integer, intent(in) :: p(0:4, 2), sp - integer :: i,j - - if(sp == 3) then - do i=1,p(0,1) - do j=1,p(0,2) - banned(p(i,1), p(j,2)) = .true. - end do - end do - else - do i=1,p(0, sp) - do j=1,i-1 - banned(p(j,sp), p(i,sp)) = .true. - banned(p(i,sp), p(j,sp)) = .true. - end do - end do - end if -end subroutine - - - -subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) - use bitmasks - implicit none - - integer, intent(in) :: interesting(0:N) - integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) - integer, intent(in) :: i_gen, N - logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) - logical, intent(out) :: fullMatch - - - integer :: i, j, na, nb, list(3) - integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) - - fullMatch = .false. - - do i=1,N_int - negMask(i,1) = not(mask(i,1)) - negMask(i,2) = not(mask(i,2)) - end do - - genl : do i=1, N - do j=1, N_int - if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl - if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl - end do - - if(interesting(i) < i_gen) then - fullMatch = .true. - return - end if - - do j=1, N_int - myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) - myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) - end do - - call bitstring_to_list(myMask(1,1), list(1), na, N_int) - call bitstring_to_list(myMask(1,2), list(na+1), nb, N_int) - banned(list(1), list(2)) = .true. - end do genl -end subroutine - +use bitmasks + +BEGIN_PROVIDER [ integer, fragment_count ] + implicit none + BEGIN_DOC + ! Number of fragments for the deterministic part + END_DOC + fragment_count = (elec_alpha_num-n_core_orb)**2 +END_PROVIDER + + +double precision function integral8(i,j,k,l) + implicit none + + integer, intent(in) :: i,j,k,l + double precision, external :: get_mo_bielec_integral + integer :: ii + ii = l-mo_integrals_cache_min + ii = ior(ii, k-mo_integrals_cache_min) + ii = ior(ii, j-mo_integrals_cache_min) + ii = ior(ii, i-mo_integrals_cache_min) + if (iand(ii, -64) /= 0) then + integral8 = get_mo_bielec_integral(i,j,k,l,mo_integrals_map) + else + ii = l-mo_integrals_cache_min + ii = ior( ishft(ii,6), k-mo_integrals_cache_min) + ii = ior( ishft(ii,6), j-mo_integrals_cache_min) + ii = ior( ishft(ii,6), i-mo_integrals_cache_min) + integral8 = mo_integrals_cache(ii) + endif +end function + + +BEGIN_PROVIDER [ integer(1), psi_phasemask, (N_int*bit_kind_size, 2, N_det)] + use bitmasks + implicit none + + integer :: i + do i=1, N_det + call get_mask_phase(psi_det_sorted(1,1,i), psi_phasemask(1,1,i)) + end do +END_PROVIDER + + +subroutine assert(cond, msg) + character(*), intent(in) :: msg + logical, intent(in) :: cond + + if(.not. cond) then + print *, "assert failed: "//msg + stop + end if +end subroutine + + +subroutine get_mask_phase(det, phasemask) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: det(N_int, 2) + integer(1), intent(out) :: phasemask(2,N_int*bit_kind_size) + integer :: s, ni, i + logical :: change + + phasemask = 0_1 + do s=1,2 + change = .false. + do ni=1,N_int + do i=0,bit_kind_size-1 + if(BTEST(det(ni, s), i)) change = .not. change + if(change) phasemask(s, (ni-1)*bit_kind_size + i + 1) = 1_1 + end do + end do + end do +end subroutine + + +subroutine select_connected(i_generator,E0,pt2,b,subset) + use bitmasks + use selection_types + implicit none + integer, intent(in) :: i_generator, subset + type(selection_buffer), intent(inout) :: b + double precision, intent(inout) :: pt2(N_states) + integer :: k,l + double precision, intent(in) :: E0(N_states) + + integer(bit_kind) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision :: fock_diag_tmp(2,mo_tot_num+1) + + call build_fock_tmp(fock_diag_tmp,psi_det_generators(1,1,i_generator),N_int) + + do l=1,N_generators_bitmask + do k=1,N_int + hole_mask(k,1) = iand(generators_bitmask(k,1,s_hole,l), psi_det_generators(k,1,i_generator)) + hole_mask(k,2) = iand(generators_bitmask(k,2,s_hole,l), psi_det_generators(k,2,i_generator)) + particle_mask(k,1) = iand(generators_bitmask(k,1,s_part,l), not(psi_det_generators(k,1,i_generator)) ) + particle_mask(k,2) = iand(generators_bitmask(k,2,s_part,l), not(psi_det_generators(k,2,i_generator)) ) + + enddo + call select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,b,subset) + enddo +end subroutine + + +double precision function get_phase_bi(phasemask, s1, s2, h1, p1, h2, p2) + use bitmasks + implicit none + + integer(1), intent(in) :: phasemask(2,*) + integer, intent(in) :: s1, s2, h1, h2, p1, p2 + logical :: change + integer(1) :: np1 + integer :: np + double precision, save :: res(0:1) = (/1d0, -1d0/) + + np1 = phasemask(s1,h1) + phasemask(s1,p1) + phasemask(s2,h2) + phasemask(s2,p2) + np = np1 + if(p1 < h1) np = np + 1 + if(p2 < h2) np = np + 1 + + if(s1 == s2 .and. max(h1, p1) > min(h2, p2)) np = np + 1 + get_phase_bi = res(iand(np,1)) +end + + + +subroutine get_m2(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, j, h1, h2, p1, p2, sfix, hfix, pfix, hmob, pmob, puti + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + integer, parameter :: turn3_2(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + integer, parameter :: turn2(2) = (/2,1/) + + if(h(0,sp) == 2) then + h1 = h(1, sp) + h2 = h(2, sp) + do i=1,3 + puti = p(i, sp) + if(bannedOrb(puti)) cycle + p1 = p(turn3_2(1,i), sp) + p2 = p(turn3_2(2,i), sp) + hij = integral8(p1, p2, h1, h2) - integral8(p2, p1, h1, h2) + hij *= get_phase_bi(phasemask, sp, sp, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end do + else if(h(0,sp) == 1) then + sfix = turn2(sp) + hfix = h(1,sfix) + pfix = p(1,sfix) + hmob = h(1,sp) + do j=1,2 + puti = p(j, sp) + if(bannedOrb(puti)) cycle + pmob = p(turn2(j), sp) + hij = integral8(pfix, pmob, hfix, hmob) + hij *= get_phase_bi(phasemask, sp, sfix, hmob, pmob, hfix, pfix) + vect(:, puti) += hij * coefs + end do + else + puti = p(1,sp) + if(.not. bannedOrb(puti)) then + sfix = turn2(sp) + p1 = p(1,sfix) + p2 = p(2,sfix) + h1 = h(1,sfix) + h2 = h(2,sfix) + hij = (integral8(p1,p2,h1,h2) - integral8(p2,p1,h1,h2)) + hij *= get_phase_bi(phasemask, sfix, sfix, h1, p1, h2, p2) + vect(:, puti) += hij * coefs + end if + end if +end + + + +subroutine get_m1(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i, hole, p1, p2, sh + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + double precision, external :: get_phase_bi, integral8 + + lbanned = bannedOrb + sh = 1 + if(h(0,2) == 1) sh = 2 + hole = h(1, sh) + lbanned(p(1,sp)) = .true. + if(p(0,sp) == 2) lbanned(p(2,sp)) = .true. + !print *, "SPm1", sp, sh + + p1 = p(1, sp) + + if(sp == sh) then + p2 = p(2, sp) + lbanned(p2) = .true. + + do i=1,hole-1 + if(lbanned(i)) cycle + hij = (integral8(p1, p2, i, hole) - integral8(p2, p1, i, hole)) + hij *= get_phase_bi(phasemask, sp, sp, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + do i=hole+1,mo_tot_num + if(lbanned(i)) cycle + hij = (integral8(p1, p2, hole, i) - integral8(p2, p1, hole, i)) + hij *= get_phase_bi(phasemask, sp, sp, hole, p1, i, p2) + vect(:,i) += hij * coefs + end do + + call apply_particle(mask, sp, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p2) += hij * coefs + else + p2 = p(1, sh) + do i=1,mo_tot_num + if(lbanned(i)) cycle + hij = integral8(p1, p2, i, hole) + hij *= get_phase_bi(phasemask, sp, sh, i, p1, hole, p2) + vect(:,i) += hij * coefs + end do + end if + + call apply_particle(mask, sp, p1, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, p1) += hij * coefs +end + + +subroutine get_m0(gen, phasemask, bannedOrb, vect, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: vect(N_states, mo_tot_num) + integer, intent(in) :: sp, h(0:2, 2), p(0:3, 2) + integer :: i + logical :: ok, lbanned(mo_tot_num) + integer(bit_kind) :: det(N_int, 2) + double precision :: hij + + lbanned = bannedOrb + lbanned(p(1,sp)) = .true. + do i=1,mo_tot_num + if(lbanned(i)) cycle + call apply_particle(mask, sp, i, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + vect(:, i) += hij * coefs + end do +end + +subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_diag_tmp,E0,pt2,buf,subset) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, subset + integer(bit_kind), intent(in) :: hole_mask(N_int,2), particle_mask(N_int,2) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + + double precision :: mat(N_states, mo_tot_num, mo_tot_num) + integer :: h1,h2,s1,s2,s3,i1,i2,ib,sp,k,i,j,nt,ii + integer(bit_kind) :: hole(N_int,2), particle(N_int,2), mask(N_int, 2), pmask(N_int, 2) + logical :: fullMatch, ok + + integer(bit_kind) :: mobMask(N_int, 2), negMask(N_int, 2) + integer,allocatable :: preinteresting(:), prefullinteresting(:), interesting(:), fullinteresting(:) + integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) + + logical :: monoAdo, monoBdo; + integer :: maskInd + + PROVIDE fragment_count + + monoAdo = .true. + monoBdo = .true. + + allocate(minilist(N_int, 2, N_det_selectors), fullminilist(N_int, 2, N_det)) + allocate(preinteresting(0:N_det_selectors), prefullinteresting(0:N_det), interesting(0:N_det_selectors), fullinteresting(0:N_det)) + + do k=1,N_int + hole (k,1) = iand(psi_det_generators(k,1,i_generator), hole_mask(k,1)) + hole (k,2) = iand(psi_det_generators(k,2,i_generator), hole_mask(k,2)) + particle(k,1) = iand(not(psi_det_generators(k,1,i_generator)), particle_mask(k,1)) + particle(k,2) = iand(not(psi_det_generators(k,2,i_generator)), particle_mask(k,2)) + enddo + + integer :: N_holes(2), N_particles(2) + integer :: hole_list(N_int*bit_kind_size,2) + integer :: particle_list(N_int*bit_kind_size,2) + + call bitstring_to_list_ab(hole , hole_list , N_holes , N_int) + call bitstring_to_list_ab(particle, particle_list, N_particles, N_int) + +! ! ====== +! ! If the subset doesn't exist, return +! logical :: will_compute +! will_compute = subset == 0 +! +! if (.not.will_compute) then +! maskInd = N_holes(1)*N_holes(2) + N_holes(2)*((N_holes(2)-1)/2) + N_holes(1)*((N_holes(1)-1)/2) +! will_compute = (maskInd >= subset) +! if (.not.will_compute) then +! return +! endif +! endif +! ! ====== + + + integer(bit_kind), allocatable:: preinteresting_det(:,:,:) + allocate (preinteresting_det(N_int,2,N_det)) + + preinteresting(0) = 0 + prefullinteresting(0) = 0 + + do i=1,N_int + negMask(i,1) = not(psi_det_generators(i,1,i_generator)) + negMask(i,2) = not(psi_det_generators(i,2,i_generator)) + end do + + do i=1,N_det + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + if(i <= N_det_selectors) then + preinteresting(0) += 1 + preinteresting(preinteresting(0)) = i + do j=1,N_int + preinteresting_det(j,1,preinteresting(0)) = psi_det_sorted(j,1,i) + preinteresting_det(j,2,preinteresting(0)) = psi_det_sorted(j,2,i) + enddo + else if(nt <= 2) then + prefullinteresting(0) += 1 + prefullinteresting(prefullinteresting(0)) = i + end if + end if + end do + + + maskInd = -1 + integer :: nb_count + do s1=1,2 + do i1=N_holes(s1),1,-1 ! Generate low excitations first + h1 = hole_list(i1,s1) + call apply_hole(psi_det_generators(1,1,i_generator), s1,h1, pmask, ok, N_int) + + negMask = not(pmask) + + interesting(0) = 0 + fullinteresting(0) = 0 + + do ii=1,preinteresting(0) + i = preinteresting(ii) + mobMask(1,1) = iand(negMask(1,1), preinteresting_det(1,1,ii)) + mobMask(1,2) = iand(negMask(1,2), preinteresting_det(1,2,ii)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), preinteresting_det(j,1,ii)) + mobMask(j,2) = iand(negMask(j,2), preinteresting_det(j,2,ii)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 4) then + interesting(0) += 1 + interesting(interesting(0)) = i + minilist(1,1,interesting(0)) = preinteresting_det(1,1,ii) + minilist(1,2,interesting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + minilist(j,1,interesting(0)) = preinteresting_det(j,1,ii) + minilist(j,2,interesting(0)) = preinteresting_det(j,2,ii) + enddo + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(1,1,fullinteresting(0)) = preinteresting_det(1,1,ii) + fullminilist(1,2,fullinteresting(0)) = preinteresting_det(1,2,ii) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = preinteresting_det(j,1,ii) + fullminilist(j,2,fullinteresting(0)) = preinteresting_det(j,2,ii) + enddo + end if + end if + end do + + do ii=1,prefullinteresting(0) + i = prefullinteresting(ii) + nt = 0 + mobMask(1,1) = iand(negMask(1,1), psi_det_sorted(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), psi_det_sorted(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), psi_det_sorted(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), psi_det_sorted(j,2,i)) + nt = nt+ popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt <= 2) then + fullinteresting(0) += 1 + fullinteresting(fullinteresting(0)) = i + fullminilist(1,1,fullinteresting(0)) = psi_det_sorted(1,1,i) + fullminilist(1,2,fullinteresting(0)) = psi_det_sorted(1,2,i) + do j=2,N_int + fullminilist(j,1,fullinteresting(0)) = psi_det_sorted(j,1,i) + fullminilist(j,2,fullinteresting(0)) = psi_det_sorted(j,2,i) + enddo + end if + end do + + + + do s2=s1,2 + sp = s1 + + if(s1 /= s2) sp = 3 + + ib = 1 + if(s1 == s2) ib = i1+1 + monoAdo = .true. + do i2=N_holes(s2),ib,-1 ! Generate low excitations first + logical :: banned(mo_tot_num, mo_tot_num,2) + logical :: bannedOrb(mo_tot_num, 2) + + h2 = hole_list(i2,s2) + call apply_hole(pmask, s2,h2, mask, ok, N_int) + banned = .false. + do j=1,mo_tot_num + bannedOrb(j, 1) = .true. + bannedOrb(j, 2) = .true. + enddo + do s3=1,2 + do i=1,N_particles(s3) + bannedOrb(particle_list(i,s3), s3) = .false. + enddo + enddo + if(s1 /= s2) then + if(monoBdo) then + bannedOrb(h1,s1) = .false. + end if + if(monoAdo) then + bannedOrb(h2,s2) = .false. + monoAdo = .false. + end if + end if + + maskInd += 1 + if(subset == 0 .or. mod(maskInd, fragment_count) == (subset-1)) then + + call spot_isinwf(mask, fullminilist, i_generator, fullinteresting(0), banned, fullMatch, fullinteresting) + if(fullMatch) cycle + + mat = 0d0 + call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) + + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + end if + enddo + if(s1 /= s2) monoBdo = .false. + enddo + enddo + enddo +end subroutine + + + +subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, mat, buf) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_tot_num, mo_tot_num) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num) + double precision, intent(in) :: fock_diag_tmp(mo_tot_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, max_e_pert,tmp + double precision, external :: diag_H_mat_elem_fock + + logical, external :: detEq + + + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + + do p1=1,mo_tot_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + do p2=ib,mo_tot_num + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + if(mat(1, p1, p2) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + max_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + val = mat(istate, p1, p2) + mat(istate, p1, p2) + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * ( tmp - delta_E) + pt2(istate) = pt2(istate) + e_pert + max_e_pert = min(e_pert,max_e_pert) +! ci(istate) = e_pert / mat(istate, p1, p2) + end do + + if(dabs(max_e_pert) > buf%mini) then + call add_to_selection_buffer(buf, det, max_e_pert) + end if + end do + end do +end + + +subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) + use bitmasks + implicit none + + integer, intent(in) :: sp, i_gen, N_sel + integer, intent(in) :: interesting(0:N_sel) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N_sel) + logical, intent(inout) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num, 2) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + + integer :: i, ii, j, k, l, h(0:2,2), p(0:4,2), nt + integer(bit_kind) :: perMask(N_int, 2), mobMask(N_int, 2), negMask(N_int, 2) +! logical :: bandon +! +! bandon = .false. + PROVIDE psi_phasemask psi_selectors_coef_transp + mat = 0d0 + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + do i=1, N_sel ! interesting(0) + !i = interesting(ii) + if (interesting(i) < 0) then + stop 'prefetch interesting(i)' + endif + + + mobMask(1,1) = iand(negMask(1,1), det(1,1,i)) + mobMask(1,2) = iand(negMask(1,2), det(1,2,i)) + nt = popcnt(mobMask(1, 1)) + popcnt(mobMask(1, 2)) + + if(nt > 4) cycle + + do j=2,N_int + mobMask(j,1) = iand(negMask(j,1), det(j,1,i)) + mobMask(j,2) = iand(negMask(j,2), det(j,2,i)) + nt = nt + popcnt(mobMask(j, 1)) + popcnt(mobMask(j, 2)) + end do + + if(nt > 4) cycle + + if (interesting(i) == i_gen) then + if(sp == 3) then + do j=1,mo_tot_num + do k=1,mo_tot_num + banned(j,k,2) = banned(k,j,1) + enddo + enddo + else + do k=1,mo_tot_num + do l=k+1,mo_tot_num + banned(l,k,1) = banned(k,l,1) + end do + end do + end if + end if + + call bitstring_to_list_in_selection(mobMask(1,1), p(1,1), p(0,1), N_int) + call bitstring_to_list_in_selection(mobMask(1,2), p(1,2), p(0,2), N_int) + + perMask(1,1) = iand(mask(1,1), not(det(1,1,i))) + perMask(1,2) = iand(mask(1,2), not(det(1,2,i))) + do j=2,N_int + perMask(j,1) = iand(mask(j,1), not(det(j,1,i))) + perMask(j,2) = iand(mask(j,2), not(det(j,2,i))) + end do + + call bitstring_to_list_in_selection(perMask(1,1), h(1,1), h(0,1), N_int) + call bitstring_to_list_in_selection(perMask(1,2), h(1,2), h(0,2), N_int) + + if (interesting(i) >= i_gen) then + if(nt == 4) then + call get_d2(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else if(nt == 3) then + call get_d1(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + else + call get_d0(det(1,1,i), psi_phasemask(1,1,interesting(i)), bannedOrb, banned, mat, mask, h, p, sp, psi_selectors_coef_transp(1, interesting(i))) + end if + else + if(nt == 4) call past_d2(banned, p, sp) + if(nt == 3) call past_d1(bannedOrb, p) + end if + end do +end + + +subroutine get_d2(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + double precision, external :: get_phase_bi, integral8 + + integer :: i, j, tip, ma, mi, puti, putj + integer :: h1, h2, p1, p2, i1, i2 + double precision :: hij, phase + + integer, parameter:: turn2d(2,3,4) = reshape((/0,0, 0,0, 0,0, 3,4, 0,0, 0,0, 2,4, 1,4, 0,0, 2,3, 1,3, 1,2 /), (/2,3,4/)) + integer, parameter :: turn2(2) = (/2, 1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + bant = 1 + + tip = p(0,1) * p(0,2) + + ma = sp + if(p(0,1) > p(0,2)) ma = 1 + if(p(0,1) < p(0,2)) ma = 2 + mi = mod(ma, 2) + 1 + + if(sp == 3) then + if(ma == 2) bant = 2 + + if(tip == 3) then + puti = p(1, mi) + do i = 1, 3 + putj = p(i, ma) + if(banned(putj,puti,bant)) cycle + i1 = turn3(1,i) + i2 = turn3(2,i) + p1 = p(i1, ma) + p2 = p(i2, ma) + h1 = h(1, ma) + h2 = h(2, ma) + + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + if(ma == 1) then + mat(:, putj, puti) += coefs * hij + else + mat(:, puti, putj) += coefs * hij + end if + end do + else + h1 = h(1,1) + h2 = h(1,2) + do j = 1,2 + putj = p(j, 2) + p2 = p(turn2(j), 2) + do i = 1,2 + puti = p(i, 1) + + if(banned(puti,putj,bant)) cycle + p1 = p(turn2(i), 1) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + end if + + else + if(tip == 0) then + h1 = h(1, ma) + h2 = h(2, ma) + do i=1,3 + puti = p(i, ma) + do j=i+1,4 + putj = p(j, ma) + if(banned(puti,putj,1)) cycle + + i1 = turn2d(1, i, j) + i2 = turn2d(2, i, j) + p1 = p(i1, ma) + p2 = p(i2, ma) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, ma, ma, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end do + end do + else if(tip == 3) then + h1 = h(1, mi) + h2 = h(1, ma) + p1 = p(1, mi) + do i=1,3 + puti = p(turn3(1,i), ma) + putj = p(turn3(2,i), ma) + if(banned(puti,putj,1)) cycle + p2 = p(i, ma) + + hij = integral8(p1, p2, h1, h2) * get_phase_bi(phasemask, mi, ma, h1, p1, h2, p2) + mat(:, min(puti, putj), max(puti, putj)) += coefs * hij + end do + else ! tip == 4 + puti = p(1, sp) + putj = p(2, sp) + if(.not. banned(puti,putj,1)) then + p1 = p(1, mi) + p2 = p(2, mi) + h1 = h(1, mi) + h2 = h(2, mi) + hij = (integral8(p1, p2, h1, h2) - integral8(p2,p1, h1, h2)) * get_phase_bi(phasemask, mi, mi, h1, p1, h2, p2) + mat(:, puti, putj) += coefs * hij + end if + end if + end if +end + + +subroutine get_d1(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: mask(N_int, 2), gen(N_int, 2) + integer(1),intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + double precision :: hij, tmp_row(N_states, mo_tot_num), tmp_row2(N_states, mo_tot_num) + double precision, external :: get_phase_bi, integral8 + + logical :: lbanned(mo_tot_num, 2), ok + integer :: puti, putj, ma, mi, s1, s2, i, i1, i2, j, hfix, pfix, h1, h2, p1, p2, ib + + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer, parameter :: turn2(2) = (/2,1/) + integer, parameter :: turn3(2,3) = reshape((/2,3, 1,3, 1,2/), (/2,3/)) + + integer :: bant + + + lbanned = bannedOrb + + do i=1, p(0,1) + lbanned(p(i,1), 1) = .true. + end do + do i=1, p(0,2) + lbanned(p(i,2), 2) = .true. + end do + + ma = 1 + if(p(0,2) >= 2) ma = 2 + mi = turn2(ma) + + bant = 1 + + if(sp == 3) then + !move MA + if(ma == 2) bant = 2 + puti = p(1,mi) + hfix = h(1,ma) + p1 = p(1,ma) + p2 = p(2,ma) + if(.not. bannedOrb(puti, mi)) then + tmp_row = 0d0 + do putj=1, hfix-1 + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + do putj=hfix+1, mo_tot_num + if(lbanned(putj, ma) .or. banned(putj, puti,bant)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(1:N_states,putj) += hij * coefs(1:N_states) + end do + + if(ma == 1) then + mat(1:N_states,1:mo_tot_num,puti) += tmp_row(1:N_states,1:mo_tot_num) + else + mat(1:N_states,puti,1:mo_tot_num) += tmp_row(1:N_states,1:mo_tot_num) + end if + end if + + !MOVE MI + pfix = p(1,mi) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,mi)) cycle + !p1 fixed + putj = p1 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p2,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p2, puti, pfix) + tmp_row(:,puti) += hij * coefs + end if + + putj = p2 + if(.not. banned(putj,puti,bant)) then + hij = integral8(p1,pfix,hfix,puti) * get_phase_bi(phasemask, ma, mi, hfix, p1, puti, pfix) + tmp_row2(:,puti) += hij * coefs + end if + end do + + if(mi == 1) then + mat(:,:,p1) += tmp_row(:,:) + mat(:,:,p2) += tmp_row2(:,:) + else + mat(:,p1,:) += tmp_row(:,:) + mat(:,p2,:) += tmp_row2(:,:) + end if + else + if(p(0,ma) == 3) then + do i=1,3 + hfix = h(1,ma) + puti = p(i, ma) + p1 = p(turn3(1,i), ma) + p2 = p(turn3(2,i), ma) + tmp_row = 0d0 + do putj=1,hfix-1 + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, putj, hfix)-integral8(p2,p1,putj,hfix)) * get_phase_bi(phasemask, ma, ma, putj, p1, hfix, p2) + tmp_row(:,putj) += hij * coefs + end do + do putj=hfix+1,mo_tot_num + if(lbanned(putj,ma) .or. banned(puti,putj,1)) cycle + hij = (integral8(p1, p2, hfix, putj)-integral8(p2,p1,hfix,putj)) * get_phase_bi(phasemask, ma, ma, hfix, p1, putj, p2) + tmp_row(:,putj) += hij * coefs + end do + + mat(:, :puti-1, puti) += tmp_row(:,:puti-1) + mat(:, puti, puti:) += tmp_row(:,puti:) + end do + else + hfix = h(1,mi) + pfix = p(1,mi) + p1 = p(1,ma) + p2 = p(2,ma) + tmp_row = 0d0 + tmp_row2 = 0d0 + do puti=1,mo_tot_num + if(lbanned(puti,ma)) cycle + putj = p2 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p1, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p1) + tmp_row(:,puti) += hij * coefs + end if + + putj = p1 + if(.not. banned(puti,putj,1)) then + hij = integral8(pfix, p2, hfix, puti) * get_phase_bi(phasemask, mi, ma, hfix, pfix, puti, p2) + tmp_row2(:,puti) += hij * coefs + end if + end do + mat(:,:p2-1,p2) += tmp_row(:,:p2-1) + mat(:,p2,p2:) += tmp_row(:,p2:) + mat(:,:p1-1,p1) += tmp_row2(:,:p1-1) + mat(:,p1,p1:) += tmp_row2(:,p1:) + end if + end if + + !! MONO + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + + do i1=1,p(0,s1) + ib = 1 + if(s1 == s2) ib = i1+1 + do i2=ib,p(0,s2) + p1 = p(i1,s1) + p2 = p(i2,s2) + if(bannedOrb(p1, s1) .or. bannedOrb(p2, s2) .or. banned(p1, p2, 1)) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + mat(:, p1, p2) += coefs * hij + end do + end do +end + + + + +subroutine get_d0(gen, phasemask, bannedOrb, banned, mat, mask, h, p, sp, coefs) + use bitmasks + implicit none + + integer(bit_kind), intent(in) :: gen(N_int, 2), mask(N_int, 2) + integer(1), intent(in) :: phasemask(2,N_int*bit_kind_size) + logical, intent(in) :: bannedOrb(mo_tot_num, 2), banned(mo_tot_num, mo_tot_num,2) + integer(bit_kind) :: det(N_int, 2) + double precision, intent(in) :: coefs(N_states) + double precision, intent(inout) :: mat(N_states, mo_tot_num, mo_tot_num) + integer, intent(in) :: h(0:2,2), p(0:4,2), sp + + integer :: i, j, s, h1, h2, p1, p2, puti, putj + double precision :: hij, phase + double precision, external :: get_phase_bi, integral8 + logical :: ok + + integer :: bant + bant = 1 + + + if(sp == 3) then ! AB + h1 = p(1,1) + h2 = p(1,2) + do p1=1, mo_tot_num + if(bannedOrb(p1, 1)) cycle + do p2=1, mo_tot_num + if(bannedOrb(p2,2)) cycle + if(banned(p1, p2, bant)) cycle ! rentable? + if(p1 == h1 .or. p2 == h2) then + call apply_particles(mask, 1,p1,2,p2, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + phase = get_phase_bi(phasemask, 1, 2, h1, p1, h2, p2) + hij = integral8(p1, p2, h1, h2) * phase + end if + mat(:, p1, p2) += coefs(:) * hij + end do + end do + else ! AA BB + p1 = p(1,sp) + p2 = p(2,sp) + do puti=1, mo_tot_num + if(bannedOrb(puti, sp)) cycle + do putj=puti+1, mo_tot_num + if(bannedOrb(putj, sp)) cycle + if(banned(puti, putj, bant)) cycle ! rentable? + if(puti == p1 .or. putj == p2 .or. puti == p2 .or. putj == p1) then + call apply_particles(mask, sp,puti,sp,putj, det, ok, N_int) + call i_h_j(gen, det, N_int, hij) + else + hij = (integral8(p1, p2, puti, putj) - integral8(p2, p1, puti, putj))* get_phase_bi(phasemask, sp, sp, puti, p1 , putj, p2) + end if + mat(:, puti, putj) += coefs(:) * hij + end do + end do + end if +end + + +subroutine past_d1(bannedOrb, p) + use bitmasks + implicit none + + logical, intent(inout) :: bannedOrb(mo_tot_num, 2) + integer, intent(in) :: p(0:4, 2) + integer :: i,s + + do s = 1, 2 + do i = 1, p(0, s) + bannedOrb(p(i, s), s) = .true. + end do + end do +end + + +subroutine past_d2(banned, p, sp) + use bitmasks + implicit none + + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + integer, intent(in) :: p(0:4, 2), sp + integer :: i,j + + if(sp == 3) then + do i=1,p(0,1) + do j=1,p(0,2) + banned(p(i,1), p(j,2)) = .true. + end do + end do + else + do i=1,p(0, sp) + do j=1,i-1 + banned(p(j,sp), p(i,sp)) = .true. + banned(p(i,sp), p(j,sp)) = .true. + end do + end do + end if +end + + + +subroutine spot_isinwf(mask, det, i_gen, N, banned, fullMatch, interesting) + use bitmasks + implicit none + + integer, intent(in) :: i_gen, N + integer, intent(in) :: interesting(0:N) + integer(bit_kind),intent(in) :: mask(N_int, 2), det(N_int, 2, N) + logical, intent(inout) :: banned(mo_tot_num, mo_tot_num) + logical, intent(out) :: fullMatch + + + integer :: i, j, na, nb, list(3) + integer(bit_kind) :: myMask(N_int, 2), negMask(N_int, 2) + + fullMatch = .false. + + do i=1,N_int + negMask(i,1) = not(mask(i,1)) + negMask(i,2) = not(mask(i,2)) + end do + + genl : do i=1, N + do j=1, N_int + if(iand(det(j,1,i), mask(j,1)) /= mask(j, 1)) cycle genl + if(iand(det(j,2,i), mask(j,2)) /= mask(j, 2)) cycle genl + end do + + if(interesting(i) < i_gen) then + fullMatch = .true. + return + end if + + do j=1, N_int + myMask(j, 1) = iand(det(j, 1, i), negMask(j, 1)) + myMask(j, 2) = iand(det(j, 2, i), negMask(j, 2)) + end do + + call bitstring_to_list_in_selection(myMask(1,1), list(1), na, N_int) + call bitstring_to_list_in_selection(myMask(1,2), list(na+1), nb, N_int) + banned(list(1), list(2)) = .true. + end do genl +end + + +subroutine bitstring_to_list_in_selection( string, list, n_elements, Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Gives the inidices(+1) of the bits set to 1 in the bit string + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: string(Nint) + integer, intent(out) :: list(Nint*bit_kind_size) + integer, intent(out) :: n_elements + + integer :: i, ishift + integer(bit_kind) :: l + + n_elements = 0 + ishift = 2 + do i=1,Nint + l = string(i) + do while (l /= 0_bit_kind) + n_elements = n_elements+1 + list(n_elements) = ishift+popcnt(l-1_bit_kind) - popcnt(l) + l = iand(l,l-1_bit_kind) + enddo + ishift = ishift + bit_kind_size + enddo + +end diff --git a/plugins/Full_CI_ZMQ/selection_slave.irp.f b/plugins/Full_CI_ZMQ/selection_slave.irp.f index 657ad63c..92c6b775 100644 --- a/plugins/Full_CI_ZMQ/selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/selection_slave.irp.f @@ -13,7 +13,7 @@ end subroutine provide_everything PROVIDE H_apply_buffer_allocated mo_bielec_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context - PROVIDE pt2_e0_denominator mo_tot_num N_int + PROVIDE pt2_e0_denominator mo_tot_num N_int fragment_count end subroutine run_wf @@ -60,28 +60,6 @@ subroutine run_wf end do end -subroutine update_energy(energy) - implicit none - double precision, intent(in) :: energy(N_states) - BEGIN_DOC -! Update energy when it is received from ZMQ - END_DOC - integer :: j,k - do j=1,N_states - do k=1,N_det - CI_eigenvectors(k,j) = psi_coef(k,j) - enddo - enddo - call u_0_S2_u_0(CI_eigenvectors_s2,CI_eigenvectors,N_det,psi_det,N_int) - if (.True.) then - do k=1,N_states - ci_electronic_energy(k) = energy(k) - enddo - TOUCH ci_electronic_energy CI_eigenvectors_s2 CI_eigenvectors - endif - - call write_double(6,ci_energy,'Energy') -end subroutine selection_slave_tcp(i,energy) implicit none diff --git a/plugins/Full_CI_ZMQ/selection_types.f90 b/plugins/Full_CI_ZMQ/selection_types.f90 index 9506629c..29e48524 100644 --- a/plugins/Full_CI_ZMQ/selection_types.f90 +++ b/plugins/Full_CI_ZMQ/selection_types.f90 @@ -1,9 +1,9 @@ module selection_types type selection_buffer integer :: N, cur - integer(8), allocatable :: det(:,:,:) - double precision, allocatable :: val(:) - double precision :: mini + integer(8) , pointer :: det(:,:,:) + double precision, pointer :: val(:) + double precision :: mini endtype end module diff --git a/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f new file mode 100644 index 00000000..04a1d9d4 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_ratio_zmq.irp.f @@ -0,0 +1,109 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref + + double precision, allocatable :: psi_coef_ref(:,:) + integer(bit_kind), allocatable :: psi_det_ref(:,:,:) + + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + ! Stopping criterion is the PT2max + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = 2 + allocate (psi_coef_ref(size(psi_coef_sorted,1),size(psi_coef_sorted,2))) + allocate (psi_det_ref(N_int,2,size(psi_det_sorted,3))) + psi_coef_ref = psi_coef_sorted + psi_det_ref = psi_det_sorted + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + do while (Nmax-Nmin > 1) + psi_coef = psi_coef_ref + psi_det = psi_det_ref + TOUCH psi_det psi_coef + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + if (ratio < var_pt2_ratio) then + Nmin = N_det + else + Nmax = N_det + psi_coef_ref = psi_coef + psi_det_ref = psi_det + TOUCH psi_det psi_coef + endif + N_det = Nmin + (Nmax-Nmin)/2 + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', var_pt2_ratio + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + call save_wavefunction + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + print *, 'E+PT2 = ', CI_energy(1)+pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) +end + + + + diff --git a/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f new file mode 100644 index 00000000..52f825f1 --- /dev/null +++ b/plugins/Full_CI_ZMQ/target_pt2_zmq.irp.f @@ -0,0 +1,95 @@ +program fci_zmq + implicit none + integer :: i,j,k + logical, external :: detEq + + double precision, allocatable :: pt2(:) + integer :: Nmin, Nmax + integer :: n_det_before, to_select + double precision :: threshold_davidson_in, ratio, E_ref, pt2_ratio + + allocate (pt2(N_states)) + + pt2 = 1.d0 + threshold_davidson_in = threshold_davidson + threshold_davidson = threshold_davidson_in * 100.d0 + SOFT_TOUCH threshold_davidson + + double precision :: E_CI_before(N_states) + do while (dabs(pt2(1)) > pt2_max) + print *, 'N_det = ', N_det + print *, 'N_states = ', N_states + do k=1, N_states + print*,'State ',k + print *, 'PT2 = ', pt2(k) + print *, 'E = ', CI_energy(k) + print *, 'E(before)+PT2 = ', E_CI_before(k)+pt2(k) + enddo + print *, '-----' + E_CI_before(1:N_states) = CI_energy(1:N_states) + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + + n_det_before = N_det + to_select = N_det + to_select = max(64-to_select, to_select) + call ZMQ_selection(to_select, pt2) + + PROVIDE psi_coef + PROVIDE psi_det + PROVIDE psi_det_sorted + + call diagonalize_CI + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + enddo + + threshold_selectors = max(threshold_selectors,threshold_selectors_pt2) + threshold_generators = max(threshold_generators,threshold_generators_pt2) + threshold_davidson = threshold_davidson_in + TOUCH threshold_selectors threshold_generators threshold_davidson + call diagonalize_CI + call ZMQ_selection(0, pt2) + + E_ref = CI_energy(1) + pt2(1) + pt2_ratio = (E_ref + pt2_max - HF_energy) / (E_ref - HF_energy) + print *, 'Est FCI = ', E_ref + + Nmax = N_det + Nmin = N_det/8 + do while (Nmax-Nmin > 1) + call diagonalize_CI + ratio = (CI_energy(1) - HF_energy) / (E_ref - HF_energy) + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + TOUCH psi_coef psi_det + if (ratio < pt2_ratio) then + Nmin = N_det + to_select = (Nmax-Nmin)/2 + call ZMQ_selection(to_select, pt2) + else + Nmax = N_det + N_det = Nmin + (Nmax-Nmin)/2 + endif + print *, '-----' + print *, 'Det min, Det max: ', Nmin, Nmax + print *, 'Ratio : ', ratio, ' ~ ', pt2_ratio + print *, 'HF_energy = ', HF_energy + print *, 'Est FCI = ', E_ref + print *, 'N_det = ', N_det + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + enddo + call ZMQ_selection(0, pt2) + print *, '------' + print *, 'E = ', CI_energy(1) + print *, 'PT2 = ', pt2(1) + + E_CI_before(1:N_states) = CI_energy(1:N_states) + call save_wavefunction + call ezfio_set_full_ci_zmq_energy(CI_energy(1)) + call ezfio_set_full_ci_zmq_energy_pt2(E_CI_before(1)+pt2(1)) +end + + + + diff --git a/plugins/Generators_CAS/.gitignore b/plugins/Generators_CAS/.gitignore deleted file mode 100644 index 1b17a42a..00000000 --- a/plugins/Generators_CAS/.gitignore +++ /dev/null @@ -1,23 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -Nuclei -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_full/.gitignore b/plugins/Generators_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Generators_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Generators_restart/.gitignore b/plugins/Generators_restart/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/Generators_restart/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/Hartree_Fock/.gitignore b/plugins/Hartree_Fock/.gitignore deleted file mode 100644 index 9f1c0929..00000000 --- a/plugins/Hartree_Fock/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -Huckel_guess -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -SCF -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/Hartree_Fock/localize_mos.irp.f b/plugins/Hartree_Fock/localize_mos.irp.f new file mode 100644 index 00000000..8a665c64 --- /dev/null +++ b/plugins/Hartree_Fock/localize_mos.irp.f @@ -0,0 +1,75 @@ +program localize_mos + implicit none + integer :: rank, i,j,k + double precision, allocatable :: W(:,:) + double precision :: f, f_incr + + allocate (W(ao_num,ao_num)) + + W = 0.d0 + do k=1,elec_beta_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,elec_beta_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,elec_beta_num,W, size(W,1), & + mo_coef(1,1),size(mo_coef,1),1.d-6,rank) + print *, rank + + if (elec_alpha_num>elec_alpha_num) then + W = 0.d0 + do k=elec_beta_num+1,elec_alpha_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,elec_alpha_num-elec_beta_num,W, size(W,1), & + mo_coef(1,elec_beta_num+1),size(mo_coef,1),1.d-6,rank) + print *, rank + endif + + W = 0.d0 + do k=elec_alpha_num+1,mo_tot_num + do j=1,ao_num + do i=1,ao_num + W(i,j) = W(i,j) + mo_coef(i,k) * mo_coef(j,k) + enddo + enddo + enddo + +! call svd_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), & +! mo_coef(1,1),size(mo_coef,1)) + call cholesky_mo(ao_num,mo_tot_num-elec_alpha_num,W, size(W,1), & + mo_coef(1,elec_alpha_num+1),size(mo_coef,1),1.d-6,rank) + print *, rank + mo_label = "Localized" + + TOUCH mo_coef + + W(1:ao_num,1:mo_tot_num) = mo_coef(1:ao_num,1:mo_tot_num) + integer :: iorder(mo_tot_num) + double precision :: s(mo_tot_num), swap(ao_num) + do k=1,mo_tot_num + iorder(k) = k + s(k) = Fock_matrix_diag_mo(k) + enddo + call dsort(s(1),iorder(1),elec_beta_num) + call dsort(s(elec_beta_num+1),iorder(elec_beta_num+1),elec_alpha_num-elec_beta_num) + call dsort(s(elec_alpha_num+1),iorder(elec_alpha_num+1),mo_tot_num-elec_alpha_num) + do k=1,mo_tot_num + mo_coef(1:ao_num,k) = W(1:ao_num,iorder(k)) + print *, k, s(k) + enddo + call save_mos + +end diff --git a/plugins/MP2/.gitignore b/plugins/MP2/.gitignore deleted file mode 100644 index 82d50427..00000000 --- a/plugins/MP2/.gitignore +++ /dev/null @@ -1,31 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -SingleRefMethod -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mp2 -mp2_wf -tags \ No newline at end of file diff --git a/plugins/MRCC_Utils/.gitignore b/plugins/MRCC_Utils/.gitignore deleted file mode 100644 index 7a0dd517..00000000 --- a/plugins/MRCC_Utils/.gitignore +++ /dev/null @@ -1,33 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Psiref_CAS -Psiref_Utils -Selectors_full -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_dummy -tags \ No newline at end of file diff --git a/plugins/MRCC_Utils/H_apply.irp.f b/plugins/MRCC_Utils/H_apply.irp.f index 4d8964bf..d8dfb62d 100644 --- a/plugins/MRCC_Utils/H_apply.irp.f +++ b/plugins/MRCC_Utils/H_apply.irp.f @@ -31,7 +31,7 @@ s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() print s -s = H_apply_zmq("mrcepa_PT2") +s = H_apply("mrcepa_PT2") s.energy = "psi_energy" s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() diff --git a/plugins/MRCC_Utils/amplitudes.irp.f b/plugins/MRCC_Utils/amplitudes.irp.f index f9cb51ad..1dcf2a2b 100644 --- a/plugins/MRCC_Utils/amplitudes.irp.f +++ b/plugins/MRCC_Utils/amplitudes.irp.f @@ -23,33 +23,39 @@ allocate(pathTo(N_det_non_ref)) pathTo(:) = 0 - is_active_exc(:) = .false. + is_active_exc(:) = .True. n_exc_active = 0 - do hh = 1, hh_shortcut(0) - do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 - do II = 1, N_det_ref +! do hh = 1, hh_shortcut(0) +! do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 +! do II = 1, N_det_ref +! +! call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) +! if(.not. ok) cycle +! +! call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) +! if(.not. ok) cycle +! +! ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) +! if(ind == -1) cycle +! +! logical, external :: is_a_two_holes_two_particles +! if (is_a_two_holes_two_particles(myDet)) then +! is_active_exc(pp) = .False. +! endif - call apply_hole_local(psi_ref(1,1,II), hh_exists(1, hh), myMask, ok, N_int) - if(.not. ok) cycle +! ind = psi_non_ref_sorted_idx(ind) +! if(pathTo(ind) == 0) then +! pathTo(ind) = pp +! else +! is_active_exc(pp) = .true. +! is_active_exc(pathTo(ind)) = .true. +! end if - call apply_particle_local(myMask, pp_exists(1, pp), myDet, ok, N_int) - if(.not. ok) cycle +! end do +! end do +! end do - ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) - if(ind == -1) cycle - - ind = psi_non_ref_sorted_idx(ind) - if(pathTo(ind) == 0) then - pathTo(ind) = pp - else - is_active_exc(pp) = .true. - is_active_exc(pathTo(ind)) = .true. - end if - end do - end do - end do -!is_active_exc=.true. do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) then @@ -66,6 +72,32 @@ END_PROVIDER +BEGIN_PROVIDER [ logical, has_a_unique_parent, (N_det_non_ref) ] + implicit none + BEGIN_DOC + ! True if the determinant in the non-reference has a unique parent + END_DOC + integer :: i,j,n + integer :: degree + do j=1,N_det_non_ref + has_a_unique_parent(j) = .True. + n=0 + do i=1,N_det_ref + call get_excitation_degree(psi_ref(1,1,i), psi_non_ref(1,1,j), degree, N_int) + if (degree < 2) then + n = n+1 + if (n > 1) then + has_a_unique_parent(j) = .False. + exit + endif + endif + enddo + enddo + +END_PROVIDER + + + BEGIN_PROVIDER [ integer, n_exc_active_sze ] implicit none BEGIN_DOC @@ -89,14 +121,13 @@ END_PROVIDER double precision :: phase logical :: ok integer, external :: searchDet - - PROVIDE psi_non_ref_sorted_idx psi_ref_coef + !$OMP PARALLEL default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int,& !$OMP active_excitation_to_determinants_val, active_excitation_to_determinants_idx)& !$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, & !$OMP psi_non_ref_sorted_idx, psi_ref, N_det_ref, N_states)& - !$OMP shared(is_active_exc, active_hh_idx, active_pp_idx, n_exc_active)& + !$OMP shared(active_hh_idx, active_pp_idx, n_exc_active)& !$OMP private(lref, pp, II, ok, myMask, myDet, ind, phase, wk, ppp, hh, s) allocate(lref(N_det_non_ref)) !$OMP DO schedule(dynamic) @@ -127,7 +158,6 @@ END_PROVIDER wk += 1 do s=1,N_states active_excitation_to_determinants_val(s,wk, ppp) = psi_ref_coef(lref(i), s) - enddo active_excitation_to_determinants_idx(wk, ppp) = i else if(lref(i) < 0) then @@ -160,7 +190,7 @@ END_PROVIDER double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij - PROVIDE psi_non_ref active_excitation_to_determinants_val + PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 @@ -168,6 +198,7 @@ END_PROVIDER mrcc_N_col(:) = 0 AtA_size = 0 + !$OMP PARALLEL default(none) shared(k, active_excitation_to_determinants_idx,& !$OMP active_excitation_to_determinants_val, hh_nex) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen,& diff --git a/plugins/MRCC_Utils/davidson.irp.f b/plugins/MRCC_Utils/davidson.irp.f index 6bdadb24..436b89a4 100644 --- a/plugins/MRCC_Utils/davidson.irp.f +++ b/plugins/MRCC_Utils/davidson.irp.f @@ -35,21 +35,20 @@ subroutine davidson_diag_mrcc(dets_in,u_in,energies,dim_in,sze,N_st,N_st_diag,Ni PROVIDE mo_bielec_integrals_in_map allocate(H_jj(sze)) + H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(sze,H_jj,N_det_ref,dets_in,Nint,istate,delta_ii,idx_ref) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze + !$OMP DO + do i=2,sze H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) enddo !$OMP END DO - !$OMP DO SCHEDULE(guided) - do i=1,N_det_ref - H_jj(idx_ref(i)) += delta_ii(istate,i) - enddo - !$OMP END DO !$OMP END PARALLEL + do i=1,N_det_ref + H_jj(idx_ref(i)) += delta_ii(istate,i) + enddo call davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) deallocate (H_jj) end @@ -224,17 +223,6 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s W(i,k,iter+1) = 0.d0 enddo enddo -! do k=1,N_st_diag -! do iter2=1,iter -! do l=1,N_st_diag -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) -! W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) -! enddo -! enddo -! enddo -! enddo -! ! call dgemm('N','N', sze, N_st_diag, N_st_diag*iter, & 1.d0, U, size(U,1), y, size(y,1)*size(y,2), 0.d0, U(1,1,iter+1), size(U,1)) @@ -276,27 +264,11 @@ subroutine davidson_diag_hjj_mrcc(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_s do k=1,N_st_diag -! do iter2=1,iter -! do l=1,N_st_diag -! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter2),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter2) -! enddo -! enddo -! enddo -! call dgemv('T',sze,N_st_diag*iter,1.d0,U,size(U,1), & U(1,k,iter+1),1,0.d0,c,1) call dgemv('N',sze,N_st_diag*iter,-1.d0,U,size(U,1), & c,1,1.d0,U(1,k,iter+1),1) -! -! do l=1,k-1 -! c(1) = u_dot_v(U(1,k,iter+1),U(1,l,iter+1),sze) -! do i=1,sze -! U(i,k,iter+1) = U(i,k,iter+1) - c(1) * U(i,l,iter+1) -! enddo -! enddo -! + call dgemv('T',sze,k-1,1.d0,U(1,1,iter+1),size(U,1), & U(1,k,iter+1),1,0.d0,c,1) call dgemv('N',sze,k-1,-1.d0,U(1,1,iter+1),size(U,1), & @@ -429,7 +401,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) allocate(vt(sze_8,N_st)) Vt = 0.d0 - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,1) do sh2=sh,shortcut(0,1) exa = 0 @@ -468,9 +440,9 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) enddo enddo enddo - !$OMP END DO NOWAIT + !$OMP END DO - !$OMP DO SCHEDULE(dynamic) + !$OMP DO SCHEDULE(static,1) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 org_i = sort_idx(i,2) @@ -490,7 +462,7 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) end do end do enddo - !$OMP END DO NOWAIT + !$OMP END DO !$OMP DO do ii=1,n_det_ref @@ -505,13 +477,12 @@ subroutine H_u_0_mrcc_nstates(v_0,u_0,H_jj,n,keys_tmp,Nint,istate_in,N_st,sze_8) enddo !$OMP END DO - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(i,istate) enddo enddo - !$OMP END CRITICAL deallocate(vt) !$OMP END PARALLEL @@ -559,25 +530,26 @@ subroutine davidson_diag_mrcc_hs2(dets_in,u_in,dim_in,energies,sze,N_st,N_st_dia ASSERT (sze > 0) ASSERT (Nint > 0) ASSERT (Nint == N_int) - PROVIDE mo_bielec_integrals_in_map + PROVIDE mo_bielec_integrals_in_map allocate(H_jj(sze), S2_jj(sze)) + H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint) + call get_s2(dets_in(1,1,1),dets_in(1,1,1),Nint,S2_jj(1)) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(sze,H_jj,S2_jj, dets_in,Nint,N_det_ref,delta_ii, & !$OMP idx_ref, istate) & !$OMP PRIVATE(i) - !$OMP DO SCHEDULE(guided) - do i=1,sze + !$OMP DO + do i=2,sze H_jj(i) = diag_h_mat_elem(dets_in(1,1,i),Nint) call get_s2(dets_in(1,1,i),dets_in(1,1,i),Nint,S2_jj(i)) enddo !$OMP END DO - !$OMP DO SCHEDULE(guided) + !$OMP END PARALLEL + do i=1,N_det_ref H_jj(idx_ref(i)) += delta_ii(istate,i) enddo - !$OMP END DO - !$OMP END PARALLEL call davidson_diag_hjj_sjj_mrcc(dets_in,u_in,H_jj,S2_jj,energies,dim_in,sze,N_st,N_st_diag,Nint,iunit,istate) deallocate (H_jj,S2_jj) @@ -1094,6 +1066,7 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i enddo enddo !$OMP END DO + !$OMP DO SCHEDULE(guided) do sh=1,shortcut(0,2) do i=shortcut(sh,2),shortcut(sh+1,2)-1 @@ -1142,14 +1115,14 @@ subroutine H_S2_u_0_mrcc_nstates(v_0,s_0,u_0,H_jj,S2_jj,n,keys_tmp,Nint,istate_i ! End Specific to dressing ! ------------------------ - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(istate,i) + !$OMP ATOMIC s_0(i,istate) = s_0(i,istate) + st(istate,i) enddo enddo - !$OMP END CRITICAL deallocate(vt,st) !$OMP END PARALLEL diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index d6b9cc79..41435688 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -5,6 +5,7 @@ use bitmasks END_PROVIDER + BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ] @@ -62,6 +63,65 @@ END_PROVIDER END_PROVIDER +! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] +!&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] +!&BEGIN_PROVIDER [ integer, lambda_mrcc_kept, (0:psi_det_size) ] +!&BEGIN_PROVIDER [ double precision, lambda_pert, (N_states, N_det_non_ref) ] +! implicit none +! BEGIN_DOC +! ! cm/ or perturbative 1/Delta_E(m) +! END_DOC +! integer :: i,k +! double precision :: ihpsi_current(N_states) +! integer :: i_pert_count +! double precision :: hii, E2(N_states), E2var(N_states) +! integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3 +! +! i_pert_count = 0 +! lambda_mrcc = 0.d0 +! N_lambda_mrcc_pt2 = 0 +! N_lambda_mrcc_pt3 = 0 +! lambda_mrcc_pt2(0) = 0 +! lambda_mrcc_kept(0) = 0 +! +! E2 = 0.d0 +! E2var = 0.d0 +! do i=1,N_det_non_ref +! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& +! size(psi_ref_coef,1), N_states,ihpsi_current) +! call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) +! do k=1,N_states +! if (ihpsi_current(k) == 0.d0) then +! ihpsi_current(k) = 1.d-32 +! endif +! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) +! lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) +! E2(k) += ihpsi_current(k)*ihpsi_current(k) / (psi_ref_energy_diagonalized(k)-hii) +! E2var(k) += ihpsi_current(k) * psi_non_ref_coef(i,k) +! enddo +! enddo +! +! do i=1,N_det_non_ref +! call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& +! size(psi_ref_coef,1), N_states,ihpsi_current) +! call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) +! do k=1,N_states +! if (ihpsi_current(k) == 0.d0) then +! ihpsi_current(k) = 1.d-32 +! endif +! lambda_mrcc(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k) +! lambda_pert(k,i) = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) * E2var(k)/E2(k) +! enddo +! enddo +! lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2 +! lambda_mrcc_kept(0) = N_lambda_mrcc_pt3 +! print*,'N_det_non_ref = ',N_det_non_ref +! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) +! print*,'lambda max = ',maxval(dabs(lambda_mrcc)) +! print*,'Number of ignored determinants = ',i_pert_count +! +!END_PROVIDER + BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] @@ -291,11 +351,11 @@ logical function is_generable(det1, det2, Nint) integer, intent(in) :: Nint integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer :: degree, f, exc(0:2, 2, 2), t - integer*2 :: h1, h2, p1, p2, s1, s2 + integer :: h1, h2, p1, p2, s1, s2 integer, external :: searchExc logical, external :: excEq double precision :: phase - integer*2 :: tmp_array(4) + integer :: tmp_array(4) is_generable = .false. call get_excitation(det1, det2, exc, degree, phase, Nint) @@ -306,7 +366,7 @@ logical function is_generable(det1, det2, Nint) end if if(degree > 2) stop "?22??" - call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) if(degree == 1) then h2 = h1 @@ -394,7 +454,7 @@ integer function searchExc(excs, exc, n) use bitmasks integer, intent(in) :: n - integer*2,intent(in) :: excs(4,n), exc(4) + integer,intent(in) :: excs(4,n), exc(4) integer :: l, h, c integer, external :: excCmp logical, external :: excEq @@ -459,8 +519,8 @@ subroutine sort_exc(key, N_key) integer, intent(in) :: N_key - integer*2,intent(inout) :: key(4,N_key) - integer*2 :: tmp(4) + integer,intent(inout) :: key(4,N_key) + integer :: tmp(4) integer :: i,ni @@ -482,7 +542,7 @@ end subroutine logical function exc_inf(exc1, exc2) implicit none - integer*2,intent(in) :: exc1(4), exc2(4) + integer,intent(in) :: exc1(4), exc2(4) integer :: i exc_inf = .false. do i=1,4 @@ -504,9 +564,9 @@ subroutine tamise_exc(key, no, n, N_key) ! Uncodumented : TODO END_DOC integer,intent(in) :: no, n, N_key - integer*2,intent(inout) :: key(4, N_key) + integer,intent(inout) :: key(4, N_key) integer :: k,j - integer*2 :: tmp(4) + integer :: tmp(4) logical :: exc_inf integer :: ni @@ -535,8 +595,9 @@ end subroutine subroutine dec_exc(exc, h1, h2, p1, p2) implicit none - integer :: exc(0:2,2,2), s1, s2, degree - integer*2, intent(out) :: h1, h2, p1, p2 + integer, intent(in) :: exc(0:2,2,2) + integer, intent(out) :: h1, h2, p1, p2 + integer :: degree, s1, s2 degree = exc(0,1,1) + exc(0,1,2) @@ -547,7 +608,7 @@ subroutine dec_exc(exc, h1, h2, p1, p2) if(degree == 0) return - call decode_exc_int2(exc, degree, h1, p1, h2, p2, s1, s2) + call decode_exc(exc, degree, h1, p1, h2, p2, s1, s2) h1 += mo_tot_num * (s1-1) p1 += mo_tot_num * (s1-1) @@ -579,7 +640,7 @@ end subroutine &BEGIN_PROVIDER [ integer, N_ex_exists ] implicit none integer :: exc(0:2, 2, 2), degree, n, on, s, l, i - integer*2 :: h1, h2, p1, p2 + integer :: h1, h2, p1, p2 double precision :: phase logical,allocatable :: hh(:,:) , pp(:,:) @@ -632,12 +693,12 @@ END_PROVIDER double precision :: phase - double precision, allocatable :: rho_mrcc_init(:) + double precision, allocatable :: rho_mrcc_inact(:) integer :: a_coll, at_roww print *, "TI", hh_nex, N_det_non_ref - allocate(rho_mrcc_init(N_det_non_ref)) + allocate(rho_mrcc_inact(N_det_non_ref)) allocate(x_new(hh_nex)) allocate(x(hh_nex), AtB(hh_nex)) @@ -649,7 +710,7 @@ END_PROVIDER !$OMP private(at_row, a_col, i, j, r1, r2, wk, A_ind_mwen, A_val_mwen, a_coll, at_roww)& !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtB, mrcc_AtA_val, mrcc_AtA_ind, s, n_exc_active, active_pp_idx) - !$OMP DO schedule(dynamic, 100) + !$OMP DO schedule(static, 100) do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) do i=1,active_excitation_to_determinants_idx(0,at_roww) @@ -668,7 +729,7 @@ END_PROVIDER X(a_col) = AtB(a_col) end do - rho_mrcc_init = 0d0 + rho_mrcc_inact(:) = 0d0 allocate(lref(N_det_ref)) do hh = 1, hh_shortcut(0) @@ -692,29 +753,23 @@ END_PROVIDER X(pp) = AtB(pp) do II=1,N_det_ref if(lref(II) > 0) then - rho_mrcc_init(lref(II)) = psi_ref_coef(II,s) * X(pp) + rho_mrcc_inact(lref(II)) = psi_ref_coef(II,s) * X(pp) else if(lref(II) < 0) then - rho_mrcc_init(-lref(II)) = -psi_ref_coef(II,s) * X(pp) + rho_mrcc_inact(-lref(II)) = -psi_ref_coef(II,s) * X(pp) end if end do end do end do deallocate(lref) - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc_init(i) - enddo - x_new = x double precision :: factor, resold factor = 1.d0 resold = huge(1.d0) - do k=0,10*hh_nex + do k=0,hh_nex/4 res = 0.d0 - !$OMP PARALLEL default(shared) private(cx, i, a_col, a_coll) reduction(+:res) - !$OMP DO do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) cx = 0.d0 @@ -725,102 +780,108 @@ END_PROVIDER res = res + (X_new(a_col) - X(a_col))*(X_new(a_col) - X(a_col)) X(a_col) = X_new(a_col) end do - !$OMP END DO - !$OMP END PARALLEL if (res > resold) then factor = factor * 0.5d0 endif + + if(iand(k, 127) == 0) then + print *, k, res, 1.d0 - res/resold + endif + + if ( res < 1d-10 ) then + exit + endif + if ( (res/resold > 0.99d0) ) then + exit + endif resold = res - - if(iand(k, 4095) == 0) then - print *, "res ", k, res - end if - - if(res < 1d-10) exit + end do dIj_unique(1:size(X), s) = X(1:size(X)) + print *, k, res, 1.d0 - res/resold - enddo - do s=1,N_states + do i=1,N_det_non_ref + rho_mrcc(i,s) = 0.d0 + enddo do a_coll=1,n_exc_active a_col = active_pp_idx(a_coll) do j=1,N_det_non_ref i = active_excitation_to_determinants_idx(j,a_coll) if (i==0) exit + if (rho_mrcc_inact(i) /= 0.d0) then + call debug_det(psi_non_ref(1,1,i),N_int) + stop + endif rho_mrcc(i,s) = rho_mrcc(i,s) + active_excitation_to_determinants_val(s,j,a_coll) * dIj_unique(a_col,s) enddo end do - norm = 0.d0 - do i=1,N_det_non_ref - norm = norm + rho_mrcc(i,s)*rho_mrcc(i,s) - enddo - ! Norm now contains the norm of A.X - + double precision :: norm2_ref, norm2_inact, a, b, c, Delta + ! Psi = Psi_ref + Psi_inactive + f*Psi_active + ! Find f to normalize Psi + + norm2_ref = 0.d0 do i=1,N_det_ref - norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) + norm2_ref = norm2_ref + psi_ref_coef(i,s)*psi_ref_coef(i,s) enddo - ! Norm now contains the norm of Psi + A.X - + + a = 0.d0 + do i=1,N_det_non_ref + a = a + rho_mrcc(i,s)*rho_mrcc(i,s) + enddo + + norm = a + norm2_ref print *, "norm : ", sqrt(norm) - enddo + + norm = sqrt((1.d0-norm2_ref)/a) + + ! Renormalize Psi+A.X + do i=1,N_det_non_ref + rho_mrcc(i,s) = rho_mrcc(i,s) * norm + enddo + +!norm = norm2_ref +!do i=1,N_det_non_ref +! norm = norm + rho_mrcc(i,s)**2 +!enddo +!print *, 'check', norm +!stop + - do s=1,N_states norm = 0.d0 - double precision :: f + double precision :: f, g, gmax + gmax = maxval(dabs(psi_non_ref_coef(:,s))) do i=1,N_det_non_ref - if (rho_mrcc(i,s) == 0.d0) then - rho_mrcc(i,s) = 1.d-32 - endif - if (lambda_type == 2) then f = 1.d0 else + if (rho_mrcc(i,s) == 0.d0) then + cycle + endif ! f is such that f.\tilde{c_i} = c_i f = psi_non_ref_coef(i,s) / rho_mrcc(i,s) ! Avoid numerical instabilities - f = min(f,2.d0) - f = max(f,-2.d0) + g = 2.d0+100.d0*exp(-20.d0*dabs(psi_non_ref_coef(i,s)/gmax)) + f = min(f, g) + f = max(f,-g) + endif - norm = norm + f*f *rho_mrcc(i,s)*rho_mrcc(i,s) + norm = norm + (rho_mrcc(i,s)*f)**2 rho_mrcc(i,s) = f enddo - ! norm now contains the norm of |T.Psi_0> - ! rho_mrcc now contains the f factors + ! rho_mrcc now contains the mu_i factors - f = 1.d0/norm - ! f now contains 1/ - - norm = 1.d0 - do i=1,N_det_ref - norm = norm - psi_ref_coef(i,s)*psi_ref_coef(i,s) - enddo - ! norm now contains - f = dsqrt(f*norm) - ! f normalises T.Psi_0 such that (1+T)|Psi> is normalized - - norm = norm*f print *, 'norm of |T Psi_0> = ', dsqrt(norm) - if (dsqrt(norm) > 1.d0) then + if (norm > 1.d0) then stop 'Error : Norm of the SD larger than the norm of the reference.' endif - do i=1,N_det_ref - norm = norm + psi_ref_coef(i,s)*psi_ref_coef(i,s) - enddo - - do i=1,N_det_non_ref - rho_mrcc(i,s) = rho_mrcc(i,s) * f - enddo - ! rho_mrcc now contains the product of the scaling factors and the - ! normalization constant - end do END_PROVIDER @@ -845,6 +906,53 @@ END_PROVIDER +!double precision function f_fit(x) +! implicit none +! double precision :: x +! f_fit = 0.d0 +! return +! if (x < 0.d0) then +! f_fit = 0.d0 +! else if (x < 1.d0) then +! f_fit = 1.d0/0.367879441171442 * ( x**2 * exp(-x**2)) +! else +! f_fit = 1.d0 +! endif +!end +! +!double precision function get_dij_index(II, i, s, Nint) +! integer, intent(in) :: II, i, s, Nint +! double precision, external :: get_dij +! double precision :: HIi, phase, c, a, b, d +! +! call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! +! a = lambda_pert(s,i) +! b = lambda_mrcc(s,i) +! c = f_fit(a/b) +! +! d = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase* rho_mrcc(i,s) +! +! c = f_fit(a*HIi/d) +! +! get_dij_index = HIi * a * c + (1.d0 - c) * d +! get_dij_index = d +! return +! +! if(lambda_type == 0) then +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase +! get_dij_index = get_dij_index * rho_mrcc(i,s) +! else if(lambda_type == 1) then +! call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi) +! get_dij_index = HIi * lambda_mrcc(s, i) +! else if(lambda_type == 2) then +! call get_phase(psi_ref(1,1,II), psi_non_ref(1,1,i), phase, N_int) +! get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint) * phase +! get_dij_index = get_dij_index * rho_mrcc(i,s) +! end if +!end function double precision function get_dij_index(II, i, s, Nint) integer, intent(in) :: II, i, s, Nint @@ -872,11 +980,11 @@ double precision function get_dij(det1, det2, s, Nint) integer, intent(in) :: s, Nint integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer :: degree, f, exc(0:2, 2, 2), t - integer*2 :: h1, h2, p1, p2, s1, s2 + integer :: h1, h2, p1, p2, s1, s2 integer, external :: searchExc logical, external :: excEq double precision :: phase - integer*2 :: tmp_array(4) + integer :: tmp_array(4) get_dij = 0d0 call get_excitation(det1, det2, exc, degree, phase, Nint) @@ -885,7 +993,7 @@ double precision function get_dij(det1, det2, s, Nint) stop "get_dij" end if - call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) if(degree == 1) then h2 = h1 @@ -918,8 +1026,8 @@ double precision function get_dij(det1, det2, s, Nint) end function - BEGIN_PROVIDER [ integer*2, hh_exists, (4, N_hh_exists) ] -&BEGIN_PROVIDER [ integer*2, pp_exists, (4, N_pp_exists) ] + BEGIN_PROVIDER [ integer, hh_exists, (4, N_hh_exists) ] +&BEGIN_PROVIDER [ integer, pp_exists, (4, N_pp_exists) ] &BEGIN_PROVIDER [ integer, hh_shortcut, (0:N_hh_exists + 1) ] &BEGIN_PROVIDER [ integer, hh_nex ] implicit none @@ -934,9 +1042,9 @@ end function ! hh_nex : Total number of excitation operators ! END_DOC - integer*2,allocatable :: num(:,:) + integer,allocatable :: num(:,:) integer :: exc(0:2, 2, 2), degree, n, on, s, l, i - integer*2 :: h1, h2, p1, p2 + integer :: h1, h2, p1, p2 double precision :: phase logical, external :: excEq @@ -962,24 +1070,40 @@ end function hh_shortcut(0) = 1 hh_shortcut(1) = 1 - hh_exists(:,1) = (/1_2, num(1,1), 1_2, num(2,1)/) - pp_exists(:,1) = (/1_2, num(3,1), 1_2, num(4,1)/) + hh_exists(:,1) = (/1, num(1,1), 1, num(2,1)/) + pp_exists(:,1) = (/1, num(3,1), 1, num(4,1)/) s = 1 do i=2,n if(.not. excEq(num(1,i), num(1,s))) then s += 1 num(:, s) = num(:, i) - pp_exists(:,s) = (/1_2, num(3,s), 1_2, num(4,s)/) + pp_exists(:,s) = (/1, num(3,s), 1, num(4,s)/) if(hh_exists(2, hh_shortcut(0)) /= num(1,s) .or. & hh_exists(4, hh_shortcut(0)) /= num(2,s)) then hh_shortcut(0) += 1 hh_shortcut(hh_shortcut(0)) = s - hh_exists(:,hh_shortcut(0)) = (/1_2, num(1,s), 1_2, num(2,s)/) + hh_exists(:,hh_shortcut(0)) = (/1, num(1,s), 1, num(2,s)/) end if end if end do hh_shortcut(hh_shortcut(0)+1) = s+1 + if (hh_shortcut(0) > N_hh_exists) then + print *, 'Error in ', irp_here + print *, 'hh_shortcut(0) :', hh_shortcut(0) + print *, 'N_hh_exists : ', N_hh_exists + print *, 'Is your active space defined?' + stop + endif + + if (hh_shortcut(hh_shortcut(0)+1)-1 > N_pp_exists) then + print *, 'Error 1 in ', irp_here + print *, 'hh_shortcut(hh_shortcut(0)+1)-1 :', hh_shortcut(hh_shortcut(0)+1)-1 + print *, 'N_pp_exists : ', N_pp_exists + print *, 'Is your active space defined?' + stop + endif + do s=2,4,2 do i=1,hh_shortcut(0) if(hh_exists(s, i) == 0) then @@ -990,6 +1114,7 @@ end function end if end do + do i=1,hh_shortcut(hh_shortcut(0)+1)-1 if(pp_exists(s, i) == 0) then pp_exists(s-1, i) = 0 @@ -1005,7 +1130,7 @@ END_PROVIDER logical function excEq(exc1, exc2) implicit none - integer*2, intent(in) :: exc1(4), exc2(4) + integer, intent(in) :: exc1(4), exc2(4) integer :: i excEq = .false. do i=1, 4 @@ -1017,7 +1142,7 @@ end function integer function excCmp(exc1, exc2) implicit none - integer*2, intent(in) :: exc1(4), exc2(4) + integer, intent(in) :: exc1(4), exc2(4) integer :: i excCmp = 0 do i=1, 4 @@ -1036,8 +1161,8 @@ subroutine apply_hole_local(det, exc, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint - integer*2, intent(in) :: exc(4) - integer*2 :: s1, s2, h1, h2 + integer, intent(in) :: exc(4) + integer :: s1, s2, h1, h2 integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2) logical, intent(out) :: ok @@ -1073,8 +1198,8 @@ subroutine apply_particle_local(det, exc, res, ok, Nint) use bitmasks implicit none integer, intent(in) :: Nint - integer*2, intent(in) :: exc(4) - integer*2 :: s1, s2, p1, p2 + integer, intent(in) :: exc(4) + integer :: s1, s2, p1, p2 integer(bit_kind),intent(in) :: det(Nint, 2) integer(bit_kind),intent(out) :: res(Nint, 2) logical, intent(out) :: ok diff --git a/plugins/MRPT_Utils/energies_cas.irp.f b/plugins/MRPT_Utils/energies_cas.irp.f index ac399ce7..dd79edbe 100644 --- a/plugins/MRPT_Utils/energies_cas.irp.f +++ b/plugins/MRPT_Utils/energies_cas.irp.f @@ -898,7 +898,7 @@ END_PROVIDER enddo print*, '***' do i = 1, N_det+1 - write(*,'(100(F16.10,X))')H_matrix(i,:) + write(*,'(100(F16.10,1X))')H_matrix(i,:) enddo call lapack_diag(eigenvalues,eigenvectors,H_matrix,size(H_matrix,1),N_det+1) corr_e_from_1h1p(state_target) += eigenvalues(1) - energy_cas_dyall(state_target) @@ -919,15 +919,15 @@ END_PROVIDER norm += psi_in_out_coef(i,state_target) * psi_in_out_coef(i,state_target) enddo print*, 'Coef ' - write(*,'(100(X,F16.10))')psi_coef(1:N_det,state_target) - write(*,'(100(X,F16.10))')psi_in_out_coef(:,state_target) + write(*,'(100(1X,F16.10))')psi_coef(1:N_det,state_target) + write(*,'(100(1X,F16.10))')psi_in_out_coef(:,state_target) double precision :: coef_tmp(N_det) do i = 1, N_det coef_tmp(i) = psi_coef(i,1) * interact_psi0(i) / delta_e_alpha_beta(i,ispin) enddo - write(*,'(100(X,F16.10))')coef_tmp(:) + write(*,'(100(1X,F16.10))')coef_tmp(:) print*, 'naked interactions' - write(*,'(100(X,F16.10))')interact_psi0(:) + write(*,'(100(1X,F16.10))')interact_psi0(:) print*, '' print*, 'norm ',norm @@ -953,10 +953,10 @@ END_PROVIDER enddo enddo print*, '***' - write(*,'(100(X,F16.10))') - write(*,'(100(X,F16.10))')delta_e_alpha_beta(:,2) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) - ! write(*,'(100(X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) + write(*,'(100(1X,F16.10))') + write(*,'(100(1X,F16.10))')delta_e_alpha_beta(:,2) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,1,:) + ! write(*,'(100(1X,F16.10))')one_anhil_one_creat_inact_virt_bis(iorb,vorb,:,2,:) print*, '---------------------------------------------------------------------------' enddo enddo @@ -1089,11 +1089,11 @@ subroutine give_singles_and_partial_doubles_1h1p_contrib(matrix_1h1p,e_corr_from print*, 'e corr perturb EN',accu(state_target) print*, '' print*, 'coef diagonalized' - write(*,'(100(F16.10,X))')psi_in_out_coef(:,state_target) + write(*,'(100(F16.10,1X))')psi_in_out_coef(:,state_target) print*, 'coef_perturb' - write(*,'(100(F16.10,X))')coef_perturb(:) + write(*,'(100(F16.10,1X))')coef_perturb(:) print*, 'coef_perturb EN' - write(*,'(100(F16.10,X))')coef_perturb_bis(:) + write(*,'(100(F16.10,1X))')coef_perturb_bis(:) endif integer :: k do k = 1, N_det diff --git a/plugins/MRPT_Utils/excitations_cas.irp.f b/plugins/MRPT_Utils/excitations_cas.irp.f index 10cfe7c0..491cda58 100644 --- a/plugins/MRPT_Utils/excitations_cas.irp.f +++ b/plugins/MRPT_Utils/excitations_cas.irp.f @@ -22,7 +22,7 @@ subroutine apply_exc_to_psi(orb,hole_particle,spin_exc, & integer :: elec_num_tab_local(2) integer :: i,j,accu_elec,k - integer :: det_tmp(N_int), det_tmp_bis(N_int) + integer(bit_kind) :: det_tmp(N_int), det_tmp_bis(N_int) double precision :: phase double precision :: norm_factor diff --git a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f index 4c12dbe1..ce3a74c8 100644 --- a/plugins/MRPT_Utils/new_way_second_order_coef.irp.f +++ b/plugins/MRPT_Utils/new_way_second_order_coef.irp.f @@ -210,7 +210,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = (fock_operator_local(aorb,borb,kspin) ) * phase - if(isnan(hab))then + if(hab /= hab)then ! check NaN print*, '1' stop endif @@ -255,7 +255,7 @@ subroutine give_2h1p_contrib_sec_order(matrix_2h1p) call get_mono_excitation(det_tmp,det_tmp_bis,exc,phase,N_int) ! ! < det_tmp | H | det_tmp_bis > = F_{aorb,borb} hab = fock_operator_local(aorb,borb,kspin) * phase - if(isnan(hab))then + if(hab /= hab)then ! check NaN print*, '2' stop endif diff --git a/plugins/Molden/.gitignore b/plugins/Molden/.gitignore deleted file mode 100644 index dad27c9b..00000000 --- a/plugins/Molden/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -print_mo -tags \ No newline at end of file diff --git a/plugins/Perturbation/.gitignore b/plugins/Perturbation/.gitignore deleted file mode 100644 index effe9ffc..00000000 --- a/plugins/Perturbation/.gitignore +++ /dev/null @@ -1,26 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Properties -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Properties/.gitignore b/plugins/Properties/.gitignore deleted file mode 100644 index b2f0a113..00000000 --- a/plugins/Properties/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -print_hcc -print_mulliken -tags \ No newline at end of file diff --git a/plugins/Properties/delta_rho.irp.f b/plugins/Properties/delta_rho.irp.f index 7803ba3d..8fd08246 100644 --- a/plugins/Properties/delta_rho.irp.f +++ b/plugins/Properties/delta_rho.irp.f @@ -6,7 +6,7 @@ z_min = 0.d0 z_max = 10.d0 delta_z = 0.005d0 - N_z_pts = (z_max - z_min)/delta_z + N_z_pts = int( (z_max - z_min)/delta_z ) print*,'N_z_pts = ',N_z_pts END_PROVIDER diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index 6fa39278..91b26dc8 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -151,7 +151,7 @@ subroutine print_hcc integer :: i,j print*,'Z AU GAUSS MHZ cm^-1' do i = 1, nucl_num - write(*,'(I2,X,F4.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) + write(*,'(I2,1X,F4.1,1X,4(F16.6,1X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i) enddo end diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f index deeb90bf..68b620c5 100644 --- a/plugins/Properties/mulliken.irp.f +++ b/plugins/Properties/mulliken.irp.f @@ -126,7 +126,7 @@ subroutine print_mulliken_sd accu = 0.d0 do i = 1, ao_num accu += spin_gross_orbital_product(i) - write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) + write(*,'(1X,I3,1X,A4,1X,I2,1X,A4,1X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i) enddo print*,'sum = ',accu accu = 0.d0 @@ -142,7 +142,7 @@ subroutine print_mulliken_sd accu = 0.d0 do i = 0, ao_l_max accu += spin_population_angular_momentum_per_atom(i,j) - write(*,'(XX,I3,XX,A4,X,A4,X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) + write(*,'(1X,I3,1X,A4,1X,A4,1X,F10.7)')j,trim(element_name(int(nucl_charge(j)))),trim(l_to_charater(i)),spin_population_angular_momentum_per_atom(i,j) print*,'sum = ',accu enddo enddo diff --git a/plugins/Psiref_CAS/.gitignore b/plugins/Psiref_CAS/.gitignore deleted file mode 100644 index d79d94d9..00000000 --- a/plugins/Psiref_CAS/.gitignore +++ /dev/null @@ -1,26 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Davidson -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Psiref_Utils -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -overwrite_with_cas -tags \ No newline at end of file diff --git a/plugins/Psiref_CAS/psi_ref.irp.f b/plugins/Psiref_CAS/psi_ref.irp.f index d3b6c28f..87439764 100644 --- a/plugins/Psiref_CAS/psi_ref.irp.f +++ b/plugins/Psiref_CAS/psi_ref.irp.f @@ -67,3 +67,37 @@ END_PROVIDER END_PROVIDER + BEGIN_PROVIDER [double precision, norm_psi_ref, (N_states)] +&BEGIN_PROVIDER [double precision, inv_norm_psi_ref, (N_states)] + implicit none + integer :: i,j + norm_psi_ref = 0.d0 + do j = 1, N_states + do i = 1, N_det_ref + norm_psi_ref(j) += psi_ref_coef(i,j) * psi_ref_coef(i,j) + enddo + inv_norm_psi_ref(j) = 1.d0/(dsqrt(norm_psi_Ref(j))) + print *, inv_norm_psi_ref(j) + enddo + + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_ref_coef_interm_norm, (N_det_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_ref + psi_ref_coef_interm_norm(i,j) = inv_norm_psi_ref(j) * psi_ref_coef(i,j) + enddo + enddo + END_PROVIDER + + BEGIN_PROVIDER [double precision, psi_non_ref_coef_interm_norm, (N_det_non_ref,N_states)] + implicit none + integer :: i,j + do j = 1, N_states + do i = 1, N_det_non_ref + psi_non_ref_coef_interm_norm(i,j) = psi_non_ref_coef(i,j) * inv_norm_psi_ref(j) + enddo + enddo + END_PROVIDER diff --git a/plugins/Psiref_Utils/.gitignore b/plugins/Psiref_Utils/.gitignore deleted file mode 100644 index d98a4abc..00000000 --- a/plugins/Psiref_Utils/.gitignore +++ /dev/null @@ -1,29 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -Generators_full -Hartree_Fock -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MOGuess -MO_Basis -Makefile -Makefile.depend -Nuclei -Perturbation -Properties -Pseudo -Selectors_full -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -mrcc_general -tags \ No newline at end of file diff --git a/plugins/Psiref_Utils/psi_ref_utils.irp.f b/plugins/Psiref_Utils/psi_ref_utils.irp.f index c4147ebc..95c993f0 100644 --- a/plugins/Psiref_Utils/psi_ref_utils.irp.f +++ b/plugins/Psiref_Utils/psi_ref_utils.irp.f @@ -98,8 +98,7 @@ END_PROVIDER enddo N_det_non_ref = i_non_ref if (N_det_non_ref < 1) then - print *, 'Error : All determinants are in the reference' - stop -1 + print *, 'Warning : All determinants are in the reference' endif END_PROVIDER diff --git a/plugins/QmcChem/.gitignore b/plugins/QmcChem/.gitignore deleted file mode 100644 index 5f364702..00000000 --- a/plugins/QmcChem/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Determinants -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Integrals_Bielec -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_for_qmcchem -tags -target_pt2_qmc \ No newline at end of file diff --git a/plugins/Selectors_full/.gitignore b/plugins/Selectors_full/.gitignore deleted file mode 100644 index 8d85dede..00000000 --- a/plugins/Selectors_full/.gitignore +++ /dev/null @@ -1,25 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Determinants -Integrals_Monoelec -MO_Basis -Utils -Pseudo -Bitmask -AO_Basis -Electrons -MOGuess -Nuclei -Hartree_Fock -Integrals_Bielec \ No newline at end of file diff --git a/plugins/Selectors_no_sorted/.gitignore b/plugins/Selectors_no_sorted/.gitignore deleted file mode 100644 index 955ad80c..00000000 --- a/plugins/Selectors_no_sorted/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# -# Do not modify this file. Add your ignored files to the gitignore -# (without the dot at the beginning) file. -# -IRPF90_temp -IRPF90_man -irpf90.make -tags -Makefile.depend -irpf90_entities -build.ninja -.ninja_log -.ninja_deps diff --git a/plugins/SingleRefMethod/.gitignore b/plugins/SingleRefMethod/.gitignore deleted file mode 100644 index d85c570a..00000000 --- a/plugins/SingleRefMethod/.gitignore +++ /dev/null @@ -1,19 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -MO_Basis -Utils -Bitmask -AO_Basis -Electrons -Nuclei \ No newline at end of file diff --git a/plugins/analyze_wf/NEEDED_CHILDREN_MODULES b/plugins/analyze_wf/NEEDED_CHILDREN_MODULES new file mode 100644 index 00000000..aae89501 --- /dev/null +++ b/plugins/analyze_wf/NEEDED_CHILDREN_MODULES @@ -0,0 +1 @@ +Determinants diff --git a/plugins/analyze_wf/README.rst b/plugins/analyze_wf/README.rst new file mode 100644 index 00000000..179e407d --- /dev/null +++ b/plugins/analyze_wf/README.rst @@ -0,0 +1,12 @@ +========== +analyze_wf +========== + +Needed Modules +============== +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. +Documentation +============= +.. Do not edit this section It was auto-generated +.. by the `update_README.py` script. diff --git a/plugins/analyze_wf/analyze_wf.irp.f b/plugins/analyze_wf/analyze_wf.irp.f new file mode 100644 index 00000000..7d005a05 --- /dev/null +++ b/plugins/analyze_wf/analyze_wf.irp.f @@ -0,0 +1,70 @@ +program analyze_wf + implicit none + BEGIN_DOC +! Wave function analyzis + END_DOC + read_wf = .True. + SOFT_TOUCH read_wf + call run() +end + +subroutine run + implicit none + integer :: istate, i + integer :: class(0:mo_tot_num,5) + double precision :: occupation(mo_tot_num) + + write(*,'(A)') 'MO Occupation' + write(*,'(A)') '=============' + write(*,'(A)') '' + do istate=1,N_states + call get_occupation_from_dets(occupation,istate) + write(*,'(A)') '' + write(*,'(A,I3)'), 'State ', istate + write(*,'(A)') '---------------' + write(*,'(A)') '' + write (*,'(A)') '======== ================' + class = 0 + do i=1,mo_tot_num + write (*,'(I8,X,F16.10)') i, occupation(i) + if (occupation(i) > 1.999d0) then + class(0,1) += 1 + class( class(0,1), 1) = i + else if (occupation(i) > 1.97d0) then + class(0,2) += 1 + class( class(0,2), 2) = i + else if (occupation(i) < 0.001d0) then + class(0,5) += 1 + class( class(0,5), 5) = i + else if (occupation(i) < 0.03d0) then + class(0,4) += 1 + class( class(0,4), 4) = i + else + class(0,3) += 1 + class( class(0,3), 3) = i + endif + enddo + write (*,'(A)') '======== ================' + write (*,'(A)') '' + + write (*,'(A)') 'Suggested classes' + write (*,'(A)') '-----------------' + write (*,'(A)') '' + write (*,'(A)') 'Core :' + write (*,*) (class(i,1), ',', i=1,class(0,1)) + write (*,*) '' + write (*,'(A)') 'Inactive :' + write (*,*) (class(i,2), ',', i=1,class(0,2)) + write (*,'(A)') '' + write (*,'(A)') 'Active :' + write (*,*) (class(i,3), ',', i=1,class(0,3)) + write (*,'(A)') '' + write (*,'(A)') 'Virtual :' + write (*,*) (class(i,4), ',', i=1,class(0,4)) + write (*,'(A)') '' + write (*,'(A)') 'Deleted :' + write (*,*) (class(i,5), ',', i=1,class(0,5)) + write (*,'(A)') '' + enddo + +end diff --git a/plugins/analyze_wf/occupation.irp.f b/plugins/analyze_wf/occupation.irp.f new file mode 100644 index 00000000..d426dc14 --- /dev/null +++ b/plugins/analyze_wf/occupation.irp.f @@ -0,0 +1,23 @@ +subroutine get_occupation_from_dets(occupation, istate) + implicit none + double precision, intent(out) :: occupation(mo_tot_num) + integer, intent(in) :: istate + BEGIN_DOC + ! Returns the average occupation of the MOs + END_DOC + integer :: i,j, ispin + integer :: list(N_int*bit_kind_size,2) + integer :: n_elements(2) + double precision :: c + + occupation = 0.d0 + do i=1,N_det + c = psi_coef(i,istate)*psi_coef(i,istate) + call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int) + do ispin=1,2 + do j=1,n_elements(ispin) + occupation( list(j,ispin) ) += c + enddo + enddo + enddo +end diff --git a/plugins/loc_cele/.gitignore b/plugins/loc_cele/.gitignore deleted file mode 100644 index 6c8b96df..00000000 --- a/plugins/loc_cele/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -loc_cele -tags \ No newline at end of file diff --git a/plugins/mrcepa0/.gitignore b/plugins/mrcepa0/.gitignore deleted file mode 100644 index 7ac9fbf6..00000000 --- a/plugins/mrcepa0/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -IRPF90_temp/ -IRPF90_man/ -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg index b64637e6..53519ec7 100644 --- a/plugins/mrcepa0/EZFIO.cfg +++ b/plugins/mrcepa0/EZFIO.cfg @@ -14,6 +14,12 @@ type: double precision doc: Calculated energy with PT2 contribution interface: ezfio +[perturbative_triples] +type: logical +doc: Compute perturbative contribution of the Triples +interface: ezfio,provider,ocaml +default: false + [energy] type: double precision doc: Calculated energy diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index 3579e3c8..2820750f 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -13,6 +13,7 @@ use bitmasks integer(bit_kind),allocatable :: buf(:,:,:) logical :: ok logical, external :: detEq + integer, external :: omp_get_thread_num delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 @@ -23,7 +24,7 @@ use bitmasks !$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc, delta_ii_s2_mrcc, delta_ij_s2_mrcc) & - !$OMP private(h, n, mask, omask, buf, ok, iproc) + !$OMP private(h, n, mask, omask, buf, ok, iproc) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) iproc = omp_get_thread_num() + 1 @@ -37,7 +38,7 @@ use bitmasks do p=hh_shortcut(h), hh_shortcut(h+1)-1 call apply_particle_local(mask, pp_exists(1, p), buf(1,1,n), ok, N_int) if(ok) n = n + 1 - if(n > N_det_non_ref) stop "MRCC..." + if(n > N_det_non_ref) stop "Buffer too small in MRCC..." end do n = n - 1 @@ -74,9 +75,9 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen logical :: good, fullMatch integer(bit_kind),allocatable :: tq(:,:,:) - integer :: N_tq, c_ref ,degree + integer :: N_tq, c_ref ,degree1, degree2, degree - double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states) + double precision :: hIk, hla, hIl, sla, dIk(N_states), dka(N_states), dIa(N_states), hka double precision, allocatable :: dIa_hla(:,:), dIa_sla(:,:) double precision :: haj, phase, phase2 double precision :: f(N_states), ci_inv(N_states) @@ -99,6 +100,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen !double precision, external :: get_dij, get_dij_index + leng = max(N_det_generators, N_det_non_ref) allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref), sij_cache(N_det_non_ref)) allocate(idx_alpha(0:psi_det_size), degree_alpha(psi_det_size)) @@ -189,17 +191,25 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen end do end if + if (perturbative_triples) then + double precision :: Delta_E_inv(N_states) + double precision, external :: diag_H_mat_elem + do i_state=1,N_states + Delta_E_inv(i_state) = 1.d0 / (psi_ref_energy_diagonalized(i_state) - diag_H_mat_elem(tq(1,1,i_alpha),N_int) ) + enddo + endif do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) call get_s2(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,sij_cache(k_sd)) enddo + ! |I> do i_I=1,N_det_ref ! Find triples and quadruple grand parents - call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree,Nint) - if (degree > 4) then + call get_excitation_degree(tq(1,1,i_alpha),psi_ref(1,1,i_I),degree1,Nint) + if (degree1 > 4) then cycle endif @@ -209,77 +219,57 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen ! |alpha> do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 - logical :: loop -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(k_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo -! if (loop) then -! cycle -! endif - + call get_excitation_degree(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),degree,Nint) if (degree > 2) then cycle endif - + ! - ! - !hIk = hij_mrcc(idx_alpha(k_sd),i_I) - ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) - - do i_state=1,N_states - dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) - !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) - !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) - enddo - ! |l> = Exc(k -> alpha) |I> - call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree2,phase,Nint) + call decode_exc(exc,degree2,h1,p1,h2,p2,s1,s2) do k=1,N_int tmp_det(k,1) = psi_ref(k,1,i_I) tmp_det(k,2) = psi_ref(k,2,i_I) enddo logical :: ok call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) - if(.not. ok) cycle + if (perturbative_triples) then + ok = ok .and. ( (degree2 /= 1).and.(degree /=1) ) + endif + + do i_state=1,N_states + dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state) + enddo ! do i_state=1,N_states dka(i_state) = 0.d0 enddo - do l_sd=k_sd+1,idx_alpha(0) - call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) - if (degree == 0) then - -! loop = .True. -! do i_state=1,N_states -! if (lambda_mrcc(i_state,idx_alpha(l_sd)) /= 0.d0) then -! loop = .False. -! exit -! endif -! enddo - loop = .false. - if (.not.loop) then + + if (ok) then + do l_sd=k_sd+1,idx_alpha(0) + call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) + if (degree == 0) then call get_excitation(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),exc,degree,phase2,Nint) - hIl = hij_mrcc(idx_alpha(l_sd),i_I) -! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) do i_state=1,N_states dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2 - !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 - !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 enddo + exit endif + enddo + + else if (perturbative_triples) then + + hka = hij_cache(idx_alpha(k_sd)) + do i_state=1,N_states + dka(i_state) = hka * Delta_E_inv(i_state) + enddo + + endif - exit - endif - enddo do i_state=1,N_states dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) enddo @@ -292,32 +282,35 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,delta_ij_s2_, delta_ii_s2_,i_gen k_sd = idx_alpha(l_sd) hla = hij_cache(k_sd) sla = sij_cache(k_sd) -! call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hla) do i_state=1,N_states dIa_hla(i_state,k_sd) = dIa(i_state) * hla dIa_sla(i_state,k_sd) = dIa(i_state) * sla enddo enddo - call omp_set_lock( psi_ref_lock(i_I) ) do i_state=1,N_states if(dabs(psi_ref_coef(i_I,i_state)).ge.1.d-3)then do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) + !$OMP ATOMIC delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + dIa_hla(i_state,k_sd) + !$OMP ATOMIC delta_ii_(i_state,i_I) = delta_ii_(i_state,i_I) - dIa_hla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) + !$OMP ATOMIC delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + dIa_sla(i_state,k_sd) + !$OMP ATOMIC delta_ii_s2_(i_state,i_I) = delta_ii_s2_(i_state,i_I) - dIa_sla(i_state,k_sd) * ci_inv(i_state) * psi_non_ref_coef_transp(i_state,k_sd) enddo else delta_ii_(i_state,i_I) = 0.d0 do l_sd=1,idx_alpha(0) k_sd = idx_alpha(l_sd) + !$OMP ATOMIC delta_ij_(i_state,k_sd,i_I) = delta_ij_(i_state,k_sd,i_I) + 0.5d0*dIa_hla(i_state,k_sd) + !$OMP ATOMIC delta_ij_s2_(i_state,k_sd,i_I) = delta_ij_s2_(i_state,k_sd,i_I) + 0.5d0*dIa_sla(i_state,k_sd) enddo endif enddo - call omp_unset_lock( psi_ref_lock(i_I) ) enddo enddo deallocate (dIa_hla,dIa_sla,hij_cache,sij_cache) @@ -691,7 +684,7 @@ subroutine getHP(a,h,p,Nint) end do lh h = deg !isInCassd = .true. -end subroutine +end function BEGIN_PROVIDER [ double precision, delta_mrcepa0_ij, (N_det_ref,N_det_non_ref,N_states) ] @@ -716,9 +709,6 @@ end subroutine integer :: II, blok integer*8, save :: notf = 0 - - PROVIDE psi_ref_coef psi_non_ref_coef - call wall_time(wall) allocate(idx_sorted_bit(N_det), sortRef(N_int,2,N_det_ref)) @@ -842,7 +832,8 @@ END_PROVIDER delta_sub_ij(:,:,:) = 0d0 delta_sub_ii(:,:) = 0d0 - provide mo_bielec_integrals_in_map N_det_non_ref psi_ref_coef psi_non_ref_coef + provide mo_bielec_integrals_in_map + !$OMP PARALLEL DO default(none) schedule(dynamic,10) shared(delta_sub_ij, delta_sub_ii) & !$OMP private(i, J, k, degree, degree2, l, deg, ni) & diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 9e9fa65a..487e6ed3 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -315,13 +315,13 @@ subroutine push_mrsc2_results(zmq_socket_push, I_i, J, delta, delta_s2, task_id) stop 'error' endif -! ! Activate is zmq_socket_push is a REQ -! integer :: idummy -! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' -! stop 'error' -! endif + ! Activate is zmq_socket_push is a REQ + integer :: idummy + rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' + stop 'error' + endif end @@ -389,13 +389,13 @@ subroutine pull_mrsc2_results(zmq_socket_pull, I_i, J, n, idx, delta, delta_s2, endif -! ! Activate is zmq_socket_pull is a REP -! integer :: idummy -! rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' -! stop 'error' -! endif + ! Activate is zmq_socket_pull is a REP + integer :: idummy + rc = f77_zmq_send( zmq_socket_pull, idummy, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_pull, idummy, 4, 0)' + stop 'error' + endif end diff --git a/plugins/mrcepa0/mrcc.irp.f b/plugins/mrcepa0/mrcc.irp.f index a5614942..bb184761 100644 --- a/plugins/mrcepa0/mrcc.irp.f +++ b/plugins/mrcepa0/mrcc.irp.f @@ -5,7 +5,7 @@ program mrsc2sub !mrmode : 1=mrcepa0, 2=mrsc2 add, 3=mrcc mrmode = 3 - + read_wf = .True. SOFT_TOUCH read_wf call set_generators_bitmasks_as_holes_and_particles diff --git a/promela/integrals.pml b/promela/integrals.pml new file mode 100644 index 00000000..7b05156f --- /dev/null +++ b/promela/integrals.pml @@ -0,0 +1,272 @@ +#define NPROC 1 +#define BUFSIZE 2 +#define NTASKS 3 + +mtype = { NONE, OK, WRONG_STATE, TERMINATE, GETPSI, PUTPSI, NEWJOB, ENDJOB, SETRUNNING, + SETWAITING, SETSTOPPED, CONNECT, DISCONNECT, ADDTASK, DELTASK, TASKDONE, GETTASK, + PSI, TASK, PUTPSI_REPLY, WAITING, RUNNING, STOPPED + } + +typedef rep_message { + mtype m = NONE; + byte value = 0; +} + +typedef req_message { + mtype m = NONE; + byte state = 0; + byte value = 0; + chan reply = [BUFSIZE] of { rep_message }; +} + +#define send_req( MESSAGE, VALUE ) msg.m=MESSAGE ; msg.value=VALUE ; msg.state=state; rep_socket ! msg; msg.reply ? reply + +chan rep_socket = [NPROC] of { req_message }; +chan pull_socket = [NPROC] of { byte }; +chan pair_socket = [NPROC] of { req_message }; +chan task_queue = [NTASKS+2] of { byte }; +chan pub_socket = [NTASKS+2] of { mtype }; + +bit socket_up = 0; +mtype global_state; /* Sent by pub */ + +active proctype qp_run() { + + bit psi = 0; + bit address_tcp = 0; + bit address_inproc = 0; + bit running = 0; + byte status = 0; + byte state = 0; + byte ntasks = 0; + req_message msg; + rep_message reply; + byte nclients = 0; + byte task; + + socket_up = 1; + running = 1; + do +// :: ( (running == 0) && (nclients == 0) && (ntasks == 0) ) -> break + :: ( running == 0 ) -> break + :: else -> + + rep_socket ? msg; + printf("req: "); printm(msg.m); printf("\t%d\n",msg.value); + + if + :: ( msg.m == TERMINATE ) -> + assert (state != 0); + assert (msg.state == state); + running = 0; + reply.m = OK; + + :: ( msg.m == PUTPSI ) -> + assert (state != 0); + assert (msg.state == state); + assert (psi == 0); + psi = 1; + reply.m = PUTPSI_REPLY; + + :: ( msg.m == GETPSI ) -> + assert (state != 0); + assert (msg.state == state); + assert (psi == 1); + reply.m = PSI; + + :: ( msg.m == NEWJOB ) -> + assert (state == 0); + state = msg.value; + pair_socket ! WAITING; + reply.m = OK; + reply.value = state; + + :: ( msg.m == ENDJOB ) -> + assert (state != 0); + assert (msg.state == state); + state = 0; + pair_socket ! WAITING; + reply.m = OK; + + :: ( msg.m == ADDTASK ) -> + assert (state != 0); + assert (msg.state == state); + task_queue ! msg.value; + ntasks++; + reply.m = OK; + + :: ( msg.m == GETTASK ) -> + assert (nclients > 0); + assert (state != 0); + assert (msg.state == state); + if + :: ( task_queue ?[task] ) -> + pair_socket ! WAITING; + reply.m = TASK; + task_queue ? reply.value + :: else -> + pair_socket ! RUNNING; + reply.m = NONE; + reply.value = 255; + fi; + + :: ( msg.m == TASKDONE) -> + assert (state != 0); + assert (msg.state == state); + assert (nclients > 0); + assert (ntasks > 0); + reply.m = OK; + + :: ( msg.m == DELTASK ) -> + assert (state != 0); + assert (msg.state == state); + ntasks--; + if + :: (ntasks > 0) -> reply.value = 1; + :: else -> reply.value = 0; + fi; + reply.m = OK; + + :: ( msg.m == CONNECT ) -> + assert ( state != 0 ) + nclients++; + reply.m = OK; + reply.value = state; + + :: ( msg.m == DISCONNECT ) -> + assert ( msg.state == state ) + nclients--; + reply.m = OK; + + :: ( msg.m == STOPPED ) -> + pair_socket ! STOPPED; + reply.m = OK; + + :: ( msg.m == WAITING ) -> + pair_socket ! WAITING; + reply.m = OK; + + :: ( msg.m == RUNNING ) -> + assert ( state != 0 ); + pair_socket ! RUNNING; + reply.m = OK; + + fi + msg.reply ! reply + od + pair_socket ! STOPPED; + socket_up = 0; + +} + + +active proctype master() { + + req_message msg; + rep_message reply; + byte state = 0; + byte count; + + run pub_thread(); + + /* New parallel job */ + state=1; + send_req( NEWJOB, state ); + assert (reply.m == OK); + + /* Add tasks */ + count = 0; + do + :: (count == NTASKS) -> break; + :: else -> + count++; + send_req( ADDTASK, count ); + assert (reply.m == OK); + od + + /* Run collector */ + run collector(state); + + /* Run slaves */ + count = 0; + do + :: (count == NPROC) -> break; + :: else -> count++; run slave(); + od + +} + +proctype slave() { + + req_message msg; + rep_message reply; + byte task; + byte state; + + msg.m=CONNECT; + msg.state = 0; + + if + :: (!socket_up) -> goto exit; + :: else -> skip; + fi + rep_socket ! msg; + + if + :: (!socket_up) -> goto exit; + :: else -> skip; + fi + msg.reply ? reply; + + state = reply.value; + + + task = 1; + do + :: (task == 255) -> break; + :: else -> + send_req( GETTASK, 0); + if + :: (reply.m == NONE) -> + task = 255; + :: (reply.m == TASK) -> + /* Compute task */ + task = reply.value; + send_req( TASKDONE, task); + assert (reply.m == OK); + pull_socket ! task; + fi + od + send_req( DISCONNECT, 0); + assert (reply.m == OK); + +exit: skip; +} + +proctype collector(byte state) { + byte task; + req_message msg; + rep_message reply; + bit loop = 1; + do + :: (loop == 0) -> break + :: else -> + pull_socket ? task; + /* Handle result */ + send_req(DELTASK, task); + assert (reply.m == OK); + loop = reply.value; + od + send_req( TERMINATE, 0); + assert (reply.m == OK); +} + +proctype pub_thread() { + mtype state = WAITING; + do + :: (state == STOPPED) -> break; + :: (pair_socket ? [state]) -> + pair_socket ? state; + global_state = state; + od +} diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 9c7a1386..af9b295c 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -1,6 +1,10 @@ -open Qputils;; -open Qptypes;; -open Core.Std;; +(* + vim::syntax=ocaml + *) + +open Qputils +open Qptypes +open Core.Std (** Interactive editing of the input. @@ -18,7 +22,7 @@ type keyword = | Mo_basis | Nuclei {keywords} -;; + let keyword_to_string = function @@ -28,7 +32,7 @@ let keyword_to_string = function | Mo_basis -> "MO basis" | Nuclei -> "Molecule" {keywords_to_string} -;; + @@ -42,7 +46,7 @@ let file_header filename = Editing file `%s` " filename -;; + (** Creates the header of a section *) @@ -50,7 +54,7 @@ let make_header kw = let s = keyword_to_string kw in let l = String.length s in "\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n" -;; + (** Returns the rst string of section [s] *) @@ -82,7 +86,7 @@ let get s = | Sys_error msg -> (Printf.eprintf "Info: %s\n%!" msg ; "") in rst -;; + (** Applies the changes from the string [str] corresponding to section [s] *) @@ -121,7 +125,7 @@ let set str s = | Ao_basis -> () (* TODO *) | Mo_basis -> () (* TODO *) end -;; + (** Creates the temporary file for interactive editing *) @@ -135,11 +139,19 @@ let create_temp_file ezfio_filename fields = ) end ; temp_filename -;; + -let run check_only ezfio_filename = + +let run check_only ?ndet ?state ezfio_filename = + + (* Set check_only if the arguments are not empty *) + let check_only = + match ndet, state with + | None, None -> check_only + | _ -> true + in (* Open EZFIO *) if (not (Sys.file_exists_exn ezfio_filename)) then @@ -147,6 +159,19 @@ let run check_only ezfio_filename = Ezfio.set_file ezfio_filename; + begin + match ndet with + | None -> () + | Some n -> Input.Determinants_by_hand.update_ndet (Det_number.of_int n) + end; + + begin + match state with + | None -> () + | Some n -> Input.Determinants_by_hand.extract_state (States_number.of_int n) + end; + + (* let output = (file_header ezfio_filename) :: ( List.map ~f:get [ @@ -196,7 +221,7 @@ let run check_only ezfio_filename = (* Remove temp_file *) Sys.remove temp_filename -;; + (** Create a backup file in case of an exception *) @@ -207,7 +232,7 @@ let create_backup ezfio_filename = " ezfio_filename ezfio_filename ezfio_filename |> Sys.command_exn -;; + (** Restore the backup file when an exception occuprs *) @@ -215,7 +240,7 @@ let restore_backup ezfio_filename = Printf.sprintf "tar -zxf %s/backup.tgz" ezfio_filename |> Sys.command_exn -;; + let spec = @@ -223,12 +248,12 @@ let spec = empty +> flag "-c" no_arg ~doc:"Checks the input data" -(* - +> flag "o" (optional string) - ~doc:"Prints output data" -*) + +> flag "ndet" (optional int) + ~doc:"int Truncate the wavefunction to the target number of determinants" + +> flag "state" (optional int) + ~doc:"int Pick the state as a new wavefunction." +> anon ("ezfio_file" %: string) -;; + let command = Command.basic @@ -245,9 +270,9 @@ Edit input data with | _ msg -> print_string ("\n\nError\n\n"^msg^"\n\n") *) - (fun c ezfio_file () -> + (fun c ndet state ezfio_file () -> try - run c ezfio_file ; + run c ?ndet ?state ezfio_file ; (* create_backup ezfio_file; *) with | Failure exc @@ -268,12 +293,12 @@ Edit input data raise e end ) -;; + let () = Command.run command; exit 0 -;; + diff --git a/scripts/module/module_handler.py b/scripts/module/module_handler.py index 7c729827..e6a13441 100755 --- a/scripts/module/module_handler.py +++ b/scripts/module/module_handler.py @@ -254,7 +254,7 @@ if __name__ == '__main__': except RuntimeError: pass except SyntaxError: - print "Warning: The graphviz API drop support of python 2.6." + print "Warning: The graphviz API dropped support for python 2.6." pass if arguments["clean"] or arguments["create_git_ignore"]: @@ -302,7 +302,7 @@ if __name__ == '__main__': from is_master_repository import is_master_repository if not is_master_repository: print >> sys.stderr, 'Not in the master repo' - sys.exit() + sys.exit(0) path = os.path.join(module_abs, ".gitignore") diff --git a/src/.gitignore b/src/.gitignore deleted file mode 100644 index 535e4bd5..00000000 --- a/src/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -CAS_SD -CID -CID_SC2_selected -CID_selected -CIS -CISD -CISD_SC2_selected -CISD_selected -DDCI_selected -DensityMatrix -FCIdump -Full_CI -Generators_CAS -Generators_full -Generators_restart -Hartree_Fock -Molden -MP2 -MRCC -Perturbation -Properties -QmcChem -Selectors_full -Selectors_no_sorted -SingleRefMethod -Casino -loc_cele -Alavi \ No newline at end of file diff --git a/src/AO_Basis/.gitignore b/src/AO_Basis/.gitignore deleted file mode 100644 index 7305be49..00000000 --- a/src/AO_Basis/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Nuclei -Ezfio_files -Utils \ No newline at end of file diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index 0938d3bd..f0f03fab 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -182,7 +182,7 @@ integer function ao_power_index(nx,ny,nz) end -BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] +BEGIN_PROVIDER [ character*(128), l_to_charater, (0:7)] BEGIN_DOC ! character corresponding to the "L" value of an AO orbital END_DOC @@ -192,6 +192,9 @@ BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] l_to_charater(2)='D' l_to_charater(3)='F' l_to_charater(4)='G' + l_to_charater(5)='H' + l_to_charater(6)='I' + l_to_charater(7)='J' END_PROVIDER diff --git a/src/Bitmask/.gitignore b/src/Bitmask/.gitignore deleted file mode 100644 index 2b7b2272..00000000 --- a/src/Bitmask/.gitignore +++ /dev/null @@ -1,18 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -MO_Basis -Utils -AO_Basis -Electrons -Nuclei \ No newline at end of file diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 964c4ed8..e50cf25a 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -2,10 +2,16 @@ use bitmasks BEGIN_PROVIDER [ integer, N_int ] implicit none + include 'Utils/constants.include.F' BEGIN_DOC ! Number of 64-bit integers needed to represent determinants as binary strings END_DOC N_int = (mo_tot_num-1)/bit_kind_size + 1 + call write_int(6,N_int, 'N_int') + if (N_int > N_int_max) then + stop 'N_int > N_int_max' + endif + END_PROVIDER @@ -386,6 +392,8 @@ END_PROVIDER n_virt_orb += popcnt(virt_bitmask(i,1)) enddo endif + call write_int(6,n_inact_orb, 'Number of inactive MOs') + call write_int(6,n_virt_orb, 'Number of virtual MOs') END_PROVIDER @@ -554,7 +562,7 @@ END_PROVIDER &BEGIN_PROVIDER [ integer, n_core_orb] implicit none BEGIN_DOC - ! Core orbitals bitmask + ! Core + deleted orbitals bitmask END_DOC integer :: i,j n_core_orb = 0 @@ -563,7 +571,7 @@ END_PROVIDER core_bitmask(i,2) = xor(full_ijkl_bitmask(i),ior(reunion_of_cas_inact_bitmask(i,2),virt_bitmask(i,1))) n_core_orb += popcnt(core_bitmask(i,1)) enddo - print*,'n_core_orb = ',n_core_orb + call write_int(6,n_core_orb,'Number of core MOs') END_PROVIDER @@ -598,7 +606,7 @@ BEGIN_PROVIDER [ integer, n_act_orb] do i = 1, N_int n_act_orb += popcnt(cas_bitmask(i,1,1)) enddo - print*,'n_act_orb = ',n_act_orb + call write_int(6,n_act_orb, 'Number of active MOs') END_PROVIDER BEGIN_PROVIDER [integer, list_act, (n_act_orb)] diff --git a/src/Davidson/EZFIO.cfg b/src/Davidson/EZFIO.cfg index 84c292dd..49a0f778 100644 --- a/src/Davidson/EZFIO.cfg +++ b/src/Davidson/EZFIO.cfg @@ -28,3 +28,9 @@ doc: If true, disk space is used to store the vectors default: False interface: ezfio,provider,ocaml +[distributed_davidson] +type: logical +doc: If true, use the distributed algorithm +default: False +interface: ezfio,provider,ocaml + diff --git a/src/Davidson/davidson_parallel.irp.f b/src/Davidson/davidson_parallel.irp.f index 37c87878..68db35da 100644 --- a/src/Davidson/davidson_parallel.irp.f +++ b/src/Davidson/davidson_parallel.irp.f @@ -394,4 +394,3 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze) enddo end - diff --git a/src/Davidson/davidson_slave.irp.f b/src/Davidson/davidson_slave.irp.f index 8aa0d6e7..e917c664 100644 --- a/src/Davidson/davidson_slave.irp.f +++ b/src/Davidson/davidson_slave.irp.f @@ -29,4 +29,3 @@ subroutine provide_everything PROVIDE mo_bielec_integrals_in_map psi_det_sorted_bit N_states_diag zmq_context ref_bitmask_energy end subroutine - diff --git a/src/Davidson/diagonalization.irp.f b/src/Davidson/diagonalization.irp.f index 4d9a67d5..e4d51198 100644 --- a/src/Davidson/diagonalization.irp.f +++ b/src/Davidson/diagonalization.irp.f @@ -354,7 +354,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia write(iunit,'(A)') trim(write_buffer) write_buffer = ' Iter' do i=1,N_st - write_buffer = trim(write_buffer)//' Energy Residual' + write_buffer = trim(write_buffer)//' Energy Residual' enddo write(iunit,'(A)') trim(write_buffer) write_buffer = '===== ' @@ -500,7 +500,7 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,N_st_dia endif enddo - write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st) + write(iunit,'(1X,I3,1X,100(1X,F16.10,1X,E16.6))') iter, to_print(:,1:N_st) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) if (converged) then exit diff --git a/src/Davidson/find_reference.irp.f b/src/Davidson/find_reference.irp.f new file mode 100644 index 00000000..0cafd739 --- /dev/null +++ b/src/Davidson/find_reference.irp.f @@ -0,0 +1,41 @@ +subroutine find_reference(thresh,n_ref,result) + implicit none + double precision, intent(in) :: thresh + integer, intent(out) :: result(N_det),n_ref + integer :: i,j,istate + double precision :: i_H_psi_array(1), E0, hii, norm + double precision :: de + integer(bit_kind), allocatable :: psi_ref_(:,:,:) + double precision, allocatable :: psi_ref_coef_(:,:) + + allocate(psi_ref_coef_(N_det,1), psi_ref_(N_int,2,N_det)) + n_ref = 1 + result(1) = 1 + istate = 1 + psi_ref_coef_(1,1) = psi_coef(1,istate) + psi_ref_(:,:,1) = psi_det(:,:,1) + norm = psi_ref_coef_(1,1) * psi_ref_coef_(1,1) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, '' + print *, 'Reference determinants' + print *, '======================' + print *, '' + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + do i=2,N_det + call i_h_psi(psi_det(1,1,i),psi_ref_(1,1,1),psi_ref_coef_(1,istate),N_int, & + n_ref,size(psi_ref_coef_,1),1,i_H_psi_array) + call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii) + de = i_H_psi_array(istate)**2 / (E0 - hii) + if (dabs(de) > thresh) then + n_ref += 1 + result(n_ref) = i + psi_ref_(:,:,n_ref) = psi_det(:,:,i) + psi_ref_coef_(n_ref,1) = psi_coef(i,istate) + call u_0_H_u_0(E0,psi_ref_coef_,n_ref,psi_ref_,N_int,1,size(psi_ref_coef_,1)) + print *, n_ref, ': E0 = ', E0 + nuclear_repulsion + call debug_det(psi_ref_(1,1,n_ref),N_int) + endif + enddo +end + diff --git a/src/Davidson/parameters.irp.f b/src/Davidson/parameters.irp.f index ae8babaa..7d383192 100644 --- a/src/Davidson/parameters.irp.f +++ b/src/Davidson/parameters.irp.f @@ -18,6 +18,11 @@ subroutine davidson_converged(energy,residual,wall,iterations,cpu,N_st,converged double precision :: E(N_st), time double precision, allocatable, save :: energy_old(:) + if (iterations < 2) then + converged = .False. + return + endif + if (.not.allocated(energy_old)) then allocate(energy_old(N_st)) energy_old = 0.d0 diff --git a/src/Determinants/EZFIO.cfg b/src/Determinants/EZFIO.cfg index 0676649e..a68a61a5 100644 --- a/src/Determinants/EZFIO.cfg +++ b/src/Determinants/EZFIO.cfg @@ -38,7 +38,7 @@ default: False type: logical doc: Force the wave function to be an eigenfunction of S^2 interface: ezfio,provider,ocaml -default: False +default: True [threshold_generators] type: Threshold diff --git a/src/Determinants/Fock_diag.irp.f b/src/Determinants/Fock_diag.irp.f index a99bbcad..01393fe1 100644 --- a/src/Determinants/Fock_diag.irp.f +++ b/src/Determinants/Fock_diag.irp.f @@ -19,6 +19,15 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint) fock_diag_tmp = 0.d0 E0 = 0.d0 + if (Ne(1) /= elec_alpha_num) then + print *, 'Error in build_fock_tmp (alpha)', Ne(1), Ne(2) + stop -1 + endif + if (Ne(2) /= elec_beta_num) then + print *, 'Error in build_fock_tmp (beta)', Ne(1), Ne(2) + stop -1 + endif + ! Occupied MOs do ii=1,elec_alpha_num i = occ(ii,1) diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index 411fe703..a6a7310f 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -362,12 +362,12 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,t endif ! Activate if zmq_socket_push is a REQ -! integer :: idummy -! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' -! stop 'error' -! endif + integer :: idummy + rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' + stop 'error' + endif end subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n,task_id) @@ -433,11 +433,11 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n endif ! Activate if zmq_socket_pull is a REP -! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) -! if (rc /= 4) then -! print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)' -! stop 'error' -! endif + rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) + if (rc /= 4) then + print *, irp_here, 'f77_zmq_send( zmq_socket_pull, 0, 4, 0)' + stop 'error' + endif end diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index 59544b79..ddedc5a2 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -38,7 +38,7 @@ subroutine $subroutine($params_main) do i_generator=1,N_det_generators $skip write(task,*) i_generator - call add_task_to_taskserver(zmq_to_qp_run_socket,task) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo allocate ( pt2_generators(N_states,N_det_generators), & diff --git a/src/Determinants/density_matrix.irp.f b/src/Determinants/density_matrix.irp.f index 118bbdf7..923318bc 100644 --- a/src/Determinants/density_matrix.irp.f +++ b/src/Determinants/density_matrix.irp.f @@ -27,62 +27,101 @@ END_PROVIDER double precision :: ck, cl, ckl double precision :: phase integer :: h1,h2,p1,p2,s1,s2, degree - integer :: exc(0:2,2,2),n_occ(2) + integer(bit_kind) :: tmp_det(N_int,2), tmp_det2(N_int) + integer :: exc(0:2,2),n_occ(2) double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) + integer :: krow, kcol, lrow, lcol - one_body_dm_mo_alpha = 0.d0 - one_body_dm_mo_beta = 0.d0 - !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & - !$OMP tmp_a, tmp_b, n_occ)& - !$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,& - !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& - !$OMP mo_tot_num) - allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) ) - tmp_a = 0.d0 - tmp_b = 0.d0 - !$OMP DO SCHEDULE(dynamic) - do k=1,N_det - call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) - do m=1,N_states - ck = psi_coef(k,m)*psi_coef(k,m) - do l=1,elec_alpha_num - j = occ(l,1) - tmp_a(j,j,m) += ck - enddo - do l=1,elec_beta_num - j = occ(l,2) - tmp_b(j,j,m) += ck - enddo - enddo - do l=1,k-1 - call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) - if (degree /= 1) then - cycle - endif - call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) - call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) - do m=1,N_states - ckl = psi_coef(k,m) * psi_coef(l,m) * phase - if (s1==1) then - tmp_a(h1,p1,m) += ckl - tmp_a(p1,h1,m) += ckl - else - tmp_b(h1,p1,m) += ckl - tmp_b(p1,h1,m) += ckl - endif - enddo - enddo - enddo - !$OMP END DO NOWAIT - !$OMP CRITICAL - one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) - !$OMP END CRITICAL - !$OMP CRITICAL - one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) - !$OMP END CRITICAL - deallocate(tmp_a,tmp_b) - !$OMP END PARALLEL + PROVIDE psi_det + + one_body_dm_mo_alpha = 0.d0 + one_body_dm_mo_beta = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2)& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,& + !$OMP elec_beta_num,one_body_dm_mo_alpha,one_body_dm_mo_beta,N_det,mo_tot_num_align,& + !$OMP mo_tot_num,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns, & + !$OMP psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns, & + !$OMP psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique, & + !$OMP psi_bilinear_matrix_values, psi_bilinear_matrix_transp_values) + allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(guided) + do k=1,N_det + krow = psi_bilinear_matrix_rows(k) + kcol = psi_bilinear_matrix_columns(k) + tmp_det(:,1) = psi_det_alpha_unique(:,krow) + tmp_det(:,2) = psi_det_beta_unique (:,kcol) + call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int) + do m=1,N_states + ck = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_values(k,m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j,m) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j,m) += ck + enddo + enddo + + l = k+1 + lrow = psi_bilinear_matrix_rows(l) + lcol = psi_bilinear_matrix_columns(l) + ! Fix beta determinant, loop over alphas + do while ( lcol == kcol ) + tmp_det2(:) = psi_det_alpha_unique(:, lrow) + call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int) + if (degree == 1) then + exc = 0 + call get_mono_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_values(l,m) * phase + tmp_a(h1,p1,m) += ckl + tmp_a(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_rows(l) + lcol = psi_bilinear_matrix_columns(l) + enddo + + l = psi_bilinear_matrix_order_reverse(k)+1 + ! Fix alpha determinant, loop over betas + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + do while ( lrow == krow ) + tmp_det2(:) = psi_det_beta_unique (:, lcol) + call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int) + if (degree == 1) then + call get_mono_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int) + call decode_exc_spin(exc,h1,p1,h2,p2) + do m=1,N_states + ckl = psi_bilinear_matrix_values(k,m)*psi_bilinear_matrix_transp_values(l,m) * phase + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + enddo + endif + l = l+1 + if (l>N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l) + lcol = psi_bilinear_matrix_transp_columns(l) + enddo + + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha(:,:,:) = one_body_dm_mo_alpha(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta(:,:,:) = one_body_dm_mo_beta(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL END_PROVIDER @@ -194,7 +233,6 @@ subroutine set_natural_mos double precision, allocatable :: tmp(:,:) label = "Natural" -! call mo_as_eigvectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,label,-1) call mo_as_svd_vectors_of_mo_matrix(one_body_dm_mo,size(one_body_dm_mo,1),mo_tot_num,mo_tot_num,label) end @@ -270,3 +308,74 @@ END_PROVIDER END_PROVIDER + + BEGIN_PROVIDER [ double precision, one_body_dm_mo_alpha_old, (mo_tot_num_align,mo_tot_num,N_states) ] +&BEGIN_PROVIDER [ double precision, one_body_dm_mo_beta_old, (mo_tot_num_align,mo_tot_num,N_states) ] + implicit none + BEGIN_DOC + ! Alpha and beta one-body density matrix for each state + END_DOC + + integer :: j,k,l,m + integer :: occ(N_int*bit_kind_size,2) + double precision :: ck, cl, ckl + double precision :: phase + integer :: h1,h2,p1,p2,s1,s2, degree + integer :: exc(0:2,2,2),n_occ(2) + double precision, allocatable :: tmp_a(:,:,:), tmp_b(:,:,:) + + one_body_dm_mo_alpha_old = 0.d0 + one_body_dm_mo_beta_old = 0.d0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc, & + !$OMP tmp_a, tmp_b, n_occ)& + !$OMP SHARED(psi_det,psi_coef,N_int,N_states,elec_alpha_num,& + !$OMP elec_beta_num,one_body_dm_mo_alpha_old,one_body_dm_mo_beta_old,N_det,mo_tot_num_align,& + !$OMP mo_tot_num) + allocate(tmp_a(mo_tot_num_align,mo_tot_num,N_states), tmp_b(mo_tot_num_align,mo_tot_num,N_states) ) + tmp_a = 0.d0 + tmp_b = 0.d0 + !$OMP DO SCHEDULE(dynamic) + do k=1,N_det + call bitstring_to_list_ab(psi_det(1,1,k), occ, n_occ, N_int) + do m=1,N_states + ck = psi_coef(k,m)*psi_coef(k,m) + do l=1,elec_alpha_num + j = occ(l,1) + tmp_a(j,j,m) += ck + enddo + do l=1,elec_beta_num + j = occ(l,2) + tmp_b(j,j,m) += ck + enddo + enddo + do l=1,k-1 + call get_excitation_degree(psi_det(1,1,k),psi_det(1,1,l),degree,N_int) + if (degree /= 1) then + cycle + endif + call get_mono_excitation(psi_det(1,1,k),psi_det(1,1,l),exc,phase,N_int) + call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) + do m=1,N_states + ckl = psi_coef(k,m) * psi_coef(l,m) * phase + if (s1==1) then + tmp_a(h1,p1,m) += ckl + tmp_a(p1,h1,m) += ckl + else + tmp_b(h1,p1,m) += ckl + tmp_b(p1,h1,m) += ckl + endif + enddo + enddo + enddo + !$OMP END DO NOWAIT + !$OMP CRITICAL + one_body_dm_mo_alpha_old(:,:,:) = one_body_dm_mo_alpha_old(:,:,:) + tmp_a(:,:,:) + !$OMP END CRITICAL + !$OMP CRITICAL + one_body_dm_mo_beta_old(:,:,:) = one_body_dm_mo_beta_old(:,:,:) + tmp_b(:,:,:) + !$OMP END CRITICAL + deallocate(tmp_a,tmp_b) + !$OMP END PARALLEL + +END_PROVIDER diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index bed3327d..2644801e 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -23,7 +23,7 @@ BEGIN_PROVIDER [ integer, N_det ] ! Number of determinants in the wave function END_DOC logical :: exists - character*64 :: label + character*(64) :: label PROVIDE ezfio_filename PROVIDE nproc if (read_wf) then @@ -88,7 +88,7 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ] END_DOC integer :: i logical :: exists - character*64 :: label + character*(64) :: label psi_det = 0_bit_kind if (read_wf) then diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index da333b1e..b76540f7 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -1,4 +1,102 @@ +subroutine filter_not_connected(key1,key2,Nint,sze,idx) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the array idx which contains the index of the + ! + ! determinants in the array key1 that DO NOT interact + ! + ! via the H operator with key2. + ! + ! idx(0) is the number of determinants that DO NOT interact with key1 + END_DOC + integer, intent(in) :: Nint, sze + integer(bit_kind), intent(in) :: key1(Nint,2,sze) + integer(bit_kind), intent(in) :: key2(Nint,2) + integer, intent(out) :: idx(0:sze) + + integer :: i,j,l + integer :: degree_x2 + + + ASSERT (Nint > 0) + ASSERT (sze >= 0) + + l=1 + + if (Nint==1) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt( xor( key1(1,1,i), key2(1,1))) & + + popcnt( xor( key1(1,2,i), key2(1,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==2) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else if (Nint==3) then + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = popcnt(xor( key1(1,1,i), key2(1,1))) + & + popcnt(xor( key1(1,2,i), key2(1,2))) + & + popcnt(xor( key1(2,1,i), key2(2,1))) + & + popcnt(xor( key1(2,2,i), key2(2,2))) + & + popcnt(xor( key1(3,1,i), key2(3,1))) + & + popcnt(xor( key1(3,2,i), key2(3,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + else + cycle + endif + enddo + + else + + !DIR$ LOOP COUNT (1000) + do i=1,sze + degree_x2 = 0 + !DEC$ LOOP COUNT MIN(4) + do j=1,Nint + degree_x2 = degree_x2+ popcnt(xor( key1(j,1,i), key2(j,1))) +& + popcnt(xor( key1(j,2,i), key2(j,2))) + if (degree_x2 > 4) then + idx(l) = i + l = l+1 + endif + enddo + if (degree_x2 <= 5) then + exit + endif + enddo + + endif + idx(0) = l-1 +end + + subroutine filter_connected(key1,key2,Nint,sze,idx) use bitmasks implicit none diff --git a/src/Determinants/occ_pattern.irp.f b/src/Determinants/occ_pattern.irp.f index 42bca8eb..38460f87 100644 --- a/src/Determinants/occ_pattern.irp.f +++ b/src/Determinants/occ_pattern.irp.f @@ -36,7 +36,7 @@ subroutine occ_pattern_to_dets_size(o,sze,n_alpha,Nint) amax -= popcnt( o(k,2) ) enddo sze = int( min(binom_func(bmax, amax), 1.d8) ) - sze = sze*sze + sze = 2*sze*sze + 16 end @@ -246,14 +246,22 @@ subroutine make_s2_eigenfunction integer :: i,j,k integer :: smax, s integer(bit_kind), allocatable :: d(:,:,:), det_buffer(:,:,:) - integer :: N_det_new + integer :: N_det_new, ithread, omp_get_thread_num integer, parameter :: bufsze = 1000 logical, external :: is_in_wavefunction - allocate (d(N_int,2,1), det_buffer(N_int,2,bufsze) ) - smax = 1 - N_det_new = 0 + call write_int(6,N_occ_pattern,'Number of occupation patterns') + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(N_occ_pattern, psi_occ_pattern, elec_alpha_num,N_int) & + !$OMP PRIVATE(s,ithread, d, det_buffer, smax, N_det_new,i,j,k) + N_det_new = 0 + call occ_pattern_to_dets_size(psi_occ_pattern(1,1,1),s,elec_alpha_num,N_int) + allocate (d(N_int,2,s), det_buffer(N_int,2,bufsze) ) + smax = s + ithread=0 + !$ ithread = omp_get_thread_num() + !$OMP DO do i=1,N_occ_pattern call occ_pattern_to_dets_size(psi_occ_pattern(1,1,i),s,elec_alpha_num,N_int) s += 1 @@ -270,40 +278,26 @@ subroutine make_s2_eigenfunction det_buffer(k,1,N_det_new) = d(k,1,j) det_buffer(k,2,N_det_new) = d(k,2,j) enddo -! integer :: ne(2) -! ne(:) = 0 -! do k=1,N_int -! ne(1) += popcnt(d(k,1,j)) -! ne(2) += popcnt(d(k,2,j)) -! enddo -! if (ne(1) /= elec_alpha_num) then -! call debug_det(d(1,1,j),N_int) -! stop "ALPHA" -! endif -! if (ne(2) /= elec_beta_num) then -! call debug_det(d(1,1,j),N_int) -! stop "BETA" -! endif if (N_det_new == bufsze) then - call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,0) + call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread) N_det_new = 0 endif endif enddo enddo + !$OMP END DO NOWAIT if (N_det_new > 0) then - call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,0) -! call fill_H_apply_buffer_no_selection_first_order_coef(N_det_new,det_buffer,N_int,0) + call fill_H_apply_buffer_no_selection(N_det_new,det_buffer,N_int,ithread) endif - + !$OMP BARRIER deallocate(d,det_buffer) + !$OMP END PARALLEL call copy_H_apply_buffer_to_wf SOFT_TOUCH N_det psi_coef psi_det print *, 'Added determinants for S^2' -! logical :: found -! call remove_duplicates_in_psi_det(found) + call write_time(6) end diff --git a/src/Determinants/print_wf.irp.f b/src/Determinants/print_wf.irp.f index af109e2d..737e4d3e 100644 --- a/src/Determinants/print_wf.irp.f +++ b/src/Determinants/print_wf.irp.f @@ -28,32 +28,32 @@ subroutine routine if(degree == 0)then print*,'Reference determinant ' else - call i_H_j(psi_det(1,1,i),psi_det(1,1,1),N_int,hij) + call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij) call get_excitation(psi_det(1,1,1),psi_det(1,1,i),exc,degree,phase,N_int) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) print*,'phase = ',phase - if(degree == 1)then - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - if(s1 == 1)then - norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) - else - norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) - endif - print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) - double precision :: hmono,hdouble - call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) - print*,'hmono = ',hmono - print*,'hdouble = ',hdouble - print*,'hmono+hdouble = ',hmono+hdouble - print*,'hij = ',hij - else - print*,'s1',s1 - print*,'h1,p1 = ',h1,p1 - print*,'s2',s2 - print*,'h2,p2 = ',h2,p2 - print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) - endif +! if(degree == 1)then +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! if(s1 == 1)then +! norm_mono_a += dabs(psi_coef(i,1)/psi_coef(1,1)) +! else +! norm_mono_b += dabs(psi_coef(i,1)/psi_coef(1,1)) +! endif +! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,list_act(1),list_act(1),p1,mo_integrals_map) +! double precision :: hmono,hdouble +! call i_H_j_verbose(psi_det(1,1,1),psi_det(1,1,i),N_int,hij,hmono,hdouble) +! print*,'hmono = ',hmono +! print*,'hdouble = ',hdouble +! print*,'hmono+hdouble = ',hmono+hdouble +! print*,'hij = ',hij +! else +! print*,'s1',s1 +! print*,'h1,p1 = ',h1,p1 +! print*,'s2',s2 +! print*,'h2,p2 = ',h2,p2 +! print*,'< h | Ka| p > = ',get_mo_bielec_integral(h1,h2,p1,p2,mo_integrals_map) +! endif print*,' = ',hij endif diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 4409502b..0340361d 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -253,13 +253,12 @@ subroutine S2_u_0_nstates(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8) enddo !$OMP END DO NOWAIT - !$OMP CRITICAL do istate=1,N_st do i=n,1,-1 + !$OMP ATOMIC v_0(i,istate) = v_0(i,istate) + vt(i,istate) enddo enddo - !$OMP END CRITICAL deallocate(vt) !$OMP END PARALLEL @@ -283,8 +282,8 @@ end subroutine get_uJ_s2_uI(psi_keys_tmp,psi_coefs_tmp,n,nmax_coefs,nmax_keys,s2,nstates) implicit none use bitmasks - integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys) integer, intent(in) :: n,nmax_coefs,nmax_keys,nstates + integer(bit_kind), intent(in) :: psi_keys_tmp(N_int,2,nmax_keys) double precision, intent(in) :: psi_coefs_tmp(nmax_coefs,nstates) double precision, intent(out) :: s2(nstates,nstates) double precision :: s2_tmp,accu @@ -375,7 +374,7 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,u_0,n,nmax_keys,nmax_coefs,nsta print*,'S^2 matrix in the basis of the states considered' do i = 1, nstates - write(*,'(100(F5.2,X))')s2(i,:) + write(*,'(100(F5.2,1X))')s2(i,:) enddo double precision :: accu_precision_diag,accu_precision_of_diag @@ -401,7 +400,7 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,u_0,n,nmax_keys,nmax_coefs,nsta print*,'Modified S^2 matrix that will be diagonalized' do i = 1, nstates - write(*,'(10(F5.2,X))')s2(i,:) + write(*,'(10(F5.2,1X))')s2(i,:) s2(i,i) = s2(i,i) enddo diff --git a/src/Determinants/spindeterminants.irp.f b/src/Determinants/spindeterminants.irp.f index 5a5723ae..aa7fde29 100644 --- a/src/Determinants/spindeterminants.irp.f +++ b/src/Determinants/spindeterminants.irp.f @@ -650,7 +650,7 @@ subroutine generate_all_alpha_beta_det_products !$OMP PARALLEL DEFAULT(NONE) SHARED(psi_coef_sorted_bit,N_det_beta_unique,& !$OMP N_det_alpha_unique, N_int, psi_det_alpha_unique, psi_det_beta_unique,& !$OMP N_det) & - !$OMP PRIVATE(i,j,k,l,tmp_det,idx,iproc) + !$OMP PRIVATE(i,j,k,l,tmp_det,iproc) !$ iproc = omp_get_thread_num() allocate (tmp_det(N_int,2,N_det_alpha_unique)) !$OMP DO @@ -675,8 +675,6 @@ subroutine generate_all_alpha_beta_det_products end -<<<<<<< HEAD -======= subroutine get_all_spin_singles_and_doubles(buffer, idx, spindet, Nint, size_buffer, singles, doubles, n_singles, n_doubles) diff --git a/src/Determinants/usefull_for_ovb.irp.f b/src/Determinants/useful_for_ovb.irp.f similarity index 97% rename from src/Determinants/usefull_for_ovb.irp.f rename to src/Determinants/useful_for_ovb.irp.f index 7b89897b..25bdb03a 100644 --- a/src/Determinants/usefull_for_ovb.irp.f +++ b/src/Determinants/useful_for_ovb.irp.f @@ -2,7 +2,8 @@ integer function n_open_shell(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer :: i n_open_shell = 0 do i=1,Nint @@ -13,7 +14,8 @@ end integer function n_closed_shell(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer :: i n_closed_shell = 0 do i=1,Nint @@ -24,7 +26,8 @@ end integer function n_closed_shell_cas(det_in,nint) implicit none use bitmasks - integer(bit_kind), intent(in) :: det_in(nint,2),nint + integer, intent(in) :: nint + integer(bit_kind), intent(in) :: det_in(nint,2) integer(bit_kind) :: det_tmp(nint,2) integer :: i n_closed_shell_cas = 0 diff --git a/src/Electrons/.gitignore b/src/Electrons/.gitignore deleted file mode 100644 index b2bd2f7f..00000000 --- a/src/Electrons/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files \ No newline at end of file diff --git a/src/Ezfio_files/.gitignore b/src/Ezfio_files/.gitignore deleted file mode 100644 index 24230463..00000000 --- a/src/Ezfio_files/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -README.rst \ No newline at end of file diff --git a/src/Integrals_Bielec/.gitignore b/src/Integrals_Bielec/.gitignore deleted file mode 100644 index aaf8a3d5..00000000 --- a/src/Integrals_Bielec/.gitignore +++ /dev/null @@ -1,22 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Bitmask -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ZMQ -ezfio_interface.irp.f -irpf90.make -irpf90_entities -qp_ao_ints -tags -test_integrals \ No newline at end of file diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index 6ce159af..4750d5a0 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -346,6 +346,7 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] integer :: n_integrals, rc integer :: kk, m, j1, i1, lmax + character*(64) :: fmt integral = ao_bielec_integral(1,1,1,1) @@ -365,14 +366,16 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ] call cpu_time(cpu_1) integer(ZMQ_PTR) :: zmq_to_qp_run_socket - character*(32) :: task - call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') - do l=ao_num,1,-1 - write(task,*) "triangle ", l - call add_task_to_taskserver(zmq_to_qp_run_socket,task) + character(len=:), allocatable :: task + allocate(character(len=ao_num*12) :: task) + write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))' + do l=1,ao_num + write(task,fmt) (i,l, i=1,l) + call add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) enddo + deallocate(task) call zmq_set_running(zmq_to_qp_run_socket) diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f index ce4518cf..38c78388 100644 --- a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -57,12 +57,12 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, endif ! Activate is zmq_socket_push is a REQ -! integer :: idummy -! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) -! if (rc /= 4) then -! print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' -! stop 'error' -! endif + integer :: idummy + rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) + if (rc /= 4) then + print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)' + stop 'error' + endif end @@ -187,11 +187,11 @@ subroutine ao_bielec_integrals_in_map_collector rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) ! Activate if zmq_socket_pull is a REP -! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) -! if (rc /= 4) then -! print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' -! stop 'error' -! endif + rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0) + if (rc /= 4) then + print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...' + stop 'error' + endif call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 1f2a7a1b..82b89f22 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -44,8 +44,8 @@ subroutine bielec_integrals_index_reverse(i,j,k,l,i1) l(1) = ceiling(0.5d0*(dsqrt(8.d0*dble(i2)+1.d0)-1.d0)) i3 = i1 - ishft(i2*i2-i2,-1) k(1) = ceiling(0.5d0*(dsqrt(8.d0*dble(i3)+1.d0)-1.d0)) - j(1) = i2 - ishft(l(1)*l(1)-l(1),-1) - i(1) = i3 - ishft(k(1)*k(1)-k(1),-1) + j(1) = int(i2 - ishft(l(1)*l(1)-l(1),-1),4) + i(1) = int(i3 - ishft(k(1)*k(1)-k(1),-1),4) !ijkl i(2) = i(1) !ilkj diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 442c38b5..05eb8dff 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -35,6 +35,8 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) print*, 'MO integrals provided' return + else + PROVIDE ao_bielec_integrals_in_map endif if(no_vvvv_integrals)then diff --git a/src/Integrals_Monoelec/.gitignore b/src/Integrals_Monoelec/.gitignore deleted file mode 100644 index 577068de..00000000 --- a/src/Integrals_Monoelec/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -check_orthonormality -ezfio_interface.irp.f -irpf90.make -irpf90_entities -save_ortho_mos -tags \ No newline at end of file diff --git a/src/Integrals_Monoelec/check_orthonormality.irp.f b/src/Integrals_Monoelec/check_orthonormality.irp.f index 749e74f0..44294023 100644 --- a/src/Integrals_Monoelec/check_orthonormality.irp.f +++ b/src/Integrals_Monoelec/check_orthonormality.irp.f @@ -11,10 +11,10 @@ end subroutine do_print implicit none integer :: i,j - real :: off_diag, diag + double precision :: off_diag, diag - off_diag = 0. - diag = 0. + off_diag = 0.d0 + diag = 0.d0 do j=1,mo_tot_num do i=1,mo_tot_num off_diag += abs(mo_overlap(i,j)) diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 6f1fd905..22cceab9 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,7 +3,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential integrals END_DOC - + if (read_ao_one_integrals) then call read_one_e_integrals('ao_pseudo_integral', ao_pseudo_integral,& size(ao_pseudo_integral,1), size(ao_pseudo_integral,2)) @@ -53,6 +53,7 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) + thread_num = 0 !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -65,6 +66,8 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$OMP wall_1) !$ thread_num = omp_get_thread_num() + + wall_0 = wall_1 !$OMP DO SCHEDULE (guided) do j = 1, ao_num @@ -102,7 +105,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_k_transp (1,k), & pseudo_dz_k_transp(1,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) - enddo ao_pseudo_integral_local(i,j) = ao_pseudo_integral_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -150,12 +152,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu call wall_time(wall_1) call cpu_time(cpu_1) thread_num = 0 -!write(34,*) 'xxxNONLOCxxx' -!write(34,*) ' pseudo_lmax,pseudo_kmax', pseudo_lmax,pseudo_kmax -!write(34,*) ' pseudo_v_kl_transp(1,0,k)', pseudo_v_kl_transp -!write(34,*) ' pseudo_n_kl_transp(1,0,k)', pseudo_n_kl_transp -!write(34,*) ' pseudo_dz_kl_transp(1,0,k)', pseudo_dz_kl_transp -!write(34,*) 'xxxNONLOCxxx' !$OMP PARALLEL & !$OMP DEFAULT (NONE) & @@ -169,8 +165,9 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu !$ thread_num = omp_get_thread_num() + wall_0 = wall_1 !$OMP DO SCHEDULE (guided) - +! do j = 1, ao_num num_A = ao_nucl(j) @@ -207,15 +204,6 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu pseudo_n_kl_transp(1,0,k), & pseudo_dz_kl_transp(1,0,k), & A_center,power_A,alpha,B_center,power_B,beta,C_center) -! write(34,*) i,j,k -! write(34,*) & -! A_center,power_A,alpha,B_center,power_B,beta,C_center, & -! Vpseudo(pseudo_lmax,pseudo_kmax, & -! pseudo_v_kl_transp(1,0,k), & -! pseudo_n_kl_transp(1,0,k), & -! pseudo_dz_kl_transp(1,0,k), & -! A_center,power_A,alpha,B_center,power_B,beta,C_center) -! write(34,*) '' enddo ao_pseudo_integral_non_local(i,j) = ao_pseudo_integral_non_local(i,j) +& ao_coef_normalized_ordered_transp(l,j)*ao_coef_normalized_ordered_transp(m,i)*c @@ -232,12 +220,12 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral_local, (ao_num_align,ao_nu endif endif enddo - + !$OMP END DO - + !$OMP END PARALLEL - - + + END_PROVIDER BEGIN_PROVIDER [ double precision, pseudo_v_k_transp, (pseudo_klocmax,nucl_num) ] diff --git a/src/Integrals_Monoelec/pseudopot.f90 b/src/Integrals_Monoelec/pseudopot.f90 index d77b3ca0..a69aa42d 100644 --- a/src/Integrals_Monoelec/pseudopot.f90 +++ b/src/Integrals_Monoelec/pseudopot.f90 @@ -15,14 +15,10 @@ double precision function Vps & implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3) -integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) -integer lmax,kmax,n_kl(kmax_max,0:lmax_max) -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -integer klocmax_max -parameter (klocmax_max=10) -integer klocmax,n_k(klocmax_max) -double precision v_k(klocmax_max),dz_k(klocmax_max) +integer lmax,kmax,n_kl(kmax,0:lmax) +double precision v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) +integer klocmax,n_k(klocmax) +double precision v_k(klocmax),dz_k(klocmax) double precision Vloc,Vpseudo Vps=Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) & @@ -36,13 +32,10 @@ double precision function Vps_num & implicit none integer n_a(3),n_b(3) double precision g_a,g_b,a(3),b(3),c(3),rmax -integer kmax_max,lmax_max -parameter (kmax_max=2,lmax_max=2) -integer lmax,kmax,n_kl(kmax_max,0:lmax_max) -double precision v_kl(kmax_max,0:lmax_max),dz_kl(kmax_max,0:lmax_max) -integer klocmax_max;parameter (klocmax_max=10) -integer klocmax,n_k(klocmax_max) -double precision v_k(klocmax_max),dz_k(klocmax_max) +integer lmax,kmax,n_kl(kmax,0:lmax) +double precision v_kl(kmax,0:lmax),dz_kl(kmax,0:lmax) +integer klocmax,n_k(klocmax) +double precision v_k(klocmax),dz_k(klocmax) double precision Vloc_num,Vpseudo_num,v1,v2 integer npts,nptsgrid nptsgrid=50 @@ -54,11 +47,9 @@ end double precision function Vloc_num(npts_over,xmax,klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) implicit none -integer klocmax_max -parameter (klocmax_max=10) integer klocmax -double precision v_k(klocmax_max),dz_k(klocmax_max) -integer n_k(klocmax_max) +double precision v_k(klocmax),dz_k(klocmax) +integer n_k(klocmax) integer npts_over,ix,iy,iz double precision xmax,dx,x,y,z double precision a(3),b(3),c(3),term,r,orb_phi,g_a,g_b,ac(3),bc(3) @@ -705,12 +696,9 @@ end double precision function Vloc(klocmax,v_k,n_k,dz_k,a,n_a,g_a,b,n_b,g_b,c) implicit none -integer klocmax_max,lmax_max,ntot_max -parameter (klocmax_max=10,lmax_max=2) -parameter (ntot_max=10) integer klocmax -double precision v_k(klocmax_max),dz_k(klocmax_max),crochet,bigA -integer n_k(klocmax_max) +double precision v_k(klocmax),dz_k(klocmax),crochet,bigA +integer n_k(klocmax) double precision a(3),g_a,b(3),g_b,c(3),d(3) integer n_a(3),n_b(3),ntotA,ntotB,ntot,m integer i,l,k,ktot,k1,k2,k3,k1p,k2p,k3p @@ -719,6 +707,7 @@ double precision,allocatable :: array_R_loc(:,:,:) double precision,allocatable :: array_coefs(:,:,:,:,:,:) double precision int_prod_bessel_loc,binom_func,accu,prod,ylm,bigI,arg + fourpi=4.d0*dacos(-1.d0) f=fourpi**1.5d0 ac=dsqrt((a(1)-c(1))**2+(a(2)-c(2))**2+(a(3)-c(3))**2) @@ -755,8 +744,8 @@ double precision int_prod_bessel_loc,binom_func,accu,prod,ylm,bigI,arg dreal=2.d0*d2 - allocate (array_R_loc(-2:ntot_max+klocmax_max,klocmax_max,0:ntot_max)) - allocate (array_coefs(0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max,0:ntot_max)) + allocate (array_R_loc(-2:ntot+klocmax,klocmax,0:ntot)) + allocate (array_coefs(0:ntot,0:ntot,0:ntot,0:ntot,0:ntot,0:ntot)) do ktot=-2,ntotA+ntotB+klocmax do l=0,ntot @@ -2111,9 +2100,7 @@ end ! r : Distance between the Atomic Orbital center and the considered point double precision function ylm_orb(l,m,c,a,n_a,g_a,r) implicit none -integer lmax_max,ntot_max -parameter (lmax_max=2) -parameter (ntot_max=14) +integer lmax_max integer l,m double precision a(3),g_a,c(3) double precision prod,binom_func,accu,bigI,ylm,bessel_mod @@ -2131,7 +2118,6 @@ factor=fourpi*dexp(-arg) areal=2.d0*g_a*ac ntotA=n_a(1)+n_a(2)+n_a(3) -if(ntotA.gt.ntot_max)stop 'increase ntot_max' if(ac.eq.0.d0)then ylm_orb=dsqrt(fourpi)*r**ntotA*dexp(-g_a*r**2)*bigI(0,0,l,m,n_a(1),n_a(2),n_a(3)) diff --git a/src/MOGuess/.gitignore b/src/MOGuess/.gitignore deleted file mode 100644 index a912636d..00000000 --- a/src/MOGuess/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -H_CORE_guess -IRPF90_man -IRPF90_temp -Integrals_Monoelec -MO_Basis -Makefile -Makefile.depend -Nuclei -Pseudo -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -tags \ No newline at end of file diff --git a/src/MO_Basis/.gitignore b/src/MO_Basis/.gitignore deleted file mode 100644 index 110e93f9..00000000 --- a/src/MO_Basis/.gitignore +++ /dev/null @@ -1,17 +0,0 @@ -# Automatically created by $QP_ROOT/scripts/module/module_handler.py -.ninja_deps -.ninja_log -AO_Basis -Electrons -Ezfio_files -IRPF90_man -IRPF90_temp -Makefile -Makefile.depend -Nuclei -Utils -ezfio_interface.irp.f -irpf90.make -irpf90_entities -swap_mos -tags \ No newline at end of file diff --git a/src/MO_Basis/EZFIO.cfg b/src/MO_Basis/EZFIO.cfg index 5aec39e0..368b70a0 100644 --- a/src/MO_Basis/EZFIO.cfg +++ b/src/MO_Basis/EZFIO.cfg @@ -20,7 +20,13 @@ doc: MO occupation numbers interface: ezfio size: (mo_basis.mo_tot_num) +[mo_class] +type: character*(32) +doc: c: core, i: inactive, a: active, v: virtual, d: deleted +interface: ezfio, provider +size: (mo_basis.mo_tot_num) + [ao_md5] type: character*(32) doc: Ao_md5 -interface: ezfio \ No newline at end of file +interface: ezfio diff --git a/src/MO_Basis/ao_ortho_canonical.irp.f b/src/MO_Basis/ao_ortho_canonical.irp.f index 95a771b0..48341129 100644 --- a/src/MO_Basis/ao_ortho_canonical.irp.f +++ b/src/MO_Basis/ao_ortho_canonical.irp.f @@ -42,7 +42,7 @@ 9;; END_TEMPLATE case default - stop 'Error in ao_cart_to_sphe' + stop 'Error in ao_cart_to_sphe : angular momentum too high' end select enddo diff --git a/src/MO_Basis/cholesky_mo.irp.f b/src/MO_Basis/cholesky_mo.irp.f index 97b6abd2..65184c1e 100644 --- a/src/MO_Basis/cholesky_mo.irp.f +++ b/src/MO_Basis/cholesky_mo.irp.f @@ -1,8 +1,20 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) implicit none BEGIN_DOC -! Cholesky decomposition of AO Density matrix to -! generate MOs +! Cholesky decomposition of AO Density matrix +! +! n : Number of AOs + +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! +! tol_in : tolerance +! +! rank : Nomber of local MOs (output) +! END_DOC integer, intent(in) :: n,m, LDC, LDP double precision, intent(in) :: P(LDP,n) @@ -15,9 +27,6 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) integer :: ipiv(n) double precision:: tol double precision, allocatable :: W(:,:), work(:) - !DEC$ ATTRIBUTES ALIGN: 32 :: W - !DEC$ ATTRIBUTES ALIGN: 32 :: work - !DEC$ ATTRIBUTES ALIGN: 32 :: ipiv allocate(W(LDC,n),work(2*n)) tol=tol_in @@ -41,40 +50,37 @@ subroutine cholesky_mo(n,m,P,LDP,C,LDC,tol_in,rank) deallocate(W,work) end -BEGIN_PROVIDER [ double precision, mo_density_matrix, (mo_tot_num_align, mo_tot_num) ] +subroutine svd_mo(n,m,P,LDP,C,LDC) implicit none BEGIN_DOC - ! Density matrix in MO basis - END_DOC - integer :: i,j,k - mo_density_matrix = 0.d0 - do k=1,mo_tot_num - if (mo_occ(k) == 0.d0) then - cycle - endif - do j=1,ao_num - do i=1,ao_num - mo_density_matrix(i,j) = mo_density_matrix(i,j) + & - mo_occ(k) * mo_coef(i,k) * mo_coef(j,k) - enddo - enddo - enddo -END_PROVIDER +! Singular value decomposition of the AO Density matrix +! +! n : Number of AOs -BEGIN_PROVIDER [ double precision, mo_density_matrix_virtual, (mo_tot_num_align, mo_tot_num) ] - implicit none - BEGIN_DOC - ! Density matrix in MO basis (virtual MOs) +! m : Number of MOs +! +! P(LDP,n) : Density matrix in AO basis +! +! C(LDC,m) : MOs +! +! tol_in : tolerance +! +! rank : Nomber of local MOs (output) +! END_DOC - integer :: i,j,k - mo_density_matrix_virtual = 0.d0 - do k=1,mo_tot_num - do j=1,ao_num - do i=1,ao_num - mo_density_matrix_virtual(i,j) = mo_density_matrix_virtual(i,j) + & - (2.d0-mo_occ(k)) * mo_coef(i,k) * mo_coef(j,k) - enddo - enddo - enddo -END_PROVIDER + integer, intent(in) :: n,m, LDC, LDP + double precision, intent(in) :: P(LDP,n) + double precision, intent(out) :: C(LDC,m) + + integer :: info + integer :: i,k + integer :: ipiv(n) + double precision:: tol + double precision, allocatable :: W(:,:), work(:) + + allocate(W(LDC,n),work(2*n)) + call svd(P,LDP,C,LDC,W,size(W,1),m,n) + + deallocate(W,work) +end diff --git a/src/MO_Basis/mos.irp.f b/src/MO_Basis/mos.irp.f index 69abf7b3..19835395 100644 --- a/src/MO_Basis/mos.irp.f +++ b/src/MO_Basis/mos.irp.f @@ -258,3 +258,4 @@ subroutine mix_mo_jk(j,k) enddo end + diff --git a/src/MO_Basis/utils.irp.f b/src/MO_Basis/utils.irp.f index 0f338877..750e3420 100644 --- a/src/MO_Basis/utils.irp.f +++ b/src/MO_Basis/utils.irp.f @@ -88,7 +88,7 @@ subroutine mo_as_eigvectors_of_mo_matrix(matrix,n,m,label,sign) enddo endif do i=1,m - write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,eigvalues(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' @@ -135,7 +135,7 @@ subroutine mo_as_svd_vectors_of_mo_matrix(matrix,lda,m,n,label) write (output_mo_basis,'(A)') '======== ================' do i=1,m - write (output_mo_basis,'(I8,X,F16.10)') i,D(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,D(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' @@ -215,7 +215,7 @@ subroutine mo_as_eigvectors_of_mo_matrix_sort_by_observable(matrix,observable,n, write (output_mo_basis,'(A)') '' write (output_mo_basis,'(A)') '======== ================' do i = 1, m - write (output_mo_basis,'(I8,X,F16.10)') i,eigvalues(i) + write (output_mo_basis,'(I8,1X,F16.10)') i,eigvalues(i) enddo write (output_mo_basis,'(A)') '======== ================' write (output_mo_basis,'(A)') '' diff --git a/src/Nuclei/.gitignore b/src/Nuclei/.gitignore deleted file mode 100644 index f09c71f7..00000000 --- a/src/Nuclei/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Ezfio_files -Utils \ No newline at end of file diff --git a/src/Nuclei/nuclei.irp.f b/src/Nuclei/nuclei.irp.f index a8def602..34fae989 100644 --- a/src/Nuclei/nuclei.irp.f +++ b/src/Nuclei/nuclei.irp.f @@ -37,8 +37,8 @@ BEGIN_PROVIDER [ double precision, nucl_coord, (nucl_num_aligned,3) ] enddo deallocate(buffer) - character*(64), parameter :: f = '(A16, 4(X,F12.6))' - character*(64), parameter :: ft= '(A16, 4(X,A12 ))' + character*(64), parameter :: f = '(A16, 4(1X,F12.6))' + character*(64), parameter :: ft= '(A16, 4(1X,A12 ))' double precision, parameter :: a0= 0.529177249d0 call write_time(output_Nuclei) write(output_Nuclei,'(A)') '' @@ -169,7 +169,7 @@ END_PROVIDER 'Nuclear repulsion energy') END_PROVIDER -BEGIN_PROVIDER [ character*(128), element_name, (36)] +BEGIN_PROVIDER [ character*(128), element_name, (78)] BEGIN_DOC ! Array of the name of element, sorted by nuclear charge (integer) END_DOC @@ -209,4 +209,47 @@ BEGIN_PROVIDER [ character*(128), element_name, (36)] element_name(34) = 'Se' element_name(35) = 'Br' element_name(36) = 'Kr' + element_name(37) = 'Rb' + element_name(38) = 'Sr' + element_name(39) = 'Y' + element_name(40) = 'Zr' + element_name(41) = 'Nb' + element_name(42) = 'Mo' + element_name(43) = 'Tc' + element_name(44) = 'Ru' + element_name(45) = 'Rh' + element_name(46) = 'Pd' + element_name(47) = 'Ag' + element_name(48) = 'Cd' + element_name(49) = 'In' + element_name(50) = 'Sn' + element_name(51) = 'Sb' + element_name(52) = 'Te' + element_name(53) = 'I' + element_name(54) = 'Xe' + element_name(55) = 'Cs' + element_name(56) = 'Ba' + element_name(57) = 'La' + element_name(58) = 'Ce' + element_name(59) = 'Pr' + element_name(60) = 'Nd' + element_name(61) = 'Pm' + element_name(62) = 'Sm' + element_name(63) = 'Eu' + element_name(64) = 'Gd' + element_name(65) = 'Tb' + element_name(66) = 'Dy' + element_name(67) = 'Ho' + element_name(68) = 'Er' + element_name(69) = 'Tm' + element_name(70) = 'Yb' + element_name(71) = 'Lu' + element_name(72) = 'Hf' + element_name(73) = 'Ta' + element_name(74) = 'W' + element_name(75) = 'Re' + element_name(76) = 'Os' + element_name(77) = 'Ir' + element_name(78) = 'Pt' + END_PROVIDER diff --git a/src/Pseudo/.gitignore b/src/Pseudo/.gitignore deleted file mode 100644 index 7305be49..00000000 --- a/src/Pseudo/.gitignore +++ /dev/null @@ -1,15 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f -Nuclei -Ezfio_files -Utils \ No newline at end of file diff --git a/src/Pseudo/EZFIO.cfg b/src/Pseudo/EZFIO.cfg index 04eea7c6..fc23b678 100644 --- a/src/Pseudo/EZFIO.cfg +++ b/src/Pseudo/EZFIO.cfg @@ -86,16 +86,4 @@ doc: QMC grid interface: ezfio size: (ao_basis.ao_num,-pseudo.pseudo_lmax:pseudo.pseudo_lmax,0:pseudo.pseudo_lmax,nuclei.nucl_num,pseudo.pseudo_grid_size) -[disk_access_pseudo_local_integrals] -type: Disk_access -doc: Read/Write the local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - -[disk_access_pseudo_no_local_integrals] -type: Disk_access -doc: Read/Write the no-local ntegrals from/to disk [ Write | Read | None ] -interface: ezfio,provider,ocaml -default: None - diff --git a/src/Utils/.gitignore b/src/Utils/.gitignore deleted file mode 100644 index 85ad9d4e..00000000 --- a/src/Utils/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -# Automatically created by /home/razoa/quantum_package/scripts/module/module_handler.py -IRPF90_temp -IRPF90_man -irpf90_entities -tags -irpf90.make -Makefile -Makefile.depend -build.ninja -.ninja_log -.ninja_deps -ezfio_interface.irp.f \ No newline at end of file diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 44a15ddf..9f94bb62 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -26,7 +26,7 @@ subroutine svd(A,LDA,U,LDU,D,Vt,LDVt,m,n) lwork = -1 call dgesvd('A','A', m, n, A_tmp, LDA, & D, U, LDU, Vt, LDVt, work, lwork, info) - lwork = work(1) + lwork = int(work(1)) deallocate(work) allocate(work(lwork)) @@ -149,11 +149,11 @@ subroutine ortho_qr(A,LDA,m,n) allocate (jpvt(n), tau(n), work(1)) LWORK=-1 call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - LWORK=2*WORK(1) + LWORK=2*int(WORK(1)) deallocate(WORK) allocate(WORK(LWORK)) - call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) + call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) + call dorgqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) deallocate(WORK,jpvt,tau) end @@ -293,7 +293,7 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA) print *, info, ': SVD failed' stop endif - lwork = work(1) + lwork = int(work(1)) deallocate(work) allocate(work(lwork)) call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info) diff --git a/src/Utils/constants.include.F b/src/Utils/constants.include.F index 991ef80a..4974fd8e 100644 --- a/src/Utils/constants.include.F +++ b/src/Utils/constants.include.F @@ -1,5 +1,6 @@ integer, parameter :: max_dim = 511 integer, parameter :: SIMD_vector = 32 +integer, parameter :: N_int_max = 16 double precision, parameter :: pi = dacos(-1.d0) double precision, parameter :: sqpi = dsqrt(dacos(-1.d0)) diff --git a/src/Utils/map_functions.irp.f b/src/Utils/map_functions.irp.f index 68ba342c..0378c253 100644 --- a/src/Utils/map_functions.irp.f +++ b/src/Utils/map_functions.irp.f @@ -73,10 +73,11 @@ subroutine map_load_from_disk(filename,map) implicit none character*(*), intent(in) :: filename type(map_type), intent(inout) :: map + double precision :: x type(c_ptr) :: c_pointer(3) integer :: fd(3) - integer*8 :: i,k - integer :: n_elements + integer*8 :: i,k,l + integer*4 :: j,n_elements @@ -95,20 +96,34 @@ subroutine map_load_from_disk(filename,map) call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + l = 0_8 k = 1_8 + x = 0.d0 do i=0_8, map % map_size deallocate(map % map(i) % value) deallocate(map % map(i) % key) map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) map % map(i) % sorted = .True. - n_elements = map % consolidated_idx (i+2) - k + n_elements = int( map % consolidated_idx (i+2) - k, 4) k = map % consolidated_idx (i+2) map % map(i) % map_size = n_elements map % map(i) % n_elements = n_elements + ! Load memory from disk + do j=1,n_elements + x = x + map % map(i) % value(j) + l = iand(l,int(map % map(i) % key(j),8)) + if (map % map(i) % value(j) > 1.e30) then + stop 'Error in integrals file' + endif + if (map % map(i) % key(j) < 0) then + stop 'Error in integrals file' + endif + enddo enddo + map % sorted = x>0 .or. l == 0_8 map % n_elements = k-1 - map % sorted = .True. + map % sorted = map % sorted .or. .True. map % consolidated = .True. end diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 80260233..ac16f97e 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -53,17 +53,17 @@ module map_module end module map_module -real function map_mb(map) +double precision function map_mb(map) use map_module use omp_lib implicit none type (map_type), intent(in) :: map integer(map_size_kind) :: i - map_mb = 8+map_size_kind+map_size_kind+omp_lock_kind+4 + map_mb = dble(8+map_size_kind+map_size_kind+omp_lock_kind+4) do i=0,map%map_size - map_mb = map_mb + map%map(i)%map_size*(cache_key_kind+integral_kind) +& - 8+8+4+cache_map_size_kind+cache_map_size_kind+omp_lock_kind + map_mb = map_mb + dble(map%map(i)%map_size*(cache_key_kind+integral_kind) +& + 8+8+4+cache_map_size_kind+cache_map_size_kind+omp_lock_kind) enddo map_mb = map_mb / (1024.d0*1024.d0) end @@ -406,8 +406,8 @@ subroutine map_update(map, key, value, sze, thr) call cache_map_reallocate(local_map, local_map%n_elements + local_map%n_elements) call cache_map_shrink(local_map,thr) endif - cache_key = iand(key(i),map_mask) - local_map%n_elements = local_map%n_elements + 1_8 + cache_key = int(iand(key(i),map_mask),2) + local_map%n_elements = local_map%n_elements + 1 local_map%value(local_map%n_elements) = value(i) local_map%key(local_map%n_elements) = cache_key local_map%sorted = .False. @@ -464,7 +464,7 @@ subroutine map_append(map, key, value, sze) if (n_elements == map%map(idx_cache)%map_size) then call cache_map_reallocate(map%map(idx_cache), n_elements+ ishft(n_elements,-1)) endif - cache_key = iand(key(i),map_mask) + cache_key = int(iand(key(i),map_mask),2) map%map(idx_cache)%value(n_elements) = value(i) map%map(idx_cache)%key(n_elements) = cache_key map%map(idx_cache)%n_elements = n_elements @@ -615,7 +615,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = -1 return endif - cache_key = iand(key,map_mask) + cache_key = int(iand(key,map_mask),2) ibegin = min(ibegin_in,sze) iend = min(iend_in,sze) if ((cache_key > X(ibegin)) .and. (cache_key < X(iend))) then @@ -723,7 +723,7 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in value = 0.d0 return endif - cache_key = iand(key,map_mask) + cache_key = int(iand(key,map_mask),2) ibegin = min(ibegin_in,sze) iend = min(iend_in,sze) if ((cache_key > X(ibegin)) .and. (cache_key < X(iend))) then diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index bf83cae4..e61cf92a 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -1000,4 +1000,3 @@ subroutine wait_for_states(state_wait,state,n) end - diff --git a/tests/bats/cassd.bats b/tests/bats/cassd.bats index 2a8fabc2..67c35235 100644 --- a/tests/bats/cassd.bats +++ b/tests/bats/cassd.bats @@ -13,14 +13,14 @@ source $QP_ROOT/tests/bats/common.bats.sh qp_set_mo_class $INPUT -core "[1]" -inact "[2,5]" -act "[3,4,6,7]" -virt "[8-24]" qp_run cassd_zmq $INPUT energy="$(ezfio get cas_sd_zmq energy_pt2)" - eq $energy -76.231084536315 5.E-5 + eq $energy -76.231248286858 5.E-5 - ezfio set determinants n_det_max 2048 + ezfio set determinants n_det_max 1024 ezfio set determinants read_wf True ezfio set perturbation do_pt2_end True qp_run cassd_zmq $INPUT ezfio set determinants read_wf False energy="$(ezfio get cas_sd_zmq energy)" - eq $energy -76.2300887947446 2.E-5 + eq $energy -76.2225678834779 2.E-5 } diff --git a/tests/bats/fci.bats b/tests/bats/fci.bats index 79ff91ab..6cded581 100644 --- a/tests/bats/fci.bats +++ b/tests/bats/fci.bats @@ -42,11 +42,13 @@ function run_FCI_ZMQ() { qp_set_mo_class h2o.ezfio -core "[1]" -act "[2-12]" -del "[13-24]" } @test "FCI H2O cc-pVDZ" { - run_FCI h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 + run_FCI h2o.ezfio 2000 -76.1253758241716 -76.1258130146102 } + + @test "FCI-ZMQ H2O cc-pVDZ" { - run_FCI_ZMQ h2o.ezfio 2000 -0.761255633582109E+02 -0.761258377850042E+02 + run_FCI_ZMQ h2o.ezfio 2000 -76.1250552686394 -76.1258817228809 } diff --git a/tests/bats/mrcepa0.bats b/tests/bats/mrcepa0.bats index dc9e0bb4..9a62885e 100644 --- a/tests/bats/mrcepa0.bats +++ b/tests/bats/mrcepa0.bats @@ -16,7 +16,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.23752746236 1.e-4 + eq $energy -76.2382106224545 1.e-4 } @test "MRCC H2O cc-pVDZ" { @@ -32,7 +32,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.237469267705 2.e-4 + eq $energy -76.2381754078899 1.e-4 } @test "MRSC2 H2O cc-pVDZ" { @@ -48,7 +48,7 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2347764009137 2.e-4 + eq $energy -76.235786994991 2.e-4 } @test "MRCEPA0 H2O cc-pVDZ" { @@ -64,6 +64,6 @@ source $QP_ROOT/tests/bats/common.bats.sh ezfio set mrcepa0 n_it_max_dressed_ci 3 qp_run $EXE $INPUT energy="$(ezfio get mrcepa0 energy_pt2)" - eq $energy -76.2406942855164 2.e-4 + eq $energy -76.2411829210128 2.e-4 } diff --git a/tests/input/h2o.xyz b/tests/input/h2o.xyz index 99268e5d..e8cd039b 100644 --- a/tests/input/h2o.xyz +++ b/tests/input/h2o.xyz @@ -1,6 +1,6 @@ 3 XYZ file: coordinates in Angstrom -O 0.0000000000 -0.3880000000 0.0000000000 H 0.7510000000 0.1940000000 0.0000000000 +O 0.0000000000 -0.3880000000 0.0000000000 H -0.7510000000 0.1940000000 0.0000000000