qp2/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
  
  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, SXvector, (nMonoEx+1)]
&BEGIN_PROVIDER [real*8, energy_improvement]
  implicit none
  BEGIN_DOC
  ! Best eigenvector of the single-excitation matrix
  END_DOC
  integer                        :: ierr,matz,i
  real*8                         :: c0
  
  energy_improvement = SXeigenval(1)
  
  integer                        :: best_vector
  real*8                         :: best_overlap
  best_overlap=0.D0
  best_vector = -1000
  do i=1,nMonoEx+1
    if (SXeigenval(i).lt.0.D0) then
      if (abs(SXeigenvec(1,i)).gt.best_overlap) then
        best_overlap=abs(SXeigenvec(1,i))
        best_vector=i
      end if
    end if
  end do
  if(best_vector.lt.0)then 
   best_vector = minloc(SXeigenval,nMonoEx+1) 
  endif
  energy_improvement = SXeigenval(best_vector)
  
  c0=SXeigenvec(1,best_vector)

  if (bavard) then
    write(6,*) ' SXdiag : eigenvalue for best overlap with '
    write(6,*) '  previous orbitals = ',SXeigenval(best_vector)
    write(6,*) ' weight of the 1st element ',c0
  endif

  do i=1,nMonoEx+1
    SXvector(i)=SXeigenvec(i,best_vector)/c0
  end do

  
END_PROVIDER


BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ]
  implicit none
  BEGIN_DOC
  ! Updated orbitals
  END_DOC
  integer                        :: i,j,ialph
  
  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))
  
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