qp_plugins_scemama/devel/casscf/det_manip.irp.f

use bitmasks

subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart,       &
      ispin,phase,ierr)
  BEGIN_DOC
  ! we create the mono-excitation, and determine, if possible,
  ! the phase and the number in the list of determinants
  END_DOC
  implicit none
  integer(bit_kind)              :: key1(N_int,2),key2(N_int,2)
  integer(bit_kind), allocatable :: keytmp(:,:)
  integer                        :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin
  real*8                         :: phase
  logical                        :: found
  allocate(keytmp(N_int,2))
  
  nu=-1
  phase=1.D0
  ierr=0
  call det_copy(key1,key2,N_int)
  !        write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin
  !        call print_det(key2,N_int)
  call do_single_excitation(key2,ihole,ipart,ispin,ierr)
  !        write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin
  !        call print_det(key2,N_int)
  !        write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr
  if (ierr.eq.1) then
    ! excitation is possible
    ! get the phase
    call get_single_excitation(key1,key2,exc,phase,N_int)
    ! get the number in the list
    found=.false.
    nu=0

    !TODO BOTTLENECK
    do while (.not.found)
      nu+=1
      if (nu.gt.N_det) then
        ! the determinant is possible, but not in the list
        found=.true.
        nu=-1
      else
        call det_extract(keytmp,nu,N_int)
        integer                        :: i,ii
        found=.true.
        do ii=1,2
          do i=1,N_int
            if (keytmp(i,ii).ne.key2(i,ii)) then
              found=.false.
            end if
          end do
        end do
      end if
    end do
  end if
  !
  ! we found the new string, the phase, and possibly the number in the list
  !
end subroutine do_signed_mono_excitation

subroutine det_extract(key,nu,Nint)
  BEGIN_DOC
  ! extract a determinant from the list of determinants
  END_DOC
  implicit none
  integer                        :: ispin,i,nu,Nint
  integer(bit_kind)              :: key(Nint,2)
  do ispin=1,2
    do i=1,Nint
      key(i,ispin)=psi_det(i,ispin,nu)
    end do
  end do
end subroutine det_extract

subroutine det_copy(key1,key2,Nint)
  use bitmasks ! you need to include the bitmasks_module.f90 features
  BEGIN_DOC
  ! copy a determinant from key1 to key2
  END_DOC
  implicit none
  integer                        :: ispin,i,Nint
  integer(bit_kind)              :: key1(Nint,2),key2(Nint,2)
  do ispin=1,2
    do i=1,Nint
      key2(i,ispin)=key1(i,ispin)
    end do
  end do
end subroutine det_copy

subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2      &
      ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr)
  BEGIN_DOC
  ! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q)
  ! we may create two determinants as result
  !
  END_DOC
  implicit none
  integer(bit_kind)              :: key_in(N_int,2),key_out1(N_int,2)
  integer(bit_kind)              :: key_out2(N_int,2)
  integer                        :: ihole,ipart,ierr,jerr,nu1,nu2
  integer                        :: ispin
  real*8                         :: phase1,phase2
  
  !        write(6,*) ' applying E_',ipart,ihole,' on determinant '
  !        call print_det(key_in,N_int)
  
  ! spin alpha
  ispin=1
  call do_signed_mono_excitation(key_in,key_out1,nu1,ihole           &
      ,ipart,ispin,phase1,ierr)
  !        if (ierr.eq.1) then
  !         write(6,*) ' 1 result is ',nu1,phase1
  !         call print_det(key_out1,N_int)
  !        end if
  ! spin beta
  ispin=2
  call do_signed_mono_excitation(key_in,key_out2,nu2,ihole           &
      ,ipart,ispin,phase2,jerr)
  !        if (jerr.eq.1) then
  !         write(6,*) ' 2 result is ',nu2,phase2
  !         call print_det(key_out2,N_int)
  !        end if
  
end subroutine do_spinfree_mono_excitation