QuantumPackage/src/casscf/densities.irp.f

use bitmasks

BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ]
  BEGIN_DOC
  ! the first-order density matrix in the basis of the starting MOs
  ! matrices are state averaged
  !
  ! we use the spin-free generators of mono-excitations
  ! E_pq destroys q and creates p
  ! D_pq   =     <0|E_pq|0> = D_qp
  !
  END_DOC
  implicit none
  integer                        :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
  integer                        :: ierr
  integer(bit_kind)              :: det_mu(N_int,2)
  integer(bit_kind)              :: det_mu_ex(N_int,2)
  integer(bit_kind)              :: det_mu_ex1(N_int,2)
  integer(bit_kind)              :: det_mu_ex2(N_int,2)
  real*8                         :: phase1,phase2,term
  integer                        :: nu1,nu2
  integer                        :: ierr1,ierr2
  real*8                         :: cI_mu(N_states)
  
  if (bavard) then
    write(6,*) ' providing density matrix D0'
  endif
  
  D0tu = 0.d0
  
  ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
  do mu=1,n_det
    call det_extract(det_mu,mu,N_int)
    do istate=1,n_states
      cI_mu(istate)=psi_coef(mu,istate)
    end do
    do t=1,n_act_orb
      ipart=list_act(t)
      do u=1,n_act_orb
        ihole=list_act(u)
        ! apply E_tu
        call det_copy(det_mu,det_mu_ex1,N_int)
        call det_copy(det_mu,det_mu_ex2,N_int)
        call do_spinfree_mono_excitation(det_mu,det_mu_ex1           &
            ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
        ! det_mu_ex1 is in the list
        if (nu1.ne.-1) then
          do istate=1,n_states
            term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
            D0tu(t,u)+=term
          end do
        end if
        ! det_mu_ex2 is in the list
        if (nu2.ne.-1) then
          do istate=1,n_states
            term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
            D0tu(t,u)+=term
          end do
        end if
      end do
    end do
  end do
  
  ! we average by just dividing by the number of states
  do x=1,n_act_orb
    do v=1,n_act_orb
      D0tu(v,x)*=1.0D0/dble(N_states)
    end do
  end do
  
END_PROVIDER

BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ]
   BEGIN_DOC
   ! the second-order density matrix in the basis of the starting MOs
   ! matrices are state averaged
   !
   ! we use the spin-free generators of mono-excitations
   ! E_pq destroys q and creates p
   ! D_pq   =     <0|E_pq|0> = D_qp
   ! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0>
   !
   END_DOC
   implicit none
   integer                        :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart
   integer                        :: ierr
   real*8                         :: phase1,phase11,phase12,phase2,phase21,phase22
   integer                        :: nu1,nu2,nu11,nu12,nu21,nu22
   integer                        :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22
   real*8                         :: cI_mu(N_states),term
   integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex
   integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12
   integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22
   
  if (bavard) then
    write(6,*) ' providing density matrix P0'
  endif

   P0tuvx = 0.d0
   
   ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu
   do mu=1,n_det
     call det_extract(det_mu,mu,N_int)
     do istate=1,n_states
       cI_mu(istate)=psi_coef(mu,istate)
     end do
     do t=1,n_act_orb
       ipart=list_act(t)
       do u=1,n_act_orb
         ihole=list_act(u)
         ! apply E_tu
         call det_copy(det_mu,det_mu_ex1,N_int)
         call det_copy(det_mu,det_mu_ex2,N_int)
         call do_spinfree_mono_excitation(det_mu,det_mu_ex1          &
             ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
         ! det_mu_ex1 is in the list
         if (nu1.ne.-1) then
           do istate=1,n_states
             term=cI_mu(istate)*psi_coef(nu1,istate)*phase1
             ! and we fill P0_tvvu
             do v=1,n_act_orb
               P0tuvx(t,v,v,u)-=term
             end do
           end do
         end if
         ! det_mu_ex2 is in the list
         if (nu2.ne.-1) then
           do istate=1,n_states
             term=cI_mu(istate)*psi_coef(nu2,istate)*phase2
             do v=1,n_act_orb
               P0tuvx(t,v,v,u)-=term
             end do
           end do
         end if
       end do
     end do
   end do
   ! now we do the double excitation E_tu E_vx |0>
   do mu=1,n_det
     call det_extract(det_mu,mu,N_int)
     do istate=1,n_states
       cI_mu(istate)=psi_coef(mu,istate)
     end do
     do v=1,n_act_orb
       ipart=list_act(v)
       do x=1,n_act_orb
         ihole=list_act(x)
         ! apply E_vx
         call det_copy(det_mu,det_mu_ex1,N_int)
         call det_copy(det_mu,det_mu_ex2,N_int)
         call do_spinfree_mono_excitation(det_mu,det_mu_ex1          &
             ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2)
         ! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0>
         if (ierr1.eq.1) then
           do t=1,n_act_orb
             jpart=list_act(t)
             do u=1,n_act_orb
               jhole=list_act(u)
               call det_copy(det_mu_ex1,det_mu_ex11,N_int)
               call det_copy(det_mu_ex1,det_mu_ex12,N_int)
               call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11&
                   ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12)
               if (nu11.ne.-1) then
                 do istate=1,n_states
                   P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)&
                       *phase11*phase1
                 end do
               end if
               if (nu12.ne.-1) then
                 do istate=1,n_states
                   P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)&
                       *phase12*phase1
                 end do
               end if
             end do
           end do
         end if
         
         ! we apply E_tu to the second resultant determinant
         if (ierr2.eq.1) then
           do t=1,n_act_orb
             jpart=list_act(t)
             do u=1,n_act_orb
               jhole=list_act(u)
               call det_copy(det_mu_ex2,det_mu_ex21,N_int)
               call det_copy(det_mu_ex2,det_mu_ex22,N_int)
               call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21&
                   ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22)
               if (nu21.ne.-1) then
                 do istate=1,n_states
                   P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)&
                       *phase21*phase2
                 end do
               end if
               if (nu22.ne.-1) then
                 do istate=1,n_states
                   P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)&
                       *phase22*phase2
                 end do
               end if
             end do
           end do
         end if
         
       end do
     end do
   end do
   
   ! we average by just dividing by the number of states
   do x=1,n_act_orb
     do v=1,n_act_orb
       do u=1,n_act_orb
         do t=1,n_act_orb
           P0tuvx(t,u,v,x)*=0.5D0/dble(N_states)
         end do
       end do
     end do
   end do
   
END_PROVIDER