use bitmasks BEGIN_PROVIDER [integer, max_number_ionic] &BEGIN_PROVIDER [integer, min_number_ionic] BEGIN_DOC ! Maximum and minimum number of ionization in psi_ref END_DOC implicit none integer :: i,j integer :: n_closed_shell_cas max_number_ionic = 0 min_number_ionic = 100000 do i = 1, N_det_ref j = n_closed_shell_cas(psi_ref(1,1,i),n_int) if(j> max_number_ionic)then max_number_ionic = j endif if(j< min_number_ionic)then min_number_ionic = j endif enddo print*,'max_number_ionic = ',max_number_ionic print*,'min_number_ionic = ',min_number_ionic END_PROVIDER BEGIN_PROVIDER [integer, ionic_index, (min_number_ionic:max_number_ionic,0:N_det_ref)] &BEGIN_PROVIDER [double precision, normalization_factor_ionic, (min_number_ionic:max_number_ionic, N_states)] BEGIN_DOC ! Index of the various determinants in psi_ref according to their level of ionicity ! ionic_index(i,0) = number of determinants in psi_ref having the degree of ionicity "i" ! ionic_index(i,j) = index of the determinants having the degree of ionicity "i" END_DOC implicit none integer :: i,j,k integer :: n_closed_shell_cas double precision :: accu ionic_index = 0 do i = 1, N_det_ref j = n_closed_shell_cas(psi_ref(1,1,i),n_int) ionic_index(j,0) +=1 ionic_index(j,ionic_index(j,0)) = i enddo do i = min_number_ionic,max_number_ionic accu = 0.d0 do j = 1, N_states do k = 1, ionic_index(i,0) accu += psi_ref_coef_diagonalized(ionic_index(i,k),j) * psi_ref_coef_diagonalized(ionic_index(i,k),j) enddo normalization_factor_ionic(i,j) = 1.d0/dsqrt(accu) enddo enddo END_PROVIDER BEGIN_PROVIDER [double precision, H_OVB_naked, (min_number_ionic:max_number_ionic, min_number_ionic:max_number_ionic, n_states)] BEGIN_DOC ! Hamiltonian matrix expressed in the basis of contracted forms in terms of ionic structures END_DOC implicit none integer :: i,j,istate,k,l double precision :: accu,hij do i = min_number_ionic,max_number_ionic do j = min_number_ionic,max_number_ionic do istate = 1, N_states accu = 0.d0 do k = 1, ionic_index(i,0) do l = 1, ionic_index(j,0) hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) accu += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_ionic(i,istate) * & psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij enddo enddo H_OVB_naked(i,j,istate) = accu enddo enddo enddo END_PROVIDER BEGIN_PROVIDER [integer, n_couples_act_orb] implicit none n_couples_act_orb = 3 END_PROVIDER BEGIN_PROVIDER [integer, couples_act_orb, (n_couples_act_orb,2) ] implicit none couples_act_orb(1,1) = 20 couples_act_orb(1,2) = 21 couples_act_orb(2,1) = 22 couples_act_orb(2,2) = 23 couples_act_orb(3,1) = 24 couples_act_orb(3,2) = 25 END_PROVIDER BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom , (n_act_orb,n_act_orb)] implicit none BEGIN_DOC ! Hamiltonian matrix elements between the various contracted functions ! that have a negative charge on a given active orbital END_DOC integer :: i,j,k,l,jj,ii integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) double precision :: accu,hij double precision :: norm allocate (key_1(N_int,2),key_2(N_int,2)) do i = 1, n_act_orb j = i ! Diagonal part norm = 0.d0 accu = 0.d0 do k = 1, n_det_ionic_on_given_atom(i) norm += psi_coef_mono_ionic_on_given_atom(k,i) **2 do ii = 1, N_int key_1(ii,1) = psi_det_mono_ionic_on_given_atom(ii,1,k,i) key_1(ii,2) = psi_det_mono_ionic_on_given_atom(ii,2,k,i) enddo do l = 1, n_det_ionic_on_given_atom(j) do jj = 1, N_int key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j) key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j) enddo call i_H_j(key_1,key_2,N_int,hij) accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij enddo enddo H_matrix_between_ionic_on_given_atom(i,j) = accu do j = i+1, n_act_orb ! Extra diagonal part accu = 0.d0 do k = 1, n_det_ionic_on_given_atom(i) do jj = 1, N_int key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i) key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i) enddo do l = 1, n_det_ionic_on_given_atom(j) do jj = 1, N_int key_2(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,l,j) key_2(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,l,j) enddo call i_H_j(key_1,key_2,N_int,hij) accu += psi_coef_mono_ionic_on_given_atom(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij enddo enddo H_matrix_between_ionic_on_given_atom(i,j) = accu H_matrix_between_ionic_on_given_atom(j,i) = accu enddo enddo END_PROVIDER BEGIN_PROVIDER [double precision, H_matrix_between_ionic_on_given_atom_and_others , (n_act_orb,min_number_ionic:max_number_ionic)] implicit none use bitmasks BEGIN_DOC ! Hamiltonian matrix elements between the various contracted functions ! that have a negative charge on a given active orbital ! and all the other fully contracted OVB structures END_DOC integer :: i,j,k,l,jj,ii integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) double precision :: accu,hij double precision :: norm allocate (key_1(N_int,2),key_2(N_int,2)) do i = 1, n_act_orb do j = min_number_ionic,max_number_ionic if(j==1)then H_matrix_between_ionic_on_given_atom_and_others(i,j) = 0.d0 endif accu = 0.d0 do k = 1, n_det_ionic_on_given_atom(i) do jj = 1, N_int key_1(jj,1) = psi_det_mono_ionic_on_given_atom(jj,1,k,i) key_1(jj,2) = psi_det_mono_ionic_on_given_atom(jj,2,k,i) enddo do l = 1, ionic_index(j,0) do ii = 1, N_int key_2(ii,1) = psi_det_ovb(ii,1,l,j) key_2(ii,2) = psi_det_ovb(ii,2,l,j) enddo call i_H_j(key_1,key_2,N_int,hij) accu += psi_coef_ovb(l,j) * psi_coef_mono_ionic_on_given_atom(k,i) * hij enddo enddo H_matrix_between_ionic_on_given_atom_and_others(i,j) = accu enddo enddo print*,'H_matrix_between_ionic_on_given_atom_and_others' print*,'' do i = 1, n_act_orb write(*,'(I3,X,100(F16.7))'),H_matrix_between_ionic_on_given_atom_and_others(i,:) enddo END_PROVIDER BEGIN_PROVIDER [integer, n_det_ionic_on_given_atom, (n_act_orb)] &BEGIN_PROVIDER [double precision, normalization_factor_ionic_on_given_atom, (n_act_orb) ] &BEGIN_PROVIDER [double precision, psi_coef_mono_ionic_on_given_atom, (N_det_ref,n_act_orb) ] &BEGIN_PROVIDER [integer(bit_kind), psi_det_mono_ionic_on_given_atom, (N_int,2,N_det_ref,n_act_orb)] implicit none use bitmasks BEGIN_DOC ! number of determinants that are mono ionic with the negative charge ! on a given atom, normalization_factor, array of determinants,and coefficients END_DOC integer :: i,j,k,l ionicity_level = 1 integer :: ionicity_level logical :: doubly_occupied_array(n_act_orb) n_det_ionic_on_given_atom = 0 normalization_factor_ionic_on_given_atom = 0.d0 do i = 1, ionic_index(ionicity_level,0) call give_index_of_doubly_occ_in_active_space(psi_det(1,1,ionic_index(ionicity_level,i)),doubly_occupied_array) do j = 1, n_act_orb if(doubly_occupied_array(j))then n_det_ionic_on_given_atom(j) += 1 normalization_factor_ionic_on_given_atom(j) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 do k = 1, N_int psi_det_mono_ionic_on_given_atom(k,1,n_det_ionic_on_given_atom(j),j) = psi_det(k,1,ionic_index(ionicity_level,i)) psi_det_mono_ionic_on_given_atom(k,2,n_det_ionic_on_given_atom(j),j) = psi_det(k,2,ionic_index(ionicity_level,i)) enddo psi_coef_mono_ionic_on_given_atom(n_det_ionic_on_given_atom(j),j) = psi_ref_coef_diagonalized(ionic_index(1,i),1) endif enddo enddo integer :: i_count i_count = 0 do j = 1, n_act_orb i_count += n_det_ionic_on_given_atom(j) normalization_factor_ionic_on_given_atom(j) = 1.d0/dsqrt(normalization_factor_ionic_on_given_atom(j)) enddo if(i_count.ne.ionic_index(ionicity_level,0))then print*,'PB with n_det_ionic_on_given_atom' print*,'i_count = ',i_count print*,'ionic_index(ionicity_level,0)',ionic_index(ionicity_level,0) stop endif do j = 1, n_act_orb do i = 1, n_det_ionic_on_given_atom(j) psi_coef_mono_ionic_on_given_atom(i,j) = psi_coef_mono_ionic_on_given_atom(i,j) * normalization_factor_ionic_on_given_atom(j) enddo enddo END_PROVIDER BEGIN_PROVIDER [integer(bit_kind), psi_det_ovb, (N_int,2,N_det_ref,min_number_ionic:max_number_ionic)] &BEGIN_PROVIDER [double precision, psi_coef_ovb, (N_det_ref,min_number_ionic:max_number_ionic) ] implicit none BEGIN_DOC ! Array of the determinants belonging to each ovb structures (neutral, mono ionic, bi ionic etc ...) ! together with the arrays of coefficients END_DOC integer :: i,j,k,l use bitmasks integer :: ionicity_level,i_count double precision :: accu do ionicity_level = min_number_ionic,max_number_ionic accu = 0.d0 do i = 1, ionic_index(ionicity_level,0) do j = 1, N_int psi_det_ovb(j,1,i,ionicity_level) = psi_det(j,1,ionic_index(ionicity_level,i)) psi_det_ovb(j,2,i,ionicity_level) = psi_det(j,2,ionic_index(ionicity_level,i)) enddo psi_coef_ovb(i,ionicity_level) = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) * normalization_factor_ionic(ionicity_level,1) accu += psi_coef_ovb(i,ionicity_level)**2 enddo accu = 1.d0/dsqrt(accu) do i = 1, ionic_index(ionicity_level,0) psi_coef_ovb(i,ionicity_level) = psi_coef_ovb(i,ionicity_level) * accu enddo accu = 0.d0 do i = 1, ionic_index(ionicity_level,0) accu += psi_coef_ovb(i,ionicity_level) **2 enddo enddo END_PROVIDER BEGIN_PROVIDER [double precision, H_matrix_psi_det_ovb, (min_number_ionic:max_number_ionic,min_number_ionic:max_number_ionic)] implicit none BEGIN_DOC ! H matrix between the fully contracted OVB forms END_DOC integer :: i,j,k,l,jj,ii integer(bit_kind), allocatable :: key_1(:,:),key_2(:,:) use bitmasks double precision :: accu,hij double precision :: norm allocate (key_1(N_int,2),key_2(N_int,2)) do i = min_number_ionic,max_number_ionic do j = min_number_ionic,max_number_ionic accu = 0.d0 do k = 1, ionic_index(i,0) do ii = 1, N_int key_1(ii,1) = psi_det_ovb(ii,1,k,i) key_1(ii,2) = psi_det_ovb(ii,2,k,i) enddo do l = 1, ionic_index(j,0) do ii = 1, N_int key_2(ii,1) = psi_det_ovb(ii,1,l,j) key_2(ii,2) = psi_det_ovb(ii,2,l,j) enddo call i_H_j(key_1,key_2,N_int,hij) accu += psi_coef_ovb(l,j) * psi_coef_ovb(k,i) * hij enddo enddo H_matrix_psi_det_ovb(i,j) = accu enddo enddo END_PROVIDER BEGIN_PROVIDER [integer, number_first_ionic_couples] &BEGIN_PROVIDER [logical , is_a_first_ionic_couple, (N_det_ref)] &BEGIN_PROVIDER [double precision, normalization_factor_special_first_ionic, (2)] implicit none BEGIN_DOC ! Number of determinants belonging to the class of first ionic ! AND that have a couple of positive/negative charge belonging ! to a couple of orbital couples_act_orb ! If is_a_first_ionic_couple(i) = .True. then this determinant is a first ionic ! and have a couple of positive/negative charge belonging ! to a couple of orbital couples_act_orb ! normalization factor (1) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .True.) ! normalization factor (2) = 1/(sum c_i^2 .with. is_a_first_ionic_couple(i) = .False.) END_DOC integer :: i,j use bitmasks number_first_ionic_couples = 0 integer :: ionicity_level logical :: couples_out(0:n_couples_act_orb) integer(bit_kind) :: key_tmp(N_int,2) ionicity_level = 1 normalization_factor_special_first_ionic = 0.d0 do i = 1, ionic_index(ionicity_level,0) do j = 1, N_int key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i)) key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i)) enddo call doubly_occ_empty_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out) if(couples_out(0))then number_first_ionic_couples +=1 is_a_first_ionic_couple(i) = .True. normalization_factor_special_first_ionic(1) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 else is_a_first_ionic_couple(i) = .False. normalization_factor_special_first_ionic(2) += psi_ref_coef_diagonalized(ionic_index(1,i),1) **2 endif enddo normalization_factor_special_first_ionic(1) = 1.d0/dsqrt(normalization_factor_special_first_ionic(1)) normalization_factor_special_first_ionic(2) = 1.d0/dsqrt(normalization_factor_special_first_ionic(2)) print*,'number_first_ionic_couples = ',number_first_ionic_couples END_PROVIDER BEGIN_PROVIDER [integer, number_neutral_no_hund_couples] &BEGIN_PROVIDER [logical , is_a_neutral_no_hund_couple, (N_det_ref)] &BEGIN_PROVIDER [double precision, normalization_factor_neutra_no_hund_couple, (2)] &BEGIN_PROVIDER [double precision, ratio_hund_no_hund ] implicit none BEGIN_DOC ! Number of determinants belonging to the class of neutral determinants ! AND that have a couple of alpha beta electrons in couple of orbital couples_act_orb ! If is_a_neutral_no_hund_couple(i) = .True. then this determinant is a neutral determinants ! and have a a couple of alpha beta electrons in couple of orbital couples_act_orb ! normalization factor (1) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .True.) ! normalization factor (2) = 1/sqrt(sum c_i^2 .with. is_a_neutral_no_hund_couple(i) = .False.) END_DOC integer :: i,j use bitmasks number_neutral_no_hund_couples = 0 integer :: ionicity_level logical :: couples_out(0:n_couples_act_orb) integer(bit_kind) :: key_tmp(N_int,2) integer :: ifirst_hund,ifirst_no_hund double precision :: coef_ref_hund,coef_ref_no_hund ifirst_hund = 0 ifirst_no_hund = 0 ionicity_level = 0 normalization_factor_neutra_no_hund_couple = 0.d0 do i = 1, ionic_index(ionicity_level,0) do j = 1, N_int key_tmp(j,1) = psi_det(j,1,ionic_index(ionicity_level,i)) key_tmp(j,2) = psi_det(j,2,ionic_index(ionicity_level,i)) enddo call neutral_no_hund_in_couple(key_tmp,n_couples_act_orb,couples_act_orb,couples_out) if(couples_out(0))then if(ifirst_no_hund == 0)then coef_ref_no_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) ifirst_no_hund = 1 endif number_neutral_no_hund_couples +=1 is_a_neutral_no_hund_couple(i) = .True. normalization_factor_neutra_no_hund_couple(1) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2 else if(ifirst_hund == 0)then coef_ref_hund = psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) ifirst_hund = 1 endif is_a_neutral_no_hund_couple(i) = .False. normalization_factor_neutra_no_hund_couple(2) += psi_ref_coef_diagonalized(ionic_index(ionicity_level,i),1) **2 endif enddo ratio_hund_no_hund = coef_ref_no_hund/coef_ref_hund normalization_factor_neutra_no_hund_couple(1) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(1)) normalization_factor_neutra_no_hund_couple(2) = 1.d0/dsqrt(normalization_factor_neutra_no_hund_couple(2)) print*,'number_neutral_no_hund_couples = ',number_neutral_no_hund_couples END_PROVIDER BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic, (2,min_number_ionic:max_number_ionic,n_states)] &BEGIN_PROVIDER [double precision, H_OVB_naked_first_ionic_between_ionic, (2,2,n_states)] BEGIN_DOC ! H_OVB_naked_first_ionic(1,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True ! and the contracted ith ionic form ! if i == 1 not defined ! H_OVB_naked_first_ionic(2,i) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False ! and the contracted ith ionic form ! if i == 1 not defined ! H_OVB_naked_first_ionic_between_ionic(1,1) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True ! and the first ionic determinants belonging to is_a_first_ionic_couple = True ! H_OVB_naked_first_ionic_between_ionic(1,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = True ! and the first ionic determinants belonging to is_a_first_ionic_couple = False ! H_OVB_naked_first_ionic_between_ionic(2,2) = H_matrix element between the first ionic determinants belonging to is_a_first_ionic_couple = False ! and the first ionic determinants belonging to is_a_first_ionic_couple = False END_DOC implicit none integer :: i,j,istate,k,l double precision :: accu_1,accu_2,hij H_OVB_naked_first_ionic = 0.d0 H_OVB_naked_first_ionic_between_ionic = 0.d0 i = 1 do j = min_number_ionic,max_number_ionic if(j==1)cycle do istate = 1, N_states accu_1 = 0.d0 accu_2 = 0.d0 do k = 1, ionic_index(i,0) if(is_a_first_ionic_couple(k))then do l = 1, ionic_index(j,0) hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) accu_1 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(1) * & psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij enddo else do l = 1, ionic_index(j,0) hij = ref_hamiltonian_matrix(ionic_index(i,k),ionic_index(j,l)) accu_2 += psi_ref_coef_diagonalized(ionic_index(i,k),istate) * normalization_factor_special_first_ionic(2) * & psi_ref_coef_diagonalized(ionic_index(j,l),istate) * normalization_factor_ionic(j,istate) * hij enddo endif enddo H_OVB_naked_first_ionic(1,j,istate) = accu_1 H_OVB_naked_first_ionic(2,j,istate) = accu_2 enddo enddo do istate = 1, N_states accu_1 = 0.d0 accu_2 = 0.d0 integer :: i_count i_count = 0 do k = 1, ionic_index(1,0) do l = 1, ionic_index(1,0) hij = ref_hamiltonian_matrix(ionic_index(1,k),ionic_index(1,l)) accu_1 = hij * psi_ref_coef_diagonalized(ionic_index(1,k),istate) * psi_ref_coef_diagonalized(ionic_index(1,l),istate) if(is_a_first_ionic_couple(k).and. is_a_first_ionic_couple(l))then H_OVB_naked_first_ionic_between_ionic(1,1,istate) += accu_1 * normalization_factor_special_first_ionic(1) **2 elseif(is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then i_count += 1 H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * & normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2) ! elseif(is_a_first_ionic_couple(l).and. .not.is_a_first_ionic_couple(k))then ! i_count += 1 ! H_OVB_naked_first_ionic_between_ionic(1,2,istate) += accu_1 * & ! normalization_factor_special_first_ionic(1) *normalization_factor_special_first_ionic(2) elseif(.not.is_a_first_ionic_couple(k).and. .not.is_a_first_ionic_couple(l))then H_OVB_naked_first_ionic_between_ionic(2,2,istate) += accu_1 * normalization_factor_special_first_ionic(2) **2 endif enddo enddo enddo print*,'i_count = ',i_count print*,'number_first_ionic_couples**2 = ',ionic_index(1,0) * number_first_ionic_couples double precision :: convert_hartree_ev convert_hartree_ev = 27.211399d0 print*,'Special H matrix' do i = 1,2 write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic(i,:,1) enddo print*,'Special H matrix bis' do i = 1,2 write(*,'(I4,X,10(F16.8 ,4X))')i, H_OVB_naked_first_ionic_between_ionic(i,:,1) enddo END_PROVIDER