10
0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-07-03 09:56:04 +02:00

Cleaned neworbs

This commit is contained in:
Anthony Scemama 2019-06-25 23:10:19 +02:00
parent 6531181316
commit 5902f3231e
2 changed files with 155 additions and 209 deletions

View File

@ -21,10 +21,6 @@ subroutine run
call run_cipsi call run_cipsi
write(6,*) ' total energy = ',eone+etwo+ecore write(6,*) ' total energy = ',eone+etwo+ecore
mo_label = "MCSCF"
mo_label = "Natural"
mo_coef(:,:) = NatOrbsFCI(:,:)
call save_mos
call driver_optorb call driver_optorb
energy_old = energy energy_old = energy

View File

@ -1,222 +1,172 @@
! -*- F90 -*-
BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)]
implicit none implicit none
integer :: i,j BEGIN_DOC
do i=1,nMonoEx+1 ! Single-excitation matrix
do j=1,nMonoEx+1 END_DOC
SXmatrix(i,j)=0.D0
end do integer :: i,j
end do
do i=1,nMonoEx+1
do i=1,nMonoEx do j=1,nMonoEx+1
SXmatrix(1,i+1)=gradvec2(i) SXmatrix(i,j)=0.D0
SXmatrix(1+i,1)=gradvec2(i) end do
end do end do
do i=1,nMonoEx do i=1,nMonoEx
do j=1,nMonoEx SXmatrix(1,i+1)=gradvec2(i)
SXmatrix(i+1,j+1)=hessmat2(i,j) SXmatrix(1+i,1)=gradvec2(i)
SXmatrix(j+1,i+1)=hessmat2(i,j) end do
end do
end do do i=1,nMonoEx
do j=1,nMonoEx
if (bavard) then SXmatrix(i+1,j+1)=hessmat2(i,j)
do i=2,nMonoEx+1 SXmatrix(j+1,i+1)=hessmat2(i,j)
write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) end do
end do end do
end if
if (bavard) then
do i=2,nMonoEx+1
write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i)
end do
end if
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)] BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)]
&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)] &BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)]
END_PROVIDER implicit none
BEGIN_DOC
! Eigenvectors/eigenvalues of the single-excitation matrix
END_DOC
call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1)
END_PROVIDER
BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)]
&BEGIN_PROVIDER [real*8, energy_improvement] &BEGIN_PROVIDER [real*8, energy_improvement]
implicit none implicit none
integer :: ierr,matz,i BEGIN_DOC
real*8 :: c0 ! Best eigenvector of the single-excitation matrix
END_DOC
call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) integer :: ierr,matz,i
write(6,*) ' SXdiag : lowest 5 eigenvalues ' real*8 :: c0
write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) write(6,*) ' SXdiag : lowest 5 eigenvalues '
write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2)
write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3)
write(6,*) write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4)
write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5)
energy_improvement = SXeigenval(1) write(6,*)
write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1)
integer :: best_vector energy_improvement = SXeigenval(1)
real*8 :: best_overlap
best_overlap=0.D0 integer :: best_vector
do i=1,nMonoEx+1 real*8 :: best_overlap
if (SXeigenval(i).lt.0.D0) then best_overlap=0.D0
if (abs(SXeigenvec(1,i)).gt.best_overlap) then do i=1,nMonoEx+1
best_overlap=abs(SXeigenvec(1,i)) if (SXeigenval(i).lt.0.D0) then
best_vector=i if (abs(SXeigenvec(1,i)).gt.best_overlap) then
end if best_overlap=abs(SXeigenvec(1,i))
end if best_vector=i
end do end if
end if
write(6,*) ' SXdiag : eigenvalue for best overlap with ' end do
write(6,*) ' previous orbitals = ',SXeigenval(best_vector)
energy_improvement = SXeigenval(best_vector) write(6,*) ' SXdiag : eigenvalue for best overlap with '
write(6,*) ' previous orbitals = ',SXeigenval(best_vector)
c0=SXeigenvec(1,best_vector) energy_improvement = SXeigenval(best_vector)
write(6,*) ' weight of the 1st element ',c0
do i=1,nMonoEx+1 c0=SXeigenvec(1,best_vector)
SXvector(i)=SXeigenvec(i,best_vector)/c0 write(6,*) ' weight of the 1st element ',c0
! write(6,*) ' component No ',i,' : ',SXvector(i) do i=1,nMonoEx+1
end do SXvector(i)=SXeigenvec(i,best_vector)/c0
! write(6,*) ' component No ',i,' : ',SXvector(i)
end do
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ]
implicit none implicit none
integer :: i,j,ialph BEGIN_DOC
! Updated orbitals
! form the exponential of the Orbital rotations END_DOC
call get_orbrotmat integer :: i,j,ialph
! form the new orbitals
do i=1,ao_num call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, &
do j=1,mo_num NatOrbsFCI, size(NatOrbsFCI,1), &
NewOrbs(i,j)=0.D0 Umat, size(Umat,1), 0.d0, &
end do NewOrbs, size(NewOrbs,1))
end do
do ialph=1,ao_num
do i=1,mo_num
wrkline(i)=mo_coef(ialph,i)
end do
do i=1,mo_num
do j=1,mo_num
NewOrbs(ialph,i)+=Umat(i,j)*wrkline(j)
end do
end do
end do
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [real*8, Tpotmat, (mo_num,mo_num) ] BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] implicit none
&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ] BEGIN_DOC
&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ] ! Orbital rotation matrix
END_PROVIDER END_DOC
integer :: i,j,indx,k,iter,t,a,ii,tt,aa
subroutine get_orbrotmat logical :: converged
implicit none
integer :: i,j,indx,k,iter,t,a,ii,tt,aa real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num)
real*8 :: sum real*8 :: Tmat(mo_num,mo_num)
logical :: converged real*8 :: f
! the orbital rotation matrix T
! the orbital rotation matrix T Tmat(:,:)=0.D0
do i=1,mo_num indx=1
do j=1,mo_num do i=1,n_core_orb
Tmat(i,j)=0.D0 ii=list_core(i)
Umat(i,j)=0.D0 do t=1,n_act_orb
Tpotmat(i,j)=0.D0 tt=list_act(t)
end do indx+=1
Tpotmat(i,i)=1.D0 Tmat(ii,tt)= SXvector(indx)
end do Tmat(tt,ii)=-SXvector(indx)
end do
indx=1 end do
do i=1,n_core_orb do i=1,n_core_orb
ii=list_core(i) ii=list_core(i)
do t=1,n_act_orb do a=1,n_virt_orb
tt=list_act(t) aa=list_virt(a)
indx+=1 indx+=1
Tmat(ii,tt)= SXvector(indx) Tmat(ii,aa)= SXvector(indx)
Tmat(tt,ii)=-SXvector(indx) Tmat(aa,ii)=-SXvector(indx)
end do end do
end do end do
do i=1,n_core_orb do t=1,n_act_orb
ii=list_core(i) tt=list_act(t)
do a=1,n_virt_orb do a=1,n_virt_orb
aa=list_virt(a) aa=list_virt(a)
indx+=1 indx+=1
Tmat(ii,aa)= SXvector(indx) Tmat(tt,aa)= SXvector(indx)
Tmat(aa,ii)=-SXvector(indx) Tmat(aa,tt)=-SXvector(indx)
end do end do
end do end do
do t=1,n_act_orb
tt=list_act(t) ! Form the exponential
do a=1,n_virt_orb
aa=list_virt(a) Tpotmat(:,:)=0.D0
indx+=1 Umat(:,:) =0.D0
Tmat(tt,aa)= SXvector(indx) do i=1,mo_num
Tmat(aa,tt)=-SXvector(indx) Tpotmat(i,i)=1.D0
end do Umat(i,i) =1.d0
end do end do
iter=0
write(6,*) ' the T matrix ' converged=.false.
do indx=1,nMonoEx do while (.not.converged)
i=excit(1,indx) iter+=1
j=excit(2,indx) f = 1.d0 / dble(iter)
! if (abs(Tmat(i,j)).gt.1.D0) then Tpotmat2(:,:) = Tpotmat(:,:) * f
! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' & call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, &
! , sign(1.D0,Tmat(i,j)) Tpotmat2, size(Tpotmat2,1), &
! Tmat(i,j)=sign(1.D0,Tmat(i,j)) Tmat, size(Tmat,1), 0.d0, &
! Tmat(j,i)=-Tmat(i,j) Tpotmat, size(Tpotmat,1))
! end if Umat(:,:) = Umat(:,:) + Tpotmat(:,:)
if (abs(Tmat(i,j)).gt.1.D-9) write(6,9901) i,j,excit_class(indx),Tmat(i,j)
9901 format(' ',i4,' -> ',i4,' (',A3,') : ',E14.6) converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30)
end do end do
write(6,*)
write(6,*) ' forming the matrix exponential '
write(6,*)
! form the exponential
iter=0
converged=.false.
do while (.not.converged)
iter+=1
! add the next term
do i=1,mo_num
do j=1,mo_num
Umat(i,j)+=Tpotmat(i,j)
end do
end do
! next power of T, we multiply Tpotmat with Tmat/iter
do i=1,mo_num
do j=1,mo_num
wrkline(j)=Tpotmat(i,j)/dble(iter)
Tpotmat(i,j)=0.D0
end do
do j=1,mo_num
do k=1,mo_num
Tpotmat(i,j)+=wrkline(k)*Tmat(k,j)
end do
end do
end do
! Convergence test
sum=0.D0
do i=1,mo_num
do j=1,mo_num
sum+=abs(Tpotmat(i,j))
end do
end do
write(6,*) ' Iteration No ',iter,' Sum = ',sum
if (sum.lt.1.D-6) then
converged=.true.
end if
if (iter.ge.NItExpMax) then
stop ' no convergence '
end if
end do
write(6,*)
write(6,*) ' Converged ! '
write(6,*)
end subroutine get_orbrotmat
BEGIN_PROVIDER [integer, NItExpMax]
NItExpMax=100
END_PROVIDER END_PROVIDER