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 [ real, mo_occ, (mo_tot_num) ]
 implicit none
 BEGIN_DOC
! Occupation numbers of molecular orbitals
 END_DOC

 call get_mo_basis_mo_occ(mo_occ)

END_PROVIDER



integer function det_exc(k,l,p)
 implicit none
! Degree of excitation between two determinants. Indices are alpha, beta
! The sign is the phase factor

 integer :: k,l,p

 integer :: i, j
 det_exc = 0
 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 += 1
  endif

 enddo

 ! Phase

 integer :: nperm
 nperm = 0
 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 *= (1-2*mod( nperm, 2 ))

end

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

BEGIN_PROVIDER [ real, ci_mo, (mo_num,mo_num,3) ]
 implicit none
 BEGIN_DOC  
! Spin Density matrix in the AO basis
 END_DOC
 integer :: i,j,k,l,m,ispin, ik,il
 do ispin=1,3

  do j=1,mo_num
   do i=1,mo_num
    ci_mo(i,j,ispin) = 0.
   enddo
  enddo

  do l=1,det_num
   do m=1,det_num
    real :: factor
    factor = 2.*det_coef(l)*det_coef(m) 
    do il=1,mo_closed_num
     do ik=1,mo_closed_num
      ci_mo(ik,il,ispin) += factor
     enddo
    enddo
   enddo
  enddo

 enddo


 do l=1,det_num
  do m=1,det_num
   factor = det_coef(l)*det_coef(m) 
   do ispin=1,2
    do j=mo_closed_num+1,elec_num_2(ispin)
     ik = det(j-mo_closed_num,l,ispin)
     do il=1,mo_closed_num
      ci_mo(ik,il,ispin) += factor
      ci_mo(il,ik,ispin) += factor
     enddo
     do i=mo_closed_num+1,elec_num_2(ispin)
      il = det(i-mo_closed_num,m,ispin)
      ci_mo(ik,il,ispin) += factor
      ci_mo(il,ik,ispin) += factor
     enddo
    enddo
   enddo

   ispin=3
   do j=mo_closed_num+1,elec_num_2(1)
    ik = det(j-mo_closed_num,l,1)
    do il=1,mo_closed_num
     ci_mo(ik,il,ispin) += det_coef(l)*det_coef(m) 
     ci_mo(il,ik,ispin) += det_coef(l)*det_coef(m) 
    enddo
    do i=mo_closed_num+1,elec_num_2(2)
     il = det(i-mo_closed_num,m,2)
     ci_mo(ik,il,ispin) += det_coef(l)*det_coef(m) 
     ci_mo(il,ik,ispin) += det_coef(l)*det_coef(m) 
    enddo
   enddo

  enddo
 enddo

END_PROVIDER