QuantumPackage/src/ao_one_e_ints/ao_ortho_canonical.irp.f

 BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_coef, (ao_num,ao_num)]
&BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_normalization, (ao_num)]
  implicit none
  BEGIN_DOC
! Coefficients to go from cartesian to spherical coordinates in the current
! basis set
!
!  S_cart^-1 <cart|sphe>
  END_DOC
  integer :: i
  integer, external              :: ao_power_index
  integer                        :: ibegin,j,k
  integer                        :: prev, ao_sphe_count
  prev = 0
  ao_cart_to_sphe_coef(:,:) = 0.d0
  ao_cart_to_sphe_normalization(:) = 1.d0
  ! Assume order provided by ao_power_index
  i = 1
  ao_sphe_count = 0
  do while (i <= ao_num)
    select case ( ao_l(i) )
      case (0)
        ao_sphe_count += 1
        ao_cart_to_sphe_coef(i,ao_sphe_count) = 1.d0
        ao_cart_to_sphe_normalization(i) = 1.d0
        i += 1
      BEGIN_TEMPLATE
      case ($SHELL)
        if (ao_power(i,1) == $SHELL) then
          do k=1,size(cart_to_sphe_$SHELL,2)
            do j=1,size(cart_to_sphe_$SHELL,1)
              ao_cart_to_sphe_coef(i+j-1,ao_sphe_count+k) = cart_to_sphe_$SHELL(j,k)
            enddo
          enddo
          do j=1,size(cart_to_sphe_$SHELL,1)
            ao_cart_to_sphe_normalization(i+j-1) = cart_to_sphe_norm_$SHELL(j)
          enddo
          i += size(cart_to_sphe_$SHELL,1)
          ao_sphe_count += size(cart_to_sphe_$SHELL,2)
        endif
      SUBST [ SHELL ]
        1;;
        2;;
        3;;
        4;;
        5;;
        6;;
        7;;
        8;;
        9;;
      END_TEMPLATE
      case default
        stop 'Error in ao_cart_to_sphe : angular momentum too high'
    end select
  enddo

  if (ao_sphe_count /= ao_sphe_num) then
    call qp_bug(irp_here, ao_sphe_count, "ao_sphe_count /= ao_sphe_num")
  endif
END_PROVIDER

BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_overlap, (ao_sphe_num,ao_sphe_num) ]
 implicit none
 BEGIN_DOC
 ! T^T . S . T
 END_DOC
 double precision, allocatable :: S(:,:)
 allocate (S(ao_sphe_num,ao_num))

 call dgemm('T','N',ao_sphe_num,ao_num,ao_num, 1.d0, &
   ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
   ao_overlap,size(ao_overlap,1), 0.d0, &
   S, size(S,1))

 call dgemm('N','N',ao_sphe_num,ao_sphe_num,ao_num, 1.d0, &
   S, size(S,1), &
   ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), 0.d0, &
   ao_cart_to_sphe_overlap,size(ao_cart_to_sphe_overlap,1))

 deallocate(S)

END_PROVIDER

BEGIN_PROVIDER [ double precision, ao_cart_to_sphe_inv, (ao_sphe_num,ao_num) ]
 implicit none
 BEGIN_DOC
 ! Inverse of :c:data:`ao_cart_to_sphe_coef`
 END_DOC

  ! Normalize
  integer :: m,k
  double precision, allocatable :: S(:,:), R(:,:), Rinv(:,:), Sinv(:,:)

  k = size(ao_cart_to_sphe_coef,1)
  m = size(ao_cart_to_sphe_coef,2)

  allocate(S(k,k), R(k,m), Rinv(m,k), Sinv(k,k))

  R(:,:) = ao_cart_to_sphe_coef(:,:)

  call dgemm('N','T', m, m, k, 1.d0, R, k, R, k, 0.d0, S, m)
  call get_pseudo_inverse(S, k, k, m, Sinv, k, 1.d-12)
  call dgemm('T','N', m, m, k, 1.d0, R, k, Sinv, k, 0.d0, Rinv, m)


  integer :: i
  do i=1,ao_num
    ao_cart_to_sphe_inv(:,i) = Rinv(:,i)
  enddo

END_PROVIDER



BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef_inv, (ao_num,ao_num)]
 implicit none
 BEGIN_DOC
! ao_ortho_canonical_coef^(-1)
 END_DOC
 call get_inverse(ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),&
     ao_num, ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1))
END_PROVIDER

 BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef, (ao_num,ao_num)]
&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num ]
  implicit none
  BEGIN_DOC
! matrix of the coefficients of the mos generated by the
! orthonormalization by the S^{-1/2} canonical transformation of the aos
! ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital
  END_DOC
  integer :: i
  ao_ortho_canonical_coef = 0.d0
  do i=1,ao_num
    ao_ortho_canonical_coef(i,i) = 1.d0
  enddo

  call write_double(6, lin_dep_cutoff, "Linear dependencies cut-off") 
  if (ao_cartesian) then

    ao_ortho_canonical_num = ao_num
    call ortho_canonical(ao_overlap,size(ao_overlap,1), &
      ao_num,ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1), &
      ao_ortho_canonical_num, lin_dep_cutoff)


  else

    double precision, allocatable :: S(:,:)

    allocate(S(ao_sphe_num,ao_sphe_num))
    S = 0.d0
    do i=1,ao_sphe_num
      S(i,i) = 1.d0
    enddo

    ao_ortho_canonical_num = ao_sphe_num
    call ortho_canonical(ao_cart_to_sphe_overlap, size(ao_cart_to_sphe_overlap,1), &
      ao_sphe_num, S, size(S,1), ao_ortho_canonical_num, lin_dep_cutoff)

    call dgemm('N','N', ao_num, ao_ortho_canonical_num, ao_sphe_num, 1.d0, &
      ao_cart_to_sphe_coef, size(ao_cart_to_sphe_coef,1), &
      S, size(S,1), &
      0.d0, ao_ortho_canonical_coef, size(ao_ortho_canonical_coef,1))

    deallocate(S)
  endif

  FREE ao_overlap

END_PROVIDER

BEGIN_PROVIDER [double precision, ao_ortho_canonical_overlap, (ao_ortho_canonical_num,ao_ortho_canonical_num)]
  implicit none
  BEGIN_DOC
! overlap matrix of the ao_ortho_canonical.
! Expected to be the Identity
  END_DOC
  integer                        :: i,j,k,l
  double precision               :: c
  do j=1, ao_ortho_canonical_num
    do i=1, ao_ortho_canonical_num
      ao_ortho_canonical_overlap(i,j) = 0.d0
    enddo
  enddo
  do j=1, ao_ortho_canonical_num
    do k=1, ao_num
      c = 0.d0
      do l=1, ao_num
        c +=  ao_ortho_canonical_coef(l,j) * ao_overlap(l,k)
      enddo
      do i=1, ao_ortho_canonical_num
        ao_ortho_canonical_overlap(i,j) += ao_ortho_canonical_coef(k,i) * c
      enddo
    enddo
  enddo
END_PROVIDER