eplf/src/det.irp.f

BEGIN_PROVIDER [ integer, det_num ]
  implicit none
  BEGIN_DOC
! Number of determinants
  END_DOC

 det_num = 1
 call get_determinants_det_num(det_num)
 if (det_num < 1) then
   call abrt(irp_here,'det_num should be > 0')
 endif

END_PROVIDER

BEGIN_PROVIDER  [ integer, det, (elec_alpha_num-mo_closed_num,det_num,2) ]
&BEGIN_PROVIDER [ real, det_coef, (det_num) ]
  implicit none

  BEGIN_DOC
! det : Description of the active orbitals of the determinants

! det_coef  : Determinant coefficients
  END_DOC

 if (elec_alpha_num > mo_closed_num) then
  det = 0
  call get_determinants_det_occ(det)
 endif
 det_coef = 0.
 det_coef(1) = 1.
 call get_determinants_det_coef(det_coef)

END_PROVIDER


BEGIN_PROVIDER [ integer, det_exc, (det_num, det_num, 3) ]
 implicit none
 BEGIN_DOC  
! Degree of excitation between two determinants. The sign is the phase.
 END_DOC

 integer :: p
 do p=1,2

  integer :: k, l
  do l=1,det_num
   det_exc(l,l,p) = 0
   do k=l+1,det_num
    det_exc(k,l,p) = 0

    ! Excitation degree
    integer :: i, j
    do i=1,elec_num_2(p)-mo_closed_num

     logical :: found
     found = .False.
     do j=1,elec_num_2(p)-mo_closed_num
      if (det(j,l,p) == det(i,k,p)) then
        found = .True.
        exit
      endif
     enddo
     if (.not.found) then
       det_exc(k,l,p) += 1
     endif

    enddo

    det_exc(l,k,p) = det_exc(k,l,p)
   enddo
  enddo

 enddo

 do l=1,det_num
  do k=l+1,det_num
   det_exc(k,l,3) = det_exc(k,l,1) + det_exc(k,l,2)
  enddo
 enddo

 ! Phase
 do p=1,2
  do i=mo_closed_num,mo_num
   integer :: det_pos(det_num)
   do k=1,det_num
    det_pos(k) = 0
    do j=1,elec_num_2(p)-mo_closed_num
     if (det(j,k,p) == i) then
      det_pos(k) = j
     endif
    enddo
   enddo
   do k=1,det_num
    do l=k+1,det_num
     det_exc(k,l,3) *= -2*mod( (det_pos(k)+det_pos(l)), 2 )+1
    enddo
   enddo
  enddo

 enddo

 do l=1,det_num
  do k=l+1,det_num
   det_exc(l,k,3) = det_exc(k,l,3)
  enddo
 enddo

END_PROVIDER

subroutine get_single_excitation(k,l,m,n,p)
 implicit none
 integer, intent(in)  :: k, l  ! determinant indices
 integer, intent(out) :: m, n  ! m->n excitation
 integer, intent(in)  :: p     ! spin
 
 logical :: found
 integer :: i,j
 m=0
 n=0
 do j=1,elec_num_2(p)-mo_closed_num
  found = .False.
  do i=1,elec_num_2(p)-mo_closed_num
   if (det(j,k,p) == det(i,l,p)) then
    found = .True.
    exit
   endif
  enddo
  if (.not.found) then
    m = det(j,k,p)
    exit
  endif
 enddo

 do i=1,elec_num_2(p)-mo_closed_num
  found = .False.
  do j=1,elec_num_2(p)-mo_closed_num
   if (det(i,k,p) == det(i,l,p)) then
    found = .True.
    exit
   endif
  enddo
  if (.not.found) then
    n = det(i,l,p)
    exit
  endif
 enddo

end

subroutine get_double_excitation(k,l,m,n,r,s,p)
 implicit none
 integer, intent(in)  :: k, l  ! determinant indices
 integer, intent(out) :: m, n  ! m->n excitation
 integer, intent(out) :: r, s  ! r->s excitation
 integer, intent(in)  :: p     ! spin
 
 logical :: found
 integer :: i,j
 m=0
 n=0
 r=0
 s=0
 do j=1,elec_num_2(p)-mo_closed_num
  found = .False.
  do i=1,elec_num_2(p)-mo_closed_num
   if (det(j,k,p) == det(i,l,p)) then
    found = .True.
    exit
   endif
  enddo
  if (.not.found) then
   if (m == 0) then
    m = det(j,k,p)
   else
    r = det(j,k,p)
    exit
   endif
  endif
 enddo

 do i=1,elec_num_2(p)-mo_closed_num
  found = .False.
  do j=1,elec_num_2(p)-mo_closed_num
   if (det(i,k,p) == det(i,l,p)) then
    found = .True.
    exit
   endif
  enddo
  if (.not.found) then
   if (n == 0) then
    n = det(i,l,p)
   else
    s = det(i,l,p)
    exit
   endif
  endif
 enddo

end