BEGIN_PROVIDER [ integer, n_exc_active ] &BEGIN_PROVIDER [ integer, active_pp_idx, (hh_nex) ] &BEGIN_PROVIDER [ integer, active_hh_idx, (hh_nex) ] &BEGIN_PROVIDER [ logical, is_active_exc, (hh_nex) ] implicit none BEGIN_DOC ! is_active_exc : True if the excitation involves at least one active MO ! ! n_exc_active : Number of active excitations : Number of excitations without the inactive ones. ! ! active_hh_idx : ! ! active_pp_idx : END_DOC integer :: hh, pp, II integer :: ind logical :: ok integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) integer, allocatable :: pathTo(:) integer, external :: searchDet allocate(pathTo(N_det_non_ref)) pathTo(:) = 0 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 ! ! 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 ! 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 do hh = 1, hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 if(is_active_exc(pp)) then n_exc_active = n_exc_active + 1 active_hh_idx(n_exc_active) = hh active_pp_idx(n_exc_active) = pp end if end do end do deallocate(pathTo) print *, n_exc_active, "active excitations /", hh_nex 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 ! Dimension of arrays to avoid zero-sized arrays END_DOC n_exc_active_sze = max(n_exc_active,1) END_PROVIDER BEGIN_PROVIDER [ integer, active_excitation_to_determinants_idx, (0:N_det_ref+1, n_exc_active_sze) ] &BEGIN_PROVIDER [ double precision, active_excitation_to_determinants_val, (N_states,N_det_ref+1, n_exc_active_sze) ] implicit none BEGIN_DOC ! Sparse matrix A containing the matrix to transform the active excitations to ! determinants : A | \Psi_0 > = | \Psi_SD > END_DOC integer :: s, ppp, pp, hh, II, ind, wk, i integer, allocatable :: lref(:) integer(bit_kind) :: myDet(N_int,2), myMask(N_int,2) double precision :: phase logical :: ok integer, external :: searchDet !$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(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) do ppp=1,n_exc_active active_excitation_to_determinants_val(:,:,ppp) = 0d0 active_excitation_to_determinants_idx(:,ppp) = 0 pp = active_pp_idx(ppp) hh = active_hh_idx(ppp) lref = 0 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) then call get_phase(myDet(1,1), psi_ref(1,1,II), phase, N_int) if (phase > 0.d0) then lref(psi_non_ref_sorted_idx(ind)) = II else lref(psi_non_ref_sorted_idx(ind)) = -II endif end if end do wk = 0 do i=1, N_det_non_ref if(lref(i) > 0) then 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 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 end if end do active_excitation_to_determinants_idx(0,ppp) = wk end do !$OMP END DO deallocate(lref) !$OMP END PARALLEL END_PROVIDER BEGIN_PROVIDER [ integer, mrcc_AtA_ind, (N_det_ref * n_exc_active_sze) ] &BEGIN_PROVIDER [ double precision, mrcc_AtA_val, (N_states, N_det_ref * n_exc_active_sze) ] &BEGIN_PROVIDER [ integer, mrcc_col_shortcut, (n_exc_active_sze) ] &BEGIN_PROVIDER [ integer, mrcc_N_col, (n_exc_active_sze) ] implicit none BEGIN_DOC ! A is active_excitation_to_determinants in At.A END_DOC integer :: AtA_size, i,k integer :: at_roww, at_row, wk, a_coll, a_col, r1, r2, s double precision, allocatable :: t(:), A_val_mwen(:,:), As2_val_mwen(:,:) integer, allocatable :: A_ind_mwen(:) double precision :: sij PROVIDE psi_non_ref mrcc_AtA_ind(:) = 0 mrcc_AtA_val(:,:) = 0.d0 mrcc_col_shortcut(:) = 0 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,& !$OMP As2_val_mwen, a_coll, at_roww,sij) & !$OMP shared(N_states,mrcc_col_shortcut, mrcc_N_col, AtA_size, mrcc_AtA_val, mrcc_AtA_ind, & !$OMP n_exc_active, active_pp_idx,psi_non_ref) allocate(A_val_mwen(N_states,hh_nex), As2_val_mwen(N_states,hh_nex), A_ind_mwen(hh_nex), t(N_states) ) !$OMP DO schedule(dynamic, 100) do at_roww = 1, n_exc_active ! hh_nex at_row = active_pp_idx(at_roww) wk = 0 do a_coll = 1, n_exc_active a_col = active_pp_idx(a_coll) t(:) = 0d0 r1 = 1 r2 = 1 do while ((active_excitation_to_determinants_idx(r1, at_roww) /= 0).and.(active_excitation_to_determinants_idx(r2, a_coll) /= 0)) if(active_excitation_to_determinants_idx(r1, at_roww) > active_excitation_to_determinants_idx(r2, a_coll)) then r2 = r2+1 else if(active_excitation_to_determinants_idx(r1, at_roww) < active_excitation_to_determinants_idx(r2, a_coll)) then r1 = r1+1 else do s=1,N_states t(s) = t(s) - active_excitation_to_determinants_val(s,r1, at_roww) * active_excitation_to_determinants_val(s,r2, a_coll) enddo r1 = r1+1 r2 = r2+1 end if end do if (a_col == at_row) then t(:) = t(:) + 1.d0 endif if (sum(dabs(t(:))) > 0.d0) then wk = wk+1 A_ind_mwen(wk) = a_col A_val_mwen(:,wk) = t(:) endif end do if(wk /= 0) then !$OMP CRITICAL mrcc_col_shortcut(at_roww) = AtA_size+1 mrcc_N_col(at_roww) = wk if (AtA_size+wk > size(mrcc_AtA_ind,1)) then print *, AtA_size+wk , size(mrcc_AtA_ind,1) stop 'too small' endif do i=1,wk mrcc_AtA_ind(AtA_size+i) = A_ind_mwen(i) do s=1,N_states mrcc_AtA_val(s,AtA_size+i) = A_val_mwen(s,i) enddo enddo AtA_size += wk !$OMP END CRITICAL end if end do !$OMP END DO NOWAIT deallocate (A_ind_mwen, A_val_mwen, As2_val_mwen, t) !$OMP END PARALLEL print *, "At.A SIZE", ata_size END_PROVIDER