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*1, det_exc, (det_num, det_num, 2) ]
 implicit none
 BEGIN_DOC  
! Degree of excitation between two determinants. Indices are alpha, beta
! The sign is the phase factor
 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

   enddo
  enddo

 enddo

 ! Phase

 do l=1,det_num
  do k=l+1,det_num
   integer :: nperm
   nperm = 0
   do p=1,2
    integer :: buffer(0:mo_num-mo_closed_num)
    do i=1,elec_num_2(p)-mo_closed_num
     buffer(i) = det(i,k,p)
    enddo
    do i=1,elec_num_2(p)-mo_closed_num
     if (buffer(i) /= det(i,l,p)) then
      integer :: m
      m=elec_num_2(p)-mo_closed_num
      do j=i+1,elec_num_2(p)-mo_closed_num
       if (buffer(i) == det(j,l,p)) then  ! found
        m=j
        exit
       endif 
      enddo
      buffer(0) = buffer(i)
      buffer(i) = det(m,l,p)
      buffer(m) = buffer(0)
      nperm += 1
     endif
    enddo
    det_exc(k,l,p) *= (1-2*mod( nperm, 2 ))
    det_exc(l,k,p) = det_exc(k,l,p)
   enddo
  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(j,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(j,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