mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-30 23:25:39 +01:00
All programs merged. Iterations not working
This commit is contained in:
parent
d29f82c080
commit
328ab2dadf
104
src/casscf/bielec.irp.f
Normal file
104
src/casscf/bielec.irp.f
Normal file
@ -0,0 +1,104 @@
|
||||
! -*- F90 -*-
|
||||
BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)]
|
||||
&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)]
|
||||
BEGIN_DOC
|
||||
! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active
|
||||
! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active
|
||||
! indices are unshifted orbital numbers
|
||||
! all integrals are read from files
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,p,q,indx,kk
|
||||
real*8 :: hhh
|
||||
logical :: lread
|
||||
|
||||
do i=1,n_core_orb+n_act_orb
|
||||
do j=1,n_core_orb+n_act_orb
|
||||
do p=1,mo_num
|
||||
do q=1,mo_num
|
||||
bielec_PQxx(p,q,i,j)=0.D0
|
||||
bielec_PxxQ(p,i,j,q)=0.D0
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp')
|
||||
lread=.true.
|
||||
indx=0
|
||||
do while (lread)
|
||||
read(12,*,iostat=kk) p,q,i,j,hhh
|
||||
if (kk.ne.0) then
|
||||
lread=.false.
|
||||
else
|
||||
! stored with p.le.q, i.le.j
|
||||
bielec_PQxx(p,q,i,j)=hhh
|
||||
bielec_PQxx(q,p,i,j)=hhh
|
||||
bielec_PQxx(q,p,j,i)=hhh
|
||||
bielec_PQxx(p,q,j,i)=hhh
|
||||
indx+=1
|
||||
end if
|
||||
end do
|
||||
close(12)
|
||||
write(6,*) ' read ',indx,' integrals PQxx into core '
|
||||
|
||||
open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp')
|
||||
lread=.true.
|
||||
indx=0
|
||||
do while (lread)
|
||||
read(12,*,iostat=kk) p,i,j,q,hhh
|
||||
if (kk.ne.0) then
|
||||
lread=.false.
|
||||
else
|
||||
! stored with (ip).le.(jq)
|
||||
bielec_PxxQ(p,i,j,q)=hhh
|
||||
bielec_PxxQ(q,j,i,p)=hhh
|
||||
indx+=1
|
||||
end if
|
||||
end do
|
||||
write(6,*) ' read ',indx,' integrals PxxQ into core '
|
||||
close(12)
|
||||
write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) '
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER[real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)]
|
||||
BEGIN_DOC
|
||||
! bielecCI : integrals (tu|vp) with p arbitrary, tuv active
|
||||
! index p runs over the whole basis, t,u,v only over the active orbitals
|
||||
! inegrals read from file
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,k,p,t,u,v,kk,indx
|
||||
real*8 :: hhh
|
||||
logical :: lread
|
||||
|
||||
write(6,*) ' reading integrals bielecCI '
|
||||
|
||||
do i=1,n_act_orb
|
||||
do j=1,n_act_orb
|
||||
do k=1,n_act_orb
|
||||
do p=1,mo_num
|
||||
bielecCI(i,k,j,p)=0.D0
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
open(unit=12,form='formatted',status='old',file='bielecCI.tmp')
|
||||
lread=.true.
|
||||
indx=0
|
||||
do while (lread)
|
||||
read(12,*,iostat=kk) i,j,k,p,hhh
|
||||
if (kk.ne.0) then
|
||||
lread=.false.
|
||||
else
|
||||
bielecCI(i,j,k,p)=hhh
|
||||
bielecCI(j,i,k,p)=hhh
|
||||
indx+=1
|
||||
end if
|
||||
end do
|
||||
write(6,*) ' read ',indx,' integrals (aa|aP) into core '
|
||||
close(12)
|
||||
write(6,*) ' provided integrals (tu|xP) '
|
||||
END_PROVIDER
|
||||
|
||||
@ -10,7 +10,20 @@ end
|
||||
|
||||
subroutine run
|
||||
implicit none
|
||||
call run_cipsi
|
||||
call driver_wdens
|
||||
double precision :: energy_old, energy
|
||||
logical :: converged
|
||||
converged = .False.
|
||||
|
||||
energy = 0.d0
|
||||
! do while (.not.converged)
|
||||
N_det = 1
|
||||
TOUCH N_det psi_det psi_coef
|
||||
call run_cipsi
|
||||
call driver_wdens
|
||||
call driver_optorb
|
||||
energy_old = energy
|
||||
energy = eone+etwo+ecore
|
||||
converged = dabs(energy - energy_old) < 1.d-10
|
||||
! enddo
|
||||
|
||||
end
|
||||
|
||||
32
src/casscf/driver_optorb.irp.f
Normal file
32
src/casscf/driver_optorb.irp.f
Normal file
@ -0,0 +1,32 @@
|
||||
subroutine driver_optorb
|
||||
implicit none
|
||||
integer :: i,j
|
||||
|
||||
write(6,*)
|
||||
! write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1)
|
||||
write(6,*) ' energy improvement = ',energy_improvement
|
||||
! write(6,*) ' new energy = ',psi_energy_with_nucl_rep(1)+energy_improvement
|
||||
write(6,*)
|
||||
|
||||
write(6,*)
|
||||
write(6,*) ' creating new orbitals '
|
||||
do i=1,mo_num
|
||||
write(6,*) ' Orbital No ',i
|
||||
write(6,'(5F14.6)') (NewOrbs(j,i),j=1,mo_num)
|
||||
write(6,*)
|
||||
end do
|
||||
|
||||
mo_label = "Natural"
|
||||
do i=1,mo_num
|
||||
do j=1,ao_num
|
||||
mo_coef(j,i)=NewOrbs(j,i)
|
||||
end do
|
||||
end do
|
||||
call save_mos
|
||||
call map_deinit(mo_integrals_map)
|
||||
FREE mo_integrals_map mo_coef mo_two_e_integrals_in_map
|
||||
|
||||
write(6,*)
|
||||
write(6,*) ' ... all done '
|
||||
|
||||
end
|
||||
251
src/casscf/gradient.irp.f
Normal file
251
src/casscf/gradient.irp.f
Normal file
@ -0,0 +1,251 @@
|
||||
! -*- F90 -*-
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
BEGIN_PROVIDER [ integer, nMonoEx ]
|
||||
BEGIN_DOC
|
||||
!
|
||||
END_DOC
|
||||
implicit none
|
||||
nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb
|
||||
write(6,*) ' nMonoEx = ',nMonoEx
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [integer, excit, (2,nMonoEx)]
|
||||
&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! a list of the orbitals involved in the excitation
|
||||
END_DOC
|
||||
|
||||
implicit none
|
||||
integer :: i,t,a,ii,tt,aa,indx
|
||||
indx=0
|
||||
do ii=1,n_core_orb
|
||||
i=list_core(ii)
|
||||
do tt=1,n_act_orb
|
||||
t=list_act(tt)
|
||||
indx+=1
|
||||
excit(1,indx)=i
|
||||
excit(2,indx)=t
|
||||
excit_class(indx)='c-a'
|
||||
end do
|
||||
end do
|
||||
|
||||
do ii=1,n_core_orb
|
||||
i=list_core(ii)
|
||||
do aa=1,n_virt_orb
|
||||
a=list_virt(aa)
|
||||
indx+=1
|
||||
excit(1,indx)=i
|
||||
excit(2,indx)=a
|
||||
excit_class(indx)='c-v'
|
||||
end do
|
||||
end do
|
||||
|
||||
do tt=1,n_act_orb
|
||||
t=list_act(tt)
|
||||
do aa=1,n_virt_orb
|
||||
a=list_virt(aa)
|
||||
indx+=1
|
||||
excit(1,indx)=t
|
||||
excit(2,indx)=a
|
||||
excit_class(indx)='a-v'
|
||||
end do
|
||||
end do
|
||||
|
||||
if (bavard) then
|
||||
write(6,*) ' Filled the table of the Monoexcitations '
|
||||
do indx=1,nMonoEx
|
||||
write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' &
|
||||
,excit(2,indx),' ',excit_class(indx)
|
||||
end do
|
||||
end if
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! calculate the orbital gradient <Psi| H E_pq |Psi> by hand, i.e. for
|
||||
! each determinant I we determine the string E_pq |I> (alpha and beta
|
||||
! separately) and generate <Psi|H E_pq |I>
|
||||
! sum_I c_I <Psi|H E_pq |I> is then the pq component of the orbital
|
||||
! gradient
|
||||
! E_pq = a^+_pa_q + a^+_Pa_Q
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: ii,tt,aa,indx,ihole,ipart,istate
|
||||
real*8 :: res
|
||||
|
||||
do indx=1,nMonoEx
|
||||
ihole=excit(1,indx)
|
||||
ipart=excit(2,indx)
|
||||
call calc_grad_elem(ihole,ipart,res)
|
||||
gradvec(indx)=res
|
||||
end do
|
||||
|
||||
real*8 :: norm_grad
|
||||
norm_grad=0.d0
|
||||
do indx=1,nMonoEx
|
||||
norm_grad+=gradvec(indx)*gradvec(indx)
|
||||
end do
|
||||
norm_grad=sqrt(norm_grad)
|
||||
write(6,*)
|
||||
write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad
|
||||
write(6,*)
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine calc_grad_elem(ihole,ipart,res)
|
||||
BEGIN_DOC
|
||||
! eq 18 of Siegbahn et al, Physica Scripta 1980
|
||||
! we calculate 2 <Psi| H E_pq | Psi>, q=hole, p=particle
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate
|
||||
real*8 :: res
|
||||
integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:)
|
||||
real*8 :: i_H_psi_array(N_states),phase
|
||||
allocate(det_mu(N_int,2))
|
||||
allocate(det_mu_ex(N_int,2))
|
||||
|
||||
res=0.D0
|
||||
|
||||
do mu=1,n_det
|
||||
! get the string of the determinant
|
||||
call det_extract(det_mu,mu,N_int)
|
||||
do ispin=1,2
|
||||
! do the monoexcitation on it
|
||||
call det_copy(det_mu,det_mu_ex,N_int)
|
||||
call do_signed_mono_excitation(det_mu,det_mu_ex,nu &
|
||||
,ihole,ipart,ispin,phase,ierr)
|
||||
if (ierr.eq.1) then
|
||||
! write(6,*)
|
||||
! write(6,*) ' mu = ',mu
|
||||
! call print_det(det_mu,N_int)
|
||||
! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin
|
||||
! call print_det(det_mu_ex,N_int)
|
||||
call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int &
|
||||
,N_det,N_det,N_states,i_H_psi_array)
|
||||
do istate=1,N_states
|
||||
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase
|
||||
end do
|
||||
! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
! state-averaged gradient
|
||||
res*=2.D0/dble(N_states)
|
||||
|
||||
end subroutine calc_grad_elem
|
||||
|
||||
BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! calculate the orbital gradient <Psi| H E_pq |Psi> from density
|
||||
! matrices and integrals; Siegbahn et al, Phys Scr 1980
|
||||
! eqs 14 a,b,c
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t,a,indx
|
||||
real*8 :: gradvec_it,gradvec_ia,gradvec_ta
|
||||
real*8 :: norm_grad
|
||||
|
||||
indx=0
|
||||
do i=1,n_core_orb
|
||||
do t=1,n_act_orb
|
||||
indx+=1
|
||||
gradvec2(indx)=gradvec_it(i,t)
|
||||
end do
|
||||
end do
|
||||
|
||||
do i=1,n_core_orb
|
||||
do a=1,n_virt_orb
|
||||
indx+=1
|
||||
gradvec2(indx)=gradvec_ia(i,a)
|
||||
end do
|
||||
end do
|
||||
|
||||
do t=1,n_act_orb
|
||||
do a=1,n_virt_orb
|
||||
indx+=1
|
||||
gradvec2(indx)=gradvec_ta(t,a)
|
||||
end do
|
||||
end do
|
||||
|
||||
norm_grad=0.d0
|
||||
do indx=1,nMonoEx
|
||||
norm_grad+=gradvec2(indx)*gradvec2(indx)
|
||||
end do
|
||||
norm_grad=sqrt(norm_grad)
|
||||
write(6,*)
|
||||
write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad
|
||||
write(6,*)
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
real*8 function gradvec_it(i,t)
|
||||
BEGIN_DOC
|
||||
! the orbital gradient core -> active
|
||||
! we assume natural orbitals
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t
|
||||
|
||||
integer :: ii,tt,v,vv,x,y
|
||||
integer :: x3,y3
|
||||
|
||||
ii=list_core(i)
|
||||
tt=list_act(t)
|
||||
gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii))
|
||||
gradvec_it-=occnum(tt)*Fipq(ii,tt)
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
do x=1,n_act_orb
|
||||
x3=x+n_core_orb
|
||||
do y=1,n_act_orb
|
||||
y3=y+n_core_orb
|
||||
gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx(ii,vv,x3,y3)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
gradvec_it*=2.D0
|
||||
end function gradvec_it
|
||||
|
||||
real*8 function gradvec_ia(i,a)
|
||||
BEGIN_DOC
|
||||
! the orbital gradient core -> virtual
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,a,ii,aa
|
||||
|
||||
ii=list_core(i)
|
||||
aa=list_virt(a)
|
||||
gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii))
|
||||
gradvec_ia*=2.D0
|
||||
|
||||
end function gradvec_ia
|
||||
|
||||
real*8 function gradvec_ta(t,a)
|
||||
BEGIN_DOC
|
||||
! the orbital gradient active -> virtual
|
||||
! we assume natural orbitals
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: t,a,tt,aa,v,vv,x,y
|
||||
|
||||
tt=list_act(t)
|
||||
aa=list_virt(a)
|
||||
gradvec_ta=0.D0
|
||||
gradvec_ta+=occnum(tt)*Fipq(aa,tt)
|
||||
do v=1,n_act_orb
|
||||
do x=1,n_act_orb
|
||||
do y=1,n_act_orb
|
||||
gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
gradvec_ta*=2.D0
|
||||
|
||||
end function gradvec_ta
|
||||
|
||||
639
src/casscf/hessian.irp.f
Normal file
639
src/casscf/hessian.irp.f
Normal file
@ -0,0 +1,639 @@
|
||||
! -*- F90 -*-
|
||||
|
||||
use bitmasks ! you need to include the bitmasks_module.f90 features
|
||||
|
||||
BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! calculate the orbital hessian 2 <Psi| E_pq H E_rs |Psi>
|
||||
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi> by hand,
|
||||
! determinant per determinant, as for the gradient
|
||||
!
|
||||
! we assume that we have natural active orbitals
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: indx,ihole,ipart
|
||||
integer :: jndx,jhole,jpart
|
||||
character*3 :: iexc,jexc
|
||||
real*8 :: res
|
||||
|
||||
write(6,*) ' providing Hessian matrix hessmat '
|
||||
write(6,*) ' nMonoEx = ',nMonoEx
|
||||
|
||||
do indx=1,nMonoEx
|
||||
do jndx=1,nMonoEx
|
||||
hessmat(indx,jndx)=0.D0
|
||||
end do
|
||||
end do
|
||||
|
||||
do indx=1,nMonoEx
|
||||
ihole=excit(1,indx)
|
||||
ipart=excit(2,indx)
|
||||
iexc=excit_class(indx)
|
||||
do jndx=indx,nMonoEx
|
||||
jhole=excit(1,jndx)
|
||||
jpart=excit(2,jndx)
|
||||
jexc=excit_class(jndx)
|
||||
call calc_hess_elem(ihole,ipart,jhole,jpart,res)
|
||||
! write(6,*) ' Hessian ',ihole,'->',ipart &
|
||||
! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res
|
||||
hessmat(indx,jndx)=res
|
||||
hessmat(jndx,indx)=res
|
||||
end do
|
||||
end do
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res)
|
||||
BEGIN_DOC
|
||||
! eq 19 of Siegbahn et al, Physica Scripta 1980
|
||||
! we calculate 2 <Psi| E_pq H E_rs |Psi>
|
||||
! + <Psi| E_pq E_rs H |Psi> + <Psi| E_rs E_pq H |Psi>
|
||||
! average over all states is performed.
|
||||
! no transition between states.
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: ihole,ipart,ispin,mu,istate
|
||||
integer :: jhole,jpart,jspin
|
||||
integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu
|
||||
real*8 :: res
|
||||
integer(bit_kind), allocatable :: det_mu(:,:)
|
||||
integer(bit_kind), allocatable :: det_nu(:,:)
|
||||
integer(bit_kind), allocatable :: det_mu_pq(:,:)
|
||||
integer(bit_kind), allocatable :: det_mu_rs(:,:)
|
||||
integer(bit_kind), allocatable :: det_nu_rs(:,:)
|
||||
integer(bit_kind), allocatable :: det_mu_pqrs(:,:)
|
||||
integer(bit_kind), allocatable :: det_mu_rspq(:,:)
|
||||
real*8 :: i_H_psi_array(N_states),phase,phase2,phase3
|
||||
real*8 :: i_H_j_element
|
||||
allocate(det_mu(N_int,2))
|
||||
allocate(det_nu(N_int,2))
|
||||
allocate(det_mu_pq(N_int,2))
|
||||
allocate(det_mu_rs(N_int,2))
|
||||
allocate(det_nu_rs(N_int,2))
|
||||
allocate(det_mu_pqrs(N_int,2))
|
||||
allocate(det_mu_rspq(N_int,2))
|
||||
integer :: mu_pq_possible
|
||||
integer :: mu_rs_possible
|
||||
integer :: nu_rs_possible
|
||||
integer :: mu_pqrs_possible
|
||||
integer :: mu_rspq_possible
|
||||
|
||||
res=0.D0
|
||||
|
||||
! the terms <0|E E H |0>
|
||||
do mu=1,n_det
|
||||
! get the string of the determinant
|
||||
call det_extract(det_mu,mu,N_int)
|
||||
do ispin=1,2
|
||||
! do the monoexcitation pq on it
|
||||
call det_copy(det_mu,det_mu_pq,N_int)
|
||||
call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq &
|
||||
,ihole,ipart,ispin,phase,mu_pq_possible)
|
||||
if (mu_pq_possible.eq.1) then
|
||||
! possible, but not necessarily in the list
|
||||
! do the second excitation
|
||||
do jspin=1,2
|
||||
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
|
||||
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs &
|
||||
,jhole,jpart,jspin,phase2,mu_pqrs_possible)
|
||||
! excitation possible
|
||||
if (mu_pqrs_possible.eq.1) then
|
||||
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
|
||||
,N_det,N_det,N_states,i_H_psi_array)
|
||||
do istate=1,N_states
|
||||
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
|
||||
end do
|
||||
end if
|
||||
! try the de-excitation with opposite sign
|
||||
call det_copy(det_mu_pq,det_mu_pqrs,N_int)
|
||||
call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs &
|
||||
,jpart,jhole,jspin,phase2,mu_pqrs_possible)
|
||||
phase2=-phase2
|
||||
! excitation possible
|
||||
if (mu_pqrs_possible.eq.1) then
|
||||
call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int &
|
||||
,N_det,N_det,N_states,i_H_psi_array)
|
||||
do istate=1,N_states
|
||||
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
! exchange the notion of pq and rs
|
||||
! do the monoexcitation rs on the initial determinant
|
||||
call det_copy(det_mu,det_mu_rs,N_int)
|
||||
call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs &
|
||||
,jhole,jpart,ispin,phase2,mu_rs_possible)
|
||||
if (mu_rs_possible.eq.1) then
|
||||
! do the second excitation
|
||||
do jspin=1,2
|
||||
call det_copy(det_mu_rs,det_mu_rspq,N_int)
|
||||
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq &
|
||||
,ihole,ipart,jspin,phase3,mu_rspq_possible)
|
||||
! excitation possible (of course, the result is outside the CAS)
|
||||
if (mu_rspq_possible.eq.1) then
|
||||
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
|
||||
,N_det,N_det,N_states,i_H_psi_array)
|
||||
do istate=1,N_states
|
||||
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
|
||||
end do
|
||||
end if
|
||||
! we may try the de-excitation, with opposite sign
|
||||
call det_copy(det_mu_rs,det_mu_rspq,N_int)
|
||||
call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq &
|
||||
,ipart,ihole,jspin,phase3,mu_rspq_possible)
|
||||
phase3=-phase3
|
||||
! excitation possible (of course, the result is outside the CAS)
|
||||
if (mu_rspq_possible.eq.1) then
|
||||
call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int &
|
||||
,N_det,N_det,N_states,i_H_psi_array)
|
||||
do istate=1,N_states
|
||||
res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
!
|
||||
! the operator E H E, we have to do a double loop over the determinants
|
||||
! we still have the determinant mu_pq and the phase in memory
|
||||
if (mu_pq_possible.eq.1) then
|
||||
do nu=1,N_det
|
||||
call det_extract(det_nu,nu,N_int)
|
||||
do jspin=1,2
|
||||
call det_copy(det_nu,det_nu_rs,N_int)
|
||||
call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs &
|
||||
,jhole,jpart,jspin,phase2,nu_rs_possible)
|
||||
! excitation possible ?
|
||||
if (nu_rs_possible.eq.1) then
|
||||
call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element)
|
||||
do istate=1,N_states
|
||||
res+=2.D0*i_H_j_element*psi_coef(mu,istate) &
|
||||
*psi_coef(nu,istate)*phase*phase2
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
! state-averaged Hessian
|
||||
res*=1.D0/dble(N_states)
|
||||
|
||||
end subroutine calc_hess_elem
|
||||
|
||||
BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! explicit hessian matrix from density matrices and integrals
|
||||
! of course, this will be used for a direct Davidson procedure later
|
||||
! we will not store the matrix in real life
|
||||
! formulas are broken down as functions for the 6 classes of matrix elements
|
||||
!
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart
|
||||
|
||||
real*8 :: hessmat_itju
|
||||
real*8 :: hessmat_itja
|
||||
real*8 :: hessmat_itua
|
||||
real*8 :: hessmat_iajb
|
||||
real*8 :: hessmat_iatb
|
||||
real*8 :: hessmat_taub
|
||||
|
||||
write(6,*) ' providing Hessian matrix hessmat2 '
|
||||
write(6,*) ' nMonoEx = ',nMonoEx
|
||||
|
||||
indx=1
|
||||
do i=1,n_core_orb
|
||||
do t=1,n_act_orb
|
||||
jndx=indx
|
||||
do j=i,n_core_orb
|
||||
if (i.eq.j) then
|
||||
ustart=t
|
||||
else
|
||||
ustart=1
|
||||
end if
|
||||
do u=ustart,n_act_orb
|
||||
hessmat2(indx,jndx)=hessmat_itju(i,t,j,u)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
do j=1,n_core_orb
|
||||
do a=1,n_virt_orb
|
||||
hessmat2(indx,jndx)=hessmat_itja(i,t,j,a)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
do u=1,n_act_orb
|
||||
do a=1,n_virt_orb
|
||||
hessmat2(indx,jndx)=hessmat_itua(i,t,u,a)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
indx+=1
|
||||
end do
|
||||
end do
|
||||
|
||||
do i=1,n_core_orb
|
||||
do a=1,n_virt_orb
|
||||
jndx=indx
|
||||
do j=i,n_core_orb
|
||||
if (i.eq.j) then
|
||||
bstart=a
|
||||
else
|
||||
bstart=1
|
||||
end if
|
||||
do b=bstart,n_virt_orb
|
||||
hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
do t=1,n_act_orb
|
||||
do b=1,n_virt_orb
|
||||
hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
indx+=1
|
||||
end do
|
||||
end do
|
||||
|
||||
do t=1,n_act_orb
|
||||
do a=1,n_virt_orb
|
||||
jndx=indx
|
||||
do u=t,n_act_orb
|
||||
if (t.eq.u) then
|
||||
bstart=a
|
||||
else
|
||||
bstart=1
|
||||
end if
|
||||
do b=bstart,n_virt_orb
|
||||
hessmat2(indx,jndx)=hessmat_taub(t,a,u,b)
|
||||
hessmat2(jndx,indx)=hessmat2(indx,jndx)
|
||||
jndx+=1
|
||||
end do
|
||||
end do
|
||||
indx+=1
|
||||
end do
|
||||
end do
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
real*8 function hessmat_itju(i,t,j,u)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for core->act,core->act
|
||||
! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu
|
||||
!
|
||||
! we assume natural orbitals
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj
|
||||
real*8 :: term,t2
|
||||
|
||||
! write(6,*) ' hessmat_itju ',i,t,j,u
|
||||
ii=list_core(i)
|
||||
tt=list_act(t)
|
||||
if (i.eq.j) then
|
||||
if (t.eq.u) then
|
||||
! diagonal element
|
||||
term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) &
|
||||
-2.D0*(Fipq(ii,ii)+Fapq(ii,ii))
|
||||
term+=2.D0*(3.D0*bielec_pxxq(tt,i,i,tt)-bielec_pqxx(tt,tt,i,i))
|
||||
term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq(tt,i,i,tt) &
|
||||
-bielec_pqxx(tt,tt,i,i))
|
||||
term-=occnum(tt)*Fipq(tt,tt)
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(vv,xx,i,i) &
|
||||
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
|
||||
bielec_pxxq(vv,i,i,xx))
|
||||
do y=1,n_act_orb
|
||||
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
else
|
||||
! it/iu, t != u
|
||||
uu=list_act(u)
|
||||
term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu))
|
||||
term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) &
|
||||
-bielec_PQxx(tt,uu,i,j))
|
||||
term-=occnum(tt)*Fipq(uu,tt)
|
||||
term-=(occnum(tt)+occnum(uu)) &
|
||||
*(3.D0*bielec_PxxQ(tt,i,i,uu)-bielec_PQxx(uu,tt,i,i))
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,i) &
|
||||
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
|
||||
*bielec_pxxq(vv,i,i,xx))
|
||||
do y=1,n_act_orb
|
||||
term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(u,v,y,xx)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
!!! write(6,*) ' direct diff ',i,t,j,u,term,term2
|
||||
!!! term=term2
|
||||
end if
|
||||
else
|
||||
! it/ju
|
||||
jj=list_core(j)
|
||||
uu=list_act(u)
|
||||
if (t.eq.u) then
|
||||
term=occnum(tt)*Fipq(ii,jj)
|
||||
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
|
||||
else
|
||||
term=0.D0
|
||||
end if
|
||||
term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) &
|
||||
-bielec_PQxx(tt,uu,i,j))
|
||||
term-=(occnum(tt)+occnum(uu))* &
|
||||
(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) &
|
||||
-bielec_PQxx(uu,tt,i,j))
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,j) &
|
||||
+(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) &
|
||||
*bielec_pxxq(vv,i,j,xx))
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
|
||||
term*=2.D0
|
||||
hessmat_itju=term
|
||||
|
||||
end function hessmat_itju
|
||||
|
||||
real*8 function hessmat_itja(i,t,j,a)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for core->act,core->virt
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y
|
||||
real*8 :: term
|
||||
|
||||
! write(6,*) ' hessmat_itja ',i,t,j,a
|
||||
! it/ja
|
||||
ii=list_core(i)
|
||||
tt=list_act(t)
|
||||
jj=list_core(j)
|
||||
aa=list_virt(a)
|
||||
term=2.D0*(4.D0*bielec_pxxq(aa,j,i,tt) &
|
||||
-bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt))
|
||||
term-=occnum(tt)*(4.D0*bielec_pxxq(aa,j,i,tt) &
|
||||
-bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt))
|
||||
if (i.eq.j) then
|
||||
term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt))
|
||||
term-=0.5D0*occnum(tt)*Fipq(aa,tt)
|
||||
do v=1,n_act_orb
|
||||
do x=1,n_act_orb
|
||||
do y=1,n_act_orb
|
||||
term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
term*=2.D0
|
||||
hessmat_itja=term
|
||||
|
||||
end function hessmat_itja
|
||||
|
||||
real*8 function hessmat_itua(i,t,u,a)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for core->act,act->virt
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3
|
||||
real*8 :: term
|
||||
|
||||
! write(6,*) ' hessmat_itua ',i,t,u,a
|
||||
ii=list_core(i)
|
||||
tt=list_act(t)
|
||||
t3=t+n_core_orb
|
||||
uu=list_act(u)
|
||||
u3=u+n_core_orb
|
||||
aa=list_virt(a)
|
||||
if (t.eq.u) then
|
||||
term=-occnum(tt)*Fipq(aa,ii)
|
||||
else
|
||||
term=0.D0
|
||||
end if
|
||||
term-=occnum(uu)*(bielec_pqxx(aa,ii,t3,u3)-4.D0*bielec_pqxx(aa,uu,t3,i) &
|
||||
+bielec_pxxq(aa,t3,u3,ii))
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
v3=v+n_core_orb
|
||||
do x=1,n_act_orb
|
||||
integer :: x3
|
||||
xx=list_act(x)
|
||||
x3=x+n_core_orb
|
||||
term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,ii,v3,x3) &
|
||||
+(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) &
|
||||
*bielec_pqxx(aa,xx,v3,i))
|
||||
end do
|
||||
end do
|
||||
if (t.eq.u) then
|
||||
term+=Fipq(aa,ii)+Fapq(aa,ii)
|
||||
end if
|
||||
term*=2.D0
|
||||
hessmat_itua=term
|
||||
|
||||
end function hessmat_itua
|
||||
|
||||
real*8 function hessmat_iajb(i,a,j,b)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for core->virt,core->virt
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,a,j,b,ii,aa,jj,bb
|
||||
real*8 :: term
|
||||
! write(6,*) ' hessmat_iajb ',i,a,j,b
|
||||
|
||||
ii=list_core(i)
|
||||
aa=list_virt(a)
|
||||
if (i.eq.j) then
|
||||
if (a.eq.b) then
|
||||
! ia/ia
|
||||
term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii))
|
||||
term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,aa)-bielec_pqxx(aa,aa,i,i))
|
||||
else
|
||||
bb=list_virt(b)
|
||||
! ia/ib
|
||||
term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb))
|
||||
term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,bb)-bielec_pqxx(aa,bb,i,i))
|
||||
end if
|
||||
else
|
||||
! ia/jb
|
||||
jj=list_core(j)
|
||||
bb=list_virt(b)
|
||||
term=2.D0*(4.D0*bielec_pxxq(aa,i,j,bb)-bielec_pqxx(aa,bb,i,j) &
|
||||
-bielec_pxxq(aa,j,i,bb))
|
||||
if (a.eq.b) then
|
||||
term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj))
|
||||
end if
|
||||
end if
|
||||
term*=2.D0
|
||||
hessmat_iajb=term
|
||||
|
||||
end function hessmat_iajb
|
||||
|
||||
real*8 function hessmat_iatb(i,a,t,b)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for core->virt,act->virt
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3
|
||||
real*8 :: term
|
||||
|
||||
! write(6,*) ' hessmat_iatb ',i,a,t,b
|
||||
ii=list_core(i)
|
||||
aa=list_virt(a)
|
||||
tt=list_act(t)
|
||||
bb=list_virt(b)
|
||||
t3=t+n_core_orb
|
||||
term=occnum(tt)*(4.D0*bielec_pxxq(aa,i,t3,bb)-bielec_pxxq(aa,t3,i,bb) &
|
||||
-bielec_pqxx(aa,bb,i,t3))
|
||||
if (a.eq.b) then
|
||||
term-=Fipq(tt,ii)+Fapq(tt,ii)
|
||||
term-=0.5D0*occnum(tt)*Fipq(tt,ii)
|
||||
do v=1,n_act_orb
|
||||
do x=1,n_act_orb
|
||||
do y=1,n_act_orb
|
||||
term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,ii)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
term*=2.D0
|
||||
hessmat_iatb=term
|
||||
|
||||
end function hessmat_iatb
|
||||
|
||||
real*8 function hessmat_taub(t,a,u,b)
|
||||
BEGIN_DOC
|
||||
! the orbital hessian for act->virt,act->virt
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y
|
||||
integer :: v3,x3
|
||||
real*8 :: term,t1,t2,t3
|
||||
|
||||
tt=list_act(t)
|
||||
aa=list_virt(a)
|
||||
if (t.eq.u) then
|
||||
if (a.eq.b) then
|
||||
! ta/ta
|
||||
t1=occnum(tt)*Fipq(aa,aa)
|
||||
t2=0.D0
|
||||
t3=0.D0
|
||||
t1-=occnum(tt)*Fipq(tt,tt)
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
v3=v+n_core_orb
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
x3=x+n_core_orb
|
||||
t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,aa,v3,x3) &
|
||||
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* &
|
||||
bielec_pxxq(aa,x3,v3,aa))
|
||||
do y=1,n_act_orb
|
||||
t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
term=t1+t2+t3
|
||||
! write(6,*) ' Hess taub ',t,a,t1,t2,t3
|
||||
else
|
||||
bb=list_virt(b)
|
||||
! ta/tb b/=a
|
||||
term=occnum(tt)*Fipq(aa,bb)
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
v3=v+n_core_orb
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
x3=x+n_core_orb
|
||||
term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,bb,v3,x3) &
|
||||
+(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) &
|
||||
*bielec_pxxq(aa,x3,v3,bb))
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
else
|
||||
! ta/ub t/=u
|
||||
uu=list_act(u)
|
||||
bb=list_virt(b)
|
||||
term=0.D0
|
||||
do v=1,n_act_orb
|
||||
vv=list_act(v)
|
||||
v3=v+n_core_orb
|
||||
do x=1,n_act_orb
|
||||
xx=list_act(x)
|
||||
x3=x+n_core_orb
|
||||
term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,bb,v3,x3) &
|
||||
+(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) &
|
||||
*bielec_pxxq(aa,x3,v3,bb))
|
||||
end do
|
||||
end do
|
||||
if (a.eq.b) then
|
||||
term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu))
|
||||
do v=1,n_act_orb
|
||||
do x=1,n_act_orb
|
||||
do y=1,n_act_orb
|
||||
term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,uu)
|
||||
term-=P0tuvx_no(u,v,x,y)*bielecCI(x,y,v,tt)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
term*=2.D0
|
||||
hessmat_taub=term
|
||||
|
||||
end function hessmat_taub
|
||||
|
||||
BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)]
|
||||
BEGIN_DOC
|
||||
! the diagonal of the Hessian, needed for the Davidson procedure
|
||||
END_DOC
|
||||
implicit none
|
||||
integer :: i,t,a,indx
|
||||
real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub
|
||||
|
||||
indx=0
|
||||
do i=1,n_core_orb
|
||||
do t=1,n_act_orb
|
||||
indx+=1
|
||||
hessdiag(indx)=hessmat_itju(i,t,i,t)
|
||||
end do
|
||||
end do
|
||||
|
||||
do i=1,n_core_orb
|
||||
do a=1,n_virt_orb
|
||||
indx+=1
|
||||
hessdiag(indx)=hessmat_iajb(i,a,i,a)
|
||||
end do
|
||||
end do
|
||||
|
||||
do t=1,n_act_orb
|
||||
do a=1,n_virt_orb
|
||||
indx+=1
|
||||
hessdiag(indx)=hessmat_taub(t,a,t,a)
|
||||
end do
|
||||
end do
|
||||
|
||||
END_PROVIDER
|
||||
67
src/casscf/mcscf_fock.irp.f
Normal file
67
src/casscf/mcscf_fock.irp.f
Normal file
@ -0,0 +1,67 @@
|
||||
! -*- F90 -*-
|
||||
BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ]
|
||||
BEGIN_DOC
|
||||
! the inactive and the active Fock matrices, in molecular
|
||||
! orbitals
|
||||
! we create them in MOs, quite expensive
|
||||
!
|
||||
! for an implementation in AOs we need first the natural orbitals
|
||||
! for forming an active density matrix in AOs
|
||||
!
|
||||
END_DOC
|
||||
implicit none
|
||||
double precision, allocatable :: integrals_array1(:,:)
|
||||
double precision, allocatable :: integrals_array2(:,:)
|
||||
integer :: p,q,k,kk,t,tt,u,uu
|
||||
allocate(integrals_array1(mo_num,mo_num))
|
||||
allocate(integrals_array2(mo_num,mo_num))
|
||||
|
||||
do p=1,mo_num
|
||||
do q=1,mo_num
|
||||
Fipq(p,q)=one_ints(p,q)
|
||||
Fapq(p,q)=0.D0
|
||||
end do
|
||||
end do
|
||||
|
||||
! the inactive Fock matrix
|
||||
do k=1,n_core_orb
|
||||
kk=list_core(k)
|
||||
do p=1,mo_num
|
||||
do q=1,mo_num
|
||||
Fipq(p,q)+=2.D0*bielec_pqxx(p,q,k,k) -bielec_pxxq(p,k,k,q)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
! the active Fock matrix, D0tu is diagonal
|
||||
do t=1,n_act_orb
|
||||
tt=list_act(t)
|
||||
do p=1,mo_num
|
||||
do q=1,mo_num
|
||||
Fapq(p,q)+=occnum(tt) &
|
||||
*(bielec_pqxx(p,q,tt,tt)-0.5D0*bielec_pxxq(p,tt,tt,q))
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
if (bavard) then
|
||||
integer :: i
|
||||
write(6,*)
|
||||
write(6,*) ' the effective Fock matrix over MOs'
|
||||
write(6,*)
|
||||
|
||||
write(6,*)
|
||||
write(6,*) ' the diagonal of the inactive effective Fock matrix '
|
||||
write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num)
|
||||
write(6,*)
|
||||
write(6,*)
|
||||
write(6,*) ' the diagonal of the active Fock matrix '
|
||||
write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num)
|
||||
write(6,*)
|
||||
end if
|
||||
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
65
src/casscf/natorb_casscf.irp.f
Normal file
65
src/casscf/natorb_casscf.irp.f
Normal file
@ -0,0 +1,65 @@
|
||||
! -*- F90 -*-
|
||||
BEGIN_PROVIDER [real*8, occnum, (mo_num)]
|
||||
implicit none
|
||||
integer :: i,kk,j
|
||||
logical :: lread
|
||||
real*8 :: rdum
|
||||
do i=1,mo_num
|
||||
occnum(i)=0.D0
|
||||
end do
|
||||
do i=1,n_core_orb
|
||||
occnum(list_core(i))=2.D0
|
||||
end do
|
||||
|
||||
open(unit=12,file='D0tu.dat',form='formatted',status='old')
|
||||
lread=.true.
|
||||
do while (lread)
|
||||
read(12,*,iostat=kk) i,j,rdum
|
||||
if (kk.ne.0) then
|
||||
lread=.false.
|
||||
else
|
||||
if (i.eq.j) then
|
||||
occnum(list_act(i))=rdum
|
||||
else
|
||||
write(6,*) ' WARNING - no natural orbitals !'
|
||||
write(6,*) i,j,rdum
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
close(12)
|
||||
write(6,*) ' read occupation numbers '
|
||||
do i=1,mo_num
|
||||
write(6,*) i,occnum(i)
|
||||
end do
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)]
|
||||
implicit none
|
||||
integer :: i,j,k,l,kk
|
||||
real*8 :: rdum
|
||||
logical :: lread
|
||||
|
||||
do i=1,n_act_orb
|
||||
do j=1,n_act_orb
|
||||
do k=1,n_act_orb
|
||||
do l=1,n_act_orb
|
||||
P0tuvx_no(l,k,j,i)=0.D0
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
open(unit=12,file='P0tuvx.dat',form='formatted',status='old')
|
||||
lread=.true.
|
||||
do while (lread)
|
||||
read(12,*,iostat=kk) i,j,k,l,rdum
|
||||
if (kk.ne.0) then
|
||||
lread=.false.
|
||||
else
|
||||
P0tuvx_no(i,j,k,l)=rdum
|
||||
end if
|
||||
end do
|
||||
close(12)
|
||||
write(6,*) ' read the 2-particle density matrix '
|
||||
END_PROVIDER
|
||||
222
src/casscf/neworbs.irp.f
Normal file
222
src/casscf/neworbs.irp.f
Normal file
@ -0,0 +1,222 @@
|
||||
! -*- F90 -*-
|
||||
BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)]
|
||||
implicit none
|
||||
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+1
|
||||
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)]
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)]
|
||||
&BEGIN_PROVIDER [real*8, energy_improvement]
|
||||
implicit none
|
||||
integer :: ierr,matz,i
|
||||
real*8 :: c0
|
||||
|
||||
call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1)
|
||||
write(6,*) ' SXdiag : lowest 5 eigenvalues '
|
||||
write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1)
|
||||
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)
|
||||
write(6,*)
|
||||
write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1)
|
||||
energy_improvement = SXeigenval(1)
|
||||
|
||||
integer :: best_vector
|
||||
real*8 :: best_overlap
|
||||
best_overlap=0.D0
|
||||
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
|
||||
|
||||
write(6,*) ' SXdiag : eigenvalue for best overlap with '
|
||||
write(6,*) ' previous orbitals = ',SXeigenval(best_vector)
|
||||
energy_improvement = SXeigenval(best_vector)
|
||||
|
||||
c0=SXeigenvec(1,best_vector)
|
||||
write(6,*) ' weight of the 1st element ',c0
|
||||
do i=1,nMonoEx+1
|
||||
SXvector(i)=SXeigenvec(i,best_vector)/c0
|
||||
! write(6,*) ' component No ',i,' : ',SXvector(i)
|
||||
end do
|
||||
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ]
|
||||
implicit none
|
||||
integer :: i,j,ialph
|
||||
|
||||
! form the exponential of the Orbital rotations
|
||||
call get_orbrotmat
|
||||
! form the new orbitals
|
||||
do i=1,ao_num
|
||||
do j=1,mo_num
|
||||
NewOrbs(i,j)=0.D0
|
||||
end do
|
||||
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
|
||||
|
||||
BEGIN_PROVIDER [real*8, Tpotmat, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ]
|
||||
&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ]
|
||||
&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ]
|
||||
END_PROVIDER
|
||||
|
||||
subroutine get_orbrotmat
|
||||
implicit none
|
||||
integer :: i,j,indx,k,iter,t,a,ii,tt,aa
|
||||
real*8 :: sum
|
||||
logical :: converged
|
||||
|
||||
|
||||
! the orbital rotation matrix T
|
||||
do i=1,mo_num
|
||||
do j=1,mo_num
|
||||
Tmat(i,j)=0.D0
|
||||
Umat(i,j)=0.D0
|
||||
Tpotmat(i,j)=0.D0
|
||||
end do
|
||||
Tpotmat(i,i)=1.D0
|
||||
end do
|
||||
|
||||
indx=1
|
||||
do i=1,n_core_orb
|
||||
ii=list_core(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_orb
|
||||
ii=list_core(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
|
||||
|
||||
write(6,*) ' the T matrix '
|
||||
do indx=1,nMonoEx
|
||||
i=excit(1,indx)
|
||||
j=excit(2,indx)
|
||||
! if (abs(Tmat(i,j)).gt.1.D0) then
|
||||
! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' &
|
||||
! , sign(1.D0,Tmat(i,j))
|
||||
! Tmat(i,j)=sign(1.D0,Tmat(i,j))
|
||||
! Tmat(j,i)=-Tmat(i,j)
|
||||
! end if
|
||||
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)
|
||||
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
|
||||
|
||||
|
||||
26
src/casscf/one_ints.irp.f
Normal file
26
src/casscf/one_ints.irp.f
Normal file
@ -0,0 +1,26 @@
|
||||
! -*- 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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user