QuantumPackage/src/casscf/neworbs.irp.f

BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)]
  implicit none
  BEGIN_DOC
  ! Single-excitation matrix
  END_DOC
  
  integer                        :: i,j
  
  do i=1,nMonoEx+1
    do j=1,nMonoEx+1
      SXmatrix(i,j)=0.D0
    end do
  end do
  
  do i=1,nMonoEx
    SXmatrix(1,i+1)=gradvec2(i)
    SXmatrix(1+i,1)=gradvec2(i)
  end do
  
  do i=1,nMonoEx
    do j=1,nMonoEx
      SXmatrix(i+1,j+1)=hessmat2(i,j)
      SXmatrix(j+1,i+1)=hessmat2(i,j)
    end do
  end do
  
  do i = 1, nMonoEx
   SXmatrix(i+1,i+1) += level_shift_casscf
  enddo
  if (bavard) then
    do i=2,nMonoEx
      write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i)
    end do
  end if
  
  
END_PROVIDER

 BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)]
&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)]
  implicit none
  BEGIN_DOC
  ! Eigenvectors/eigenvalues of the single-excitation matrix
  END_DOC
  call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1)
  if (bavard) then
    write(6,*) ' SXdiag : lowest 5 eigenvalues '
    write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
    if(nmonoex.gt.0)then
     write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2)
     write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3)
     write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4)
     write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5)
    endif
    write(6,*)
    write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1)
  endif
END_PROVIDER

 BEGIN_PROVIDER [real*8, energy_improvement]
 implicit none
 if(state_following_casscf)then
  energy_improvement = SXeigenval(best_vector_ovrlp_casscf)
 else 
  energy_improvement = SXeigenval(1)
 endif
 END_PROVIDER 



 BEGIN_PROVIDER [ integer, best_vector_ovrlp_casscf ]
&BEGIN_PROVIDER [ double precision,  best_overlap_casscf ]
  implicit none
  integer :: i
  double precision :: c0
  best_overlap_casscf = 0.D0
  best_vector_ovrlp_casscf = -1000
  do i=1,nMonoEx+1
    if (SXeigenval(i).lt.0.D0) then
      if (abs(SXeigenvec(1,i)).gt.best_overlap_casscf) then
        best_overlap_casscf=abs(SXeigenvec(1,i))
        best_vector_ovrlp_casscf = i
      end if
    end if
  end do
  if(best_vector_ovrlp_casscf.lt.0)then 
   best_vector_ovrlp_casscf = minloc(SXeigenval,nMonoEx+1) 
  endif
  c0=SXeigenvec(1,best_vector_ovrlp_casscf)
  if (bavard) then
    write(6,*) ' SXdiag : eigenvalue for best overlap with '
    write(6,*) ' previous orbitals = ',SXeigenval(best_vector_ovrlp_casscf)
    write(6,*) ' weight of the 1st element ',c0
  endif
 END_PROVIDER 

 BEGIN_PROVIDER [double precision, SXvector, (nMonoEx+1)]
  implicit none
  BEGIN_DOC
  ! Best eigenvector of the single-excitation matrix
  END_DOC
  integer           :: i
  double precision  :: c0
  c0=SXeigenvec(1,best_vector_ovrlp_casscf)
  do i=1,nMonoEx+1
    SXvector(i)=SXeigenvec(i,best_vector_ovrlp_casscf)/c0
  end do
 END_PROVIDER


BEGIN_PROVIDER [double precision, NewOrbs, (ao_num,mo_num) ]
  implicit none
  BEGIN_DOC
  ! Updated orbitals
  END_DOC
  integer                        :: i,j,ialph
  
  if(state_following_casscf)then
   print*,'Using the state following casscf '
   call dgemm('N','T', ao_num,mo_num,mo_num,1.d0,                     &
       NatOrbsFCI, size(NatOrbsFCI,1),                                &
       Umat, size(Umat,1), 0.d0,                                      &
       NewOrbs, size(NewOrbs,1))

    level_shift_casscf *= 0.5D0
    level_shift_casscf = max(level_shift_casscf,0.002d0)
   !touch level_shift_casscf
  else
   if(best_vector_ovrlp_casscf.ne.1.and.n_orb_swap.ne.0)then
     print*,'Taking the lowest root for the CASSCF'
     print*,'!!! SWAPPING MOS !!!!!!'
     level_shift_casscf *= 2.D0
    level_shift_casscf = min(level_shift_casscf,0.5d0)
     print*,'level_shift_casscf = ',level_shift_casscf
     NewOrbs = switch_mo_coef
    !mo_coef = switch_mo_coef
    !soft_touch mo_coef
    !call save_mos_no_occ
    !stop
   else 
    level_shift_casscf *= 0.5D0
    level_shift_casscf = max(level_shift_casscf,0.002d0)
   !touch level_shift_casscf
    call dgemm('N','T', ao_num,mo_num,mo_num,1.d0,                     &
        NatOrbsFCI, size(NatOrbsFCI,1),                                &
        Umat, size(Umat,1), 0.d0,                                      &
        NewOrbs, size(NewOrbs,1))
   endif
  endif
  
END_PROVIDER

BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
  implicit none
  BEGIN_DOC
  ! Orbital rotation matrix
  END_DOC
  integer                        :: i,j,indx,k,iter,t,a,ii,tt,aa
  logical                        :: converged
  
  real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num) 
  real*8 :: Tmat(mo_num,mo_num) 
  real*8 :: f
  
  ! the orbital rotation matrix T
  Tmat(:,:)=0.D0
  indx=1
  do i=1,n_core_inact_orb
    ii=list_core_inact(i)
    do t=1,n_act_orb
      tt=list_act(t)
      indx+=1
      Tmat(ii,tt)= SXvector(indx)
      Tmat(tt,ii)=-SXvector(indx)
    end do
  end do
  do i=1,n_core_inact_orb
    ii=list_core_inact(i)
    do a=1,n_virt_orb
      aa=list_virt(a)
      indx+=1
      Tmat(ii,aa)= SXvector(indx)
      Tmat(aa,ii)=-SXvector(indx)
    end do
  end do
  do t=1,n_act_orb
    tt=list_act(t)
    do a=1,n_virt_orb
      aa=list_virt(a)
      indx+=1
      Tmat(tt,aa)= SXvector(indx)
      Tmat(aa,tt)=-SXvector(indx)
    end do
  end do
  
  ! Form the exponential

  Tpotmat(:,:)=0.D0
  Umat(:,:)   =0.D0
  do i=1,mo_num
    Tpotmat(i,i)=1.D0
    Umat(i,i)   =1.d0
  end do
  iter=0
  converged=.false.
  do while (.not.converged)
    iter+=1
    f = 1.d0 / dble(iter)
    Tpotmat2(:,:) = Tpotmat(:,:) * f
    call dgemm('N','N', mo_num,mo_num,mo_num,1.d0,                   &
        Tpotmat2, size(Tpotmat2,1),                                  &
        Tmat, size(Tmat,1), 0.d0,                                    &
        Tpotmat, size(Tpotmat,1))
    Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
    
    converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
  end do
END_PROVIDER