10
0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-11-08 07:03:52 +01:00

More cleaning

This commit is contained in:
Anthony Scemama 2019-06-25 19:10:50 +02:00
parent 26be853c18
commit 6531181316
5 changed files with 21 additions and 93 deletions

View File

@ -19,7 +19,13 @@ subroutine run
N_det = 1 N_det = 1
TOUCH N_det psi_det psi_coef TOUCH N_det psi_det psi_coef
call run_cipsi call run_cipsi
call driver_wdens
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
energy = eone+etwo+ecore energy = eone+etwo+ecore

View File

@ -1,52 +0,0 @@
subroutine driver_wdens
implicit none
integer :: istate,p,q,r,s,indx,i,j
write(6,*) ' total energy = ',eone+etwo+ecore
write(6,*) ' generating natural orbitals '
write(6,*)
write(6,*)
write(6,*) ' all data available ! '
write(6,*) ' writing out files '
call trf_to_natorb
real*8 :: approx,np,nq,nr,ns
logical :: lpq,lrs,lps,lqr
open(unit=12,form='formatted',status='unknown',file='onetrf.tmp')
indx=0
do q=1,mo_num
do p=q,mo_num
if (abs(onetrf(p,q)).gt.1.D-12) then
write(12,'(2i6,E20.12)') p,q,onetrf(p,q)
indx+=1
end if
end do
end do
write(6,*) ' wrote ',indx,' mono-electronic integrals'
close(12)
write(6,*)
write(6,*) ' creating new orbitals '
do i=1,mo_num
write(6,*) ' Orbital No ',i
write(6,'(5F14.6)') (NatOrbsFCI(j,i),j=1,mo_num)
write(6,*)
end do
mo_label = "MCSCF"
mo_label = "Natural"
do i=1,mo_num
do j=1,ao_num
mo_coef(j,i)=NatOrbsFCI(j,i)
end do
end do
call save_mos
write(6,*) ' ... done '
end

View File

@ -7,7 +7,7 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
do q=1,mo_num do q=1,mo_num
do p=1,mo_num do p=1,mo_num
Fipq(p,q)=one_ints(p,q) Fipq(p,q)=one_ints_no(p,q)
end do end do
end do end do

View File

@ -158,14 +158,14 @@ END_PROVIDER
BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Transformed one-e integrals ! Transformed one-e integrals
END_DOC END_DOC
integer :: i,j, p, pp, q integer :: i,j, p, pp, q
real*8 :: d(n_act_orb) real*8 :: d(n_act_orb)
onetrf(:,:)=mo_one_e_integrals(:,:) one_ints_no(:,:)=mo_one_e_integrals(:,:)
! 1st half-trf ! 1st half-trf
do j=1,mo_num do j=1,mo_num
@ -175,11 +175,11 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)]
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb do q=1,n_act_orb
d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) d(pp)+=one_ints_no(list_act(q),j)*natorbsCI(q,p)
end do end do
end do end do
do p=1,n_act_orb do p=1,n_act_orb
onetrf(list_act(p),j)=d(p) one_ints_no(list_act(p),j)=d(p)
end do end do
end do end do
@ -191,14 +191,14 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)]
do p=1,n_act_orb do p=1,n_act_orb
pp=n_act_orb-p+1 pp=n_act_orb-p+1
do q=1,n_act_orb do q=1,n_act_orb
d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) d(pp)+=one_ints_no(j,list_act(q))*natorbsCI(q,p)
end do end do
end do end do
do p=1,n_act_orb do p=1,n_act_orb
onetrf(j,list_act(p))=d(p) one_ints_no(j,list_act(p))=d(p)
end do end do
end do end do
write(6,*) ' transformed onetrf ' write(6,*) ' transformed one_ints '
END_PROVIDER END_PROVIDER
@ -271,7 +271,7 @@ subroutine trf_to_natorb()
e_two_all=0.D0 e_two_all=0.D0
do i=1,n_core_orb do i=1,n_core_orb
ii=list_core(i) ii=list_core(i)
e_one_all+=2.D0*onetrf(ii,ii) e_one_all+=2.D0*one_ints_no(ii,ii)
do j=1,n_core_orb do j=1,n_core_orb
jj=list_core(j) jj=list_core(j)
e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i)
@ -288,7 +288,7 @@ subroutine trf_to_natorb()
do t=1,n_act_orb do t=1,n_act_orb
tt=list_act(t) tt=list_act(t)
e_one_all += occnum(list_act(t))*onetrf(tt,tt) e_one_all += occnum(list_act(t))*one_ints_no(tt,tt)
do u=1,n_act_orb do u=1,n_act_orb
uu=list_act(u) uu=list_act(u)
do v=1,n_act_orb do v=1,n_act_orb
@ -306,8 +306,8 @@ subroutine trf_to_natorb()
ecore_bis=nuclear_repulsion ecore_bis=nuclear_repulsion
do i=1,n_core_orb do i=1,n_core_orb
ii=list_core(i) ii=list_core(i)
ecore +=2.D0*onetrf(ii,ii) ecore +=2.D0*one_ints_no(ii,ii)
ecore_bis+=2.D0*onetrf(ii,ii) ecore_bis+=2.D0*one_ints_no(ii,ii)
do j=1,n_core_orb do j=1,n_core_orb
jj=list_core(j) jj=list_core(j)
ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i)
@ -322,8 +322,8 @@ subroutine trf_to_natorb()
do t=1,n_act_orb do t=1,n_act_orb
tt=list_act(t) tt=list_act(t)
t3=t+n_core_orb t3=t+n_core_orb
eone += occnum(list_act(t))*onetrf(tt,tt) eone += occnum(list_act(t))*one_ints_no(tt,tt)
eone_bis += occnum(list_act(t))*onetrf(tt,tt) eone_bis += occnum(list_act(t))*one_ints_no(tt,tt)
do i=1,n_core_orb do i=1,n_core_orb
ii=list_core(i) ii=list_core(i)
eone += occnum(list_act(t)) * & eone += occnum(list_act(t)) * &

View File

@ -1,26 +0,0 @@
! -*- F90 -*-
BEGIN_PROVIDER [real*8, one_ints, (mo_num,mo_num)]
implicit none
integer :: i,j,kk
logical :: lread
real*8 :: rdum
do i=1,mo_num
do j=1,mo_num
one_ints(i,j)=0.D0
end do
end do
open(unit=12,file='onetrf.tmp',status='old',form='formatted')
lread=.true.
do while (lread)
read(12,*,iostat=kk) i,j,rdum
if (kk.ne.0) then
lread=.false.
else
one_ints(i,j)=rdum
one_ints(j,i)=rdum
end if
end do
close(12)
write(6,*) ' read MCSCF natural one-electron integrals '
END_PROVIDER