QuantumPackage/src/bitmask/track_orb.irp.f

BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num,mo_num) ]
   implicit none
   BEGIN_DOC
   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
   !
   ! Useful to track some orbitals
   END_DOC
END_PROVIDER

BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_complex, (ao_num,mo_num) ]
   implicit none
   BEGIN_DOC
   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
   !
   ! Useful to track some orbitals
   END_DOC
END_PROVIDER

BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_kpts, (ao_num_per_kpt,mo_num_per_kpt,kpt_num) ]
   implicit none
   BEGIN_DOC
   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
   !
   ! Useful to track some orbitals
   END_DOC
END_PROVIDER

subroutine initialize_mo_coef_begin_iteration
 implicit none
 BEGIN_DOC
 !
 ! Initialize :c:data:`mo_coef_begin_iteration` to the current :c:data:`mo_coef`
 END_DOC
 if (is_complex) then
   !mo_coef_begin_iteration_complex = mo_coef_complex
   mo_coef_begin_iteration_kpts = mo_coef_kpts
 else
   mo_coef_begin_iteration = mo_coef
 endif
end

subroutine reorder_core_orb
  implicit none
  BEGIN_DOC
  ! TODO: test for complex
 ! routines that takes the current :c:data:`mo_coef` and reorder the core orbitals (see :c:data:`list_core` and :c:data:`n_core_orb`) according to the overlap with :c:data:`mo_coef_begin_iteration`
  END_DOC
  integer :: i,j,iorb
  integer :: k,l
  integer, allocatable :: index_core_orb(:),iorder(:)
  double precision, allocatable :: accu(:)
  integer :: i1,i2
  if (is_complex) then
    complex*16, allocatable :: accu_c(:)
    !allocate(accu(mo_num),accu_c(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
    !do i = 1, n_core_orb
    !  iorb = list_core(i)
    !  do j = 1, mo_num
    !    accu(j) = 0.d0
    !    accu_c(j) = (0.d0,0.d0)
    !    iorder(j) = j
    !    do k = 1, ao_num
    !      do l = 1, ao_num
    !        accu_c(j) += dconjg(mo_coef_begin_iteration_complex(k,iorb)) * &
    !                     mo_coef_complex(l,j) * ao_overlap_complex(k,l)
    !      enddo
    !    enddo
    !    accu(j) = -cdabs(accu_c(j))
    !  enddo
    !  call dsort(accu,iorder,mo_num)
    !  index_core_orb(i) = iorder(1)
    !enddo

    !complex*16 :: x_c
    !do j = 1, n_core_orb
    !  i1 = list_core(j)
    !  i2 = index_core_orb(j)
    !  do i=1,ao_num
    !     x_c = mo_coef_complex(i,i1)
    !     mo_coef_complex(i,i1) = mo_coef_complex(i,i2)
    !     mo_coef_complex(i,i2) = x_c
    !  enddo
    !enddo
    !!call loc_cele_routine
   
    !deallocate(accu,accu_c,index_core_orb, iorder)
    allocate(accu(mo_num_per_kpt),accu_c(mo_num_per_kpt),index_core_orb(n_core_orb),iorder(mo_num_per_kpt))
    integer :: kk
    do kk=1,kpt_num
      do i = 1, n_core_orb_kpts(kk)
        iorb = list_core_kpts(i,kk)
        do j = 1, mo_num_per_kpt
          accu(j) = 0.d0
          accu_c(j) = (0.d0,0.d0)
          iorder(j) = j
          do k = 1, ao_num_per_kpt
            do l = 1, ao_num_per_kpt
              accu_c(j) += dconjg(mo_coef_begin_iteration_kpts(k,iorb,kk)) * &
                           mo_coef_kpts(l,j,kk) * ao_overlap_kpts(k,l,kk)
            enddo
          enddo
          accu(j) = -cdabs(accu_c(j))
        enddo
        call dsort(accu,iorder,mo_num_per_kpt)
        index_core_orb(i) = iorder(1)
      enddo

      complex*16 :: x_c
      do j = 1, n_core_orb
        i1 = list_core_kpts(j,kk)
        i2 = index_core_orb(j)
        do i=1,ao_num_per_kpt
           x_c = mo_coef_kpts(i,i1,kk)
           mo_coef_kpts(i,i1,kk) = mo_coef_kpts(i,i2,kk)
           mo_coef_kpts(i,i2,kk) = x_c
        enddo
      enddo
      !call loc_cele_routine
    enddo
    deallocate(accu,accu_c,index_core_orb, iorder)
  else
    allocate(accu(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
   
    do i = 1, n_core_orb
      iorb = list_core(i)
      do j = 1, mo_num
        accu(j) = 0.d0
        iorder(j) = j
        do k = 1, ao_num
          do l = 1, ao_num
            accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
          enddo
        enddo
        accu(j) = -dabs(accu(j))
      enddo
      call dsort(accu,iorder,mo_num)
      index_core_orb(i) = iorder(1)
    enddo
   
    double precision :: x
    do j = 1, n_core_orb
      i1 = list_core(j)
      i2 = index_core_orb(j)
      do i=1,ao_num
         x = mo_coef(i,i1)
         mo_coef(i,i1) = mo_coef(i,i2)
         mo_coef(i,i2) = x
      enddo
    enddo
    !call loc_cele_routine
   
    deallocate(accu,index_core_orb, iorder)
  endif
end