mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 12:10:50 +01:00
2294 lines
79 KiB
Fortran
Executable File
2294 lines
79 KiB
Fortran
Executable File
************************************************************************
|
|
subroutine iabcread(nw,ind2,iabc,w,nocc,nvirt,irecln,ibufln)
|
|
************************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer irecln, ibufln
|
|
integer nw,ind2,nrec,c,p
|
|
real*8 iabc(nocc*nvirt**2,nw),w(ibufln)
|
|
open(722,file='iabc',status='unknown',access='direct',
|
|
$recl=irecln)
|
|
nrec=(nocc*nvirt**2-modulo(nocc*nvirt**2,ibufln))/ibufln+1
|
|
do c=1,nw
|
|
do p=1,nrec-1
|
|
read(722,rec=p+(c+ind2-2)*nrec)iabc((p-1)*ibufln+1:p*ibufln,c)
|
|
c write(6,'(2i4)')p,c
|
|
enddo
|
|
read(722,rec=(c+ind2-1)*nrec)w(1:ibufln)
|
|
call dcopy(modulo(nocc*nvirt**2,ibufln),w,1,
|
|
$iabc((nrec-1)*ibufln+1,c),1)
|
|
enddo
|
|
|
|
close(722)
|
|
return
|
|
end subroutine
|
|
************************************************************************
|
|
subroutine iabcwrite(nw,ind2,iabc,w,nocc,nvirt,irecln,ibufln)
|
|
************************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer irecln, ibufln
|
|
integer nw,ind2,nrec,c,p
|
|
real*8 iabc(nocc*nvirt**2,nw),w(ibufln)
|
|
open(722,file='iabc',status='unknown',access='direct',
|
|
$recl=irecln)
|
|
nrec=(nocc*nvirt**2-modulo(nocc*nvirt**2,ibufln))/ibufln+1
|
|
do c=1,nw
|
|
do p=1,nrec-1
|
|
write(722,rec=p+(c+ind2-2)*nrec)iabc((p-1)*ibufln+1:p*ibufln,c)
|
|
enddo
|
|
call dcopy(modulo(nocc*nvirt**2,ibufln),
|
|
$iabc((nrec-1)*ibufln+1,c),1,w,1)
|
|
write(722,rec=(c+ind2-1)*nrec)w(1:ibufln)
|
|
enddo
|
|
close(722)
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine abci2read(ind,n,abci,bsymmv,symmocc,dgroup,co,
|
|
$first,last,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,c,i,p,ii,jj
|
|
integer asymm,bsymm,csymm,isymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer ind,n
|
|
real*8 abci(nvirt,nvirt,n,nvirt)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(602,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(602,file='abci',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ci> '
|
|
c write(155,*) 'read <ab|ci> '
|
|
jj=iname('abci')
|
|
do isymm=1,dgroup
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
if(co(i).ge.ind.and.co(i).le.ind+n-1)then
|
|
do csymm=1,dgroup
|
|
xsymm=multpg(isymm,csymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(asymm.ge.csymm)THEN
|
|
IF(last(jj,bsymm,csymm,i).ne.0)THEN
|
|
p=first(jj,bsymm,csymm,i)-1
|
|
ii=ibufln
|
|
do c=bsymmv(csymm)+symmocc(csymm),bsymmv(csymm+1)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),
|
|
$ bsymmv(bsymm+1)-1
|
|
do a=max(c,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(c),co(b),co(i)
|
|
abci(co(a)-nocc,co(c)-nocc,co(i)-ind+1,co(b)-nocc)=V(ii)
|
|
abci(co(c)-nocc,co(a)-nocc,co(i)-ind+1,co(b)-nocc)=V(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
CLOSE(602)
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine abci3read(ind,n,abci,bsymmv,symmocc,dgroup,co,
|
|
$first,last,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,c,i,p,ii,jj
|
|
integer asymm,bsymm,csymm,isymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
real*8 V(ibufln)
|
|
c real*8 V(max((nvirt**2+1)*nvirt/2,(nocc**2+1)*nocc/2))
|
|
integer ind,n
|
|
real*8 abci(nvirt,nvirt,n,nvirt)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(602,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(602,file='abci',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ci> '
|
|
c write(155,*) 'read <ab|ci> '
|
|
jj=iname('abci')
|
|
do isymm=1,dgroup
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
if(co(i).ge.ind.and.co(i).le.ind+n-1)then
|
|
do csymm=1,dgroup
|
|
xsymm=multpg(isymm,csymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(asymm.ge.csymm)THEN
|
|
IF(last(jj,bsymm,csymm,i).ne.0)THEN
|
|
p=first(jj,bsymm,csymm,i)-1
|
|
ii=ibufln
|
|
do c=bsymmv(csymm)+symmocc(csymm),bsymmv(csymm+1)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),
|
|
$ bsymmv(bsymm+1)-1
|
|
do a=max(c,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(c),co(b),co(i)
|
|
abci(co(a)-nocc,co(b)-nocc,co(i)-ind+1,co(c)-nocc)=V(ii)
|
|
abci(co(c)-nocc,co(b)-nocc,co(i)-ind+1,co(a)-nocc)=V(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
CLOSE(602)
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine abciread(ind,n,abci,bsymmv,symmocc,dgroup,co,
|
|
$first,last,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,c,i,p,ii,jj
|
|
integer asymm,bsymm,csymm,isymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer ind,n
|
|
real*8 abci(nvirt,nvirt,nvirt,n)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(602,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
c$OMP CRITICAL
|
|
OPEN(602,file='abci',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ci> '
|
|
c write(155,*) 'read <ab|ci> '
|
|
jj=iname('abci')
|
|
do isymm=1,dgroup
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
if(co(i).ge.ind.and.co(i).le.ind+n-1)then
|
|
do csymm=1,dgroup
|
|
xsymm=multpg(isymm,csymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(asymm.ge.csymm)THEN
|
|
IF(last(jj,bsymm,csymm,i).ne.0)THEN
|
|
p=first(jj,bsymm,csymm,i)-1
|
|
ii=ibufln
|
|
do c=bsymmv(csymm)+symmocc(csymm),bsymmv(csymm+1)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),
|
|
$ bsymmv(bsymm+1)-1
|
|
do a=max(c,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(c),co(b),co(i)
|
|
abci(co(a)-nocc,co(b)-nocc,co(c)-nocc,co(i)-ind+1)=V(ii)
|
|
abci(co(c)-nocc,co(b)-nocc,co(a)-nocc,co(i)-ind+1)=V(ii)
|
|
c db write(*,'(4i4,es18.6)') i,a,b,c,V(ii)
|
|
c db if (a.ne.c) write(*,'(4i4,es18.6)') i,c,b,a,V(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
|
|
CLOSE(602)
|
|
c$OMP END CRITICAL
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine fockextract(h,fij,fai,fab,
|
|
$bsymmv,symmocc,co,first,last,dgroup,ijkl,V,localcc,dfintran,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,k,l,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,ksymm,lsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 h(nbasis,nbasis)
|
|
real*8 fij(nocc,nocc),ijkl(nocc,nocc,nocc,nocc)
|
|
real*8 fai(nvirt,nocc)
|
|
real*8 fab(nvirt,nvirt)
|
|
character*4 localcc,ovirt
|
|
character*8 dfintran
|
|
logical lfock
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(601,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(605,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(601,file='ijkl',access='direct',recl=irecln,STATUS='OLD')
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
OPEN(605,file='aibj',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
call getkey('ovirt',5,ovirt,4) !RZ
|
|
call getkey('dfintran',8,dfintran,8) !RZ
|
|
lfock=ovirt.eq.'off '.or.dfintran.eq.'drpa ' !RZ
|
|
|
|
C if localcc=on, the Fock-matrix is in h!!!
|
|
do i=1,nocc
|
|
call dcopy(nocc,h(1,i),1,fij(1,i),1)
|
|
call dcopy(nvirt,h(1+nocc,i),1,fai(1,i),1)
|
|
enddo
|
|
do b=1,nvirt
|
|
call dcopy(nvirt,h(1+nocc,b+nocc),1,fab(1,b),1)
|
|
enddo
|
|
C if localcc=on, now extracting h from the Fock-matrix
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0)THEN
|
|
p=first(jj,isymm,jsymm,k)-1
|
|
ii=ibufln
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
c aijk(co(a)-nocc,co(i),co(j),co(k))=V(ii)
|
|
c aijk(co(a)-nocc,co(k),co(j),co(i))=V(ii)
|
|
|
|
c if(localcc.eq.'off '.and.
|
|
c $ dfintran.eq.'ovirt ') then !NP
|
|
if(.not.lfock)then !RZ
|
|
if(i.eq.k)fai(co(a)-nocc,co(j))=
|
|
$fai(co(a)-nocc,co(j))+2.d0*V(ii)
|
|
if(j.eq.i)fai(co(a)-nocc,co(k))=
|
|
$fai(co(a)-nocc,co(k))-V(ii)
|
|
if(j.eq.k.and.i.ne.k)fai(co(a)-nocc,co(i))=
|
|
$fai(co(a)-nocc,co(i))-V(ii)
|
|
else
|
|
if(i.eq.k)h(co(a),co(j))=
|
|
$h(co(a),co(j))-2.d0*V(ii)
|
|
if(j.eq.i)h(co(a),co(k))=
|
|
$h(co(a),co(k))+V(ii)
|
|
if(j.eq.k.and.i.ne.k)h(co(a),co(i))=
|
|
$h(co(a),co(i))+V(ii)
|
|
endif
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
c do k=1,nocc
|
|
c do i=1,nocc
|
|
c do a=1,nvirt
|
|
c fai(a,k)=fai(a,k)+2.d0*aijk(a,i,k,i)-aijk(a,i,i,k)
|
|
c fai(a,k)=fai(a,k)-aijk(a,i,i,k)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
|
|
|
|
c rewind 900
|
|
c write(6,*) 'read <ij|kl> '
|
|
c write(155,*) 'read <ij|kl> '
|
|
jj=iname('ijkl')
|
|
do lsymm=1,dgroup
|
|
do l=bsymmv(lsymm),bsymmv(lsymm)+symmocc(lsymm)-1
|
|
do ksymm=lsymm,dgroup
|
|
xsymm=multpg(lsymm,ksymm)
|
|
do jsymm=lsymm,dgroup
|
|
isymm=multpg(jsymm,xsymm)
|
|
IF(isymm.ge.ksymm)THEN
|
|
IF(last(jj,jsymm,ksymm,l).ne.0)THEN
|
|
p=first(jj,jsymm,ksymm,l)-1
|
|
ii=ibufln
|
|
do k=max(l,bsymmv(ksymm)),
|
|
$ bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do j=max(l,bsymmv(jsymm)),
|
|
$ bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(k.gt.l.or.(k.eq.l.and.i.ge.j))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(i),co(k),co(j),co(l)
|
|
c write(900,'(4i4)')i,j,k,l
|
|
ijkl(co(i),co(j),co(k),co(l))=V(ii)
|
|
ijkl(co(k),co(j),co(i),co(l))=V(ii)
|
|
ijkl(co(i),co(l),co(k),co(j))=V(ii)
|
|
ijkl(co(k),co(l),co(i),co(j))=V(ii)
|
|
ijkl(co(j),co(i),co(l),co(k))=V(ii)
|
|
ijkl(co(j),co(k),co(l),co(i))=V(ii)
|
|
ijkl(co(l),co(i),co(j),co(k))=V(ii)
|
|
ijkl(co(l),co(k),co(j),co(i))=V(ii)
|
|
c write(900,'(4i4,f14.10)')co(i),co(j),co(k),co(l),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(k),co(j),co(i),co(l),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(i),co(l),co(k),co(j),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(k),co(l),co(i),co(j),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(j),co(i),co(l),co(k),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(j),co(k),co(l),co(i),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(l),co(i),co(j),co(k),V(ii)
|
|
c write(900,'(4i4,f14.10)')co(l),co(k),co(j),co(i),V(ii)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(601)
|
|
|
|
c rewind 900
|
|
c do l=1,nocc
|
|
c do k=1,nocc
|
|
c do j=1,nocc
|
|
c do i=1,nocc
|
|
c write(900,'(4i3,f14.10)')i,j,k,l,ijkl(i,j,k,l)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
|
|
do k=1,nocc
|
|
do j=1,nocc
|
|
do i=1,nocc
|
|
c if(localcc.eq.'off '.and.dfintran.eq.'ovirt ') then !NP
|
|
if(.not.lfock)then !RZ
|
|
fij(j,k)=fij(j,k)+2.d0*ijkl(j,i,k,i)
|
|
fij(j,k)=fij(j,k)-ijkl(j,i,i,k)
|
|
else
|
|
h(j,k)=h(j,k)-2.d0*ijkl(j,i,k,i)
|
|
h(j,k)=h(j,k)+ijkl(j,i,i,k)
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
c abij(co(a)-nocc,co(b)-nocc,co(i),co(j))=V(ii)
|
|
c abij(co(b)-nocc,co(a)-nocc,co(j),co(i))=V(ii)
|
|
c if(i.eq.j)then
|
|
c abij(co(b)-nocc,co(a)-nocc,co(i),co(j))=V(ii)
|
|
c endif
|
|
|
|
if(i.eq.j)then
|
|
c if(localcc.eq.'off '.and.
|
|
c $ dfintran.eq.'ovirt ') then !NP
|
|
if(.not.lfock)then !RZ
|
|
fab(co(a)-nocc,co(b)-nocc)=
|
|
$fab(co(a)-nocc,co(b)-nocc)-V(ii)
|
|
if(a.ne.b)fab(co(b)-nocc,co(a)-nocc)=
|
|
$fab(co(b)-nocc,co(a)-nocc)-V(ii)
|
|
else
|
|
h(co(a),co(b))=
|
|
$h(co(a),co(b))+V(ii)
|
|
if(a.ne.b)h(co(b),co(a))=
|
|
$h(co(b),co(a))+V(ii)
|
|
endif
|
|
endif
|
|
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c do i=1,nocc
|
|
c fab(a,b)=fab(a,b)-abij(a,b,i,i)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
|
|
c write(6,*) 'read <ai|bj> '
|
|
c write(155,*) 'read <ai|bj> '
|
|
jj=iname('aibj')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do bsymm=1,dgroup
|
|
xsymm=multpg(jsymm,bsymm)
|
|
do isymm=jsymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(asymm.ge.bsymm)THEN
|
|
IF(last(jj,isymm,bsymm,j).ne.0)THEN
|
|
p=first(jj,isymm,bsymm,j)-1
|
|
ii=ibufln
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=max(b,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(b),co(i),co(j)
|
|
c aibj(co(a)-nocc,co(i),co(b)-nocc,co(j))=V(ii)
|
|
c aibj(co(a)-nocc,co(j),co(b)-nocc,co(i))=V(ii)
|
|
c aibj(co(b)-nocc,co(i),co(a)-nocc,co(j))=V(ii)
|
|
c aibj(co(b)-nocc,co(j),co(a)-nocc,co(i))=V(ii)
|
|
|
|
if(i.eq.j)then
|
|
c if(localcc.eq.'off '.and.
|
|
c $ dfintran.eq.'ovirt ') then !NP
|
|
if(.not.lfock)then !RZ
|
|
fab(co(a)-nocc,co(b)-nocc)=
|
|
$fab(co(a)-nocc,co(b)-nocc)+2.d0*V(ii)
|
|
if(a.ne.b)fab(co(b)-nocc,co(a)-nocc)=
|
|
$fab(co(b)-nocc,co(a)-nocc)+2.d0*V(ii)
|
|
else
|
|
h(co(a),co(b))=
|
|
$h(co(a),co(b))-2.d0*V(ii)
|
|
if(a.ne.b)h(co(b),co(a))=
|
|
$h(co(b),co(a))-2.d0*V(ii)
|
|
endif
|
|
endif
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(605)
|
|
|
|
c do i=1,nocc
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c fab(a,b)=fab(a,b)+2.d0*aibj(a,i,b,i)
|
|
c fab(a,b)=fab(a,b)-abij(a,b,i,i)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c if(.false.)then
|
|
c rewind 900
|
|
c do i=1,nbasis
|
|
c do j=1,nbasis
|
|
c write(900,'(2i3,2f14.10)')i,j,fij(i,j),h(i,j)
|
|
c write(900,'(2i3,2f14.10)')i,j,fai(i-nocc,j),h(i,j)
|
|
c write(900,'(2i3,2f14.10)')i,j,fab(i-nocc,j-nocc),h(i,j)
|
|
c enddo
|
|
c enddo
|
|
c endif
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine jetoy(y, irecln, ibufln, nocc, nvirt)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln, ibufln, nocc, nvirt
|
|
integer ii,jj
|
|
|
|
integer lastrec,lastrecsize
|
|
real*8 y(nvirt**2*nocc**2),buffer(ibufln)
|
|
|
|
c buff=8
|
|
cif defined (Intel)
|
|
c OPEN(705,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
c OPEN(705,access='direct',recl=8*buff,STATUS='OLD')
|
|
cendif
|
|
|
|
open(805,file='jezinfofile')
|
|
rewind(805)
|
|
read(805,*)lastrec,lastrecsize
|
|
close(805)
|
|
|
|
OPEN(705,file='jezfile',access='direct',recl=irecln,STATUS='OLD')
|
|
|
|
ii=1
|
|
do jj=1,lastrec-1
|
|
c if(jj.ne.lastrec)then
|
|
c read(705,rec=jj)y((jj-1)*buff+1:jj*buff)
|
|
read(705,rec=jj)buffer(1:ibufln)
|
|
call daxpy(ibufln,-0.5d0,buffer,1,y((jj-1)*ibufln+1:
|
|
$jj*ibufln),1)
|
|
c else
|
|
c read(705,rec=jj)buffer(1:ibufln)
|
|
c call dcopy(lastrecsize,buffer,1,y(buff*(lastrec-1)+1),1)
|
|
c call daxpy(lastrecsize,-0.5d0,buffer,1,
|
|
c $y(ibufln*(lastrec-1)+1),1)
|
|
c endif
|
|
enddo
|
|
read(705,rec=lastrec)buffer(1:ibufln)
|
|
call daxpy(lastrecsize,-0.5d0,buffer,1,y(ibufln*(lastrec-1)+1),1)
|
|
|
|
CLOSE(705,status="delete")
|
|
return
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine jj1read(ind,n,aibj,bsymmv,symmocc,dgroup,co,
|
|
$first,last,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer ind,n
|
|
real*8 aibj(nvirt,nvirt,
|
|
$ (2*nocc-2*ind-n+3)*n/2)
|
|
c $ nocc,n)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(605,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(605,file='aibj',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|bj> '
|
|
c write(155,*) 'read <ai|bj> '
|
|
jj=iname('aibj')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
IF(j.ge.ind.and.j.le.ind+n-1)THEN
|
|
do bsymm=1,dgroup
|
|
xsymm=multpg(jsymm,bsymm)
|
|
do isymm=jsymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(asymm.ge.bsymm)THEN
|
|
IF(last(jj,isymm,bsymm,j).ne.0)THEN
|
|
p=first(jj,isymm,bsymm,j)-1
|
|
ii=ibufln
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=max(b,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(b),co(i),co(j)
|
|
c aibj(co(a)-nocc,co(i),co(b)-nocc,co(j))=V(ii)
|
|
c aibj(co(a)-nocc,co(j),co(b)-nocc,co(i))=V(ii)
|
|
c aibj(co(b)-nocc,co(i),co(a)-nocc,co(j))=V(ii)
|
|
c aibj(co(b)-nocc,co(j),co(a)-nocc,co(i))=V(ii)
|
|
aibj(co(a)-nocc,co(b)-nocc,
|
|
$(co(j)-ind)*(2*nocc-ind-co(j)+3)/2+co(i)-co(j)+1)=V(ii)
|
|
aibj(co(b)-nocc,co(a)-nocc,
|
|
$(co(j)-ind)*(2*nocc-ind-co(j)+3)/2+co(i)-co(j)+1)=V(ii)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
CLOSE(605)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine jjtoy(y,bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 y(nvirt,nvirt,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(605,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(605,file='aibj',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|bj> '
|
|
c write(155,*) 'read <ai|bj> '
|
|
jj=iname('aibj')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do bsymm=1,dgroup
|
|
xsymm=multpg(jsymm,bsymm)
|
|
do isymm=jsymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(asymm.ge.bsymm)THEN
|
|
IF(last(jj,isymm,bsymm,j).ne.0)THEN
|
|
p=first(jj,isymm,bsymm,j)-1
|
|
ii=ibufln
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=max(b,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(b),co(i),co(j)
|
|
y(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
$ y(co(a)-nocc,co(b)-nocc,co(i),co(j))-0.5d0*V(ii)
|
|
if(co(i).ne.co(j))
|
|
$ y(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
$ y(co(a)-nocc,co(b)-nocc,co(j),co(i))-0.5d0*V(ii)
|
|
if(co(a).ne.co(b))
|
|
$ y(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
$ y(co(b)-nocc,co(a)-nocc,co(i),co(j))-0.5d0*V(ii)
|
|
if(co(a).ne.co(b).and.co(i).ne.co(j))
|
|
$ y(co(b)-nocc,co(a)-nocc,co(j),co(i))=
|
|
$ y(co(b)-nocc,co(a)-nocc,co(j),co(i))-0.5d0*V(ii)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(605)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine jjtoz(z,bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 z(nvirt,nvirt,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(605,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(605,file='aibj',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|bj> '
|
|
c write(155,*) 'read <ai|bj> '
|
|
jj=iname('aibj')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do bsymm=1,dgroup
|
|
xsymm=multpg(jsymm,bsymm)
|
|
do isymm=jsymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(asymm.ge.bsymm)THEN
|
|
IF(last(jj,isymm,bsymm,j).ne.0)THEN
|
|
p=first(jj,isymm,bsymm,j)-1
|
|
ii=ibufln
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=max(b,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(b),co(i),co(j)
|
|
c tmp = z(co(a)-nocc,co(b)-nocc,co(i),co(j))
|
|
c z(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
c $z(co(a)-nocc,co(b)-nocc,co(j),co(i))+V(ii)
|
|
c if(co(i).ne.co(j))
|
|
c $z(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
c $tmp+V(ii)
|
|
c if(co(a).ne.co(b)) then
|
|
c tmp = z(co(b)-nocc,co(a)-nocc,co(i),co(j))
|
|
c z(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
c $z(co(b)-nocc,co(a)-nocc,co(j),co(i))+V(ii)
|
|
c end if
|
|
c if(co(a).ne.co(b).and.co(i).ne.co(j))
|
|
c $z(co(b)-nocc,co(a)-nocc,co(j),co(i))=
|
|
c $tmp+V(ii)
|
|
|
|
z(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
$z(co(a)-nocc,co(b)-nocc,co(i),co(j))+V(ii)
|
|
if(co(i).ne.co(j))
|
|
$z(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
$z(co(a)-nocc,co(b)-nocc,co(j),co(i))+V(ii)
|
|
if(co(a).ne.co(b))
|
|
$z(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
$z(co(b)-nocc,co(a)-nocc,co(i),co(j))+V(ii)
|
|
if(co(a).ne.co(b).and.co(i).ne.co(j))
|
|
$z(co(b)-nocc,co(a)-nocc,co(j),co(i))=
|
|
$z(co(b)-nocc,co(a)-nocc,co(j),co(i))+V(ii)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(605)
|
|
return
|
|
|
|
end subroutine
|
|
c {{{ abijread
|
|
*********************************************************************
|
|
subroutine abijread(abij,bsymmv,symmocc,dgroup,first,last,
|
|
$co,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
real*8 V(nvirt**3)
|
|
real*8 abij(nvirt,nvirt,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
ii=1
|
|
do p=first(jj,bsymm,isymm,j),last(jj,bsymm,isymm,j)
|
|
read(600+jj,rec=p) V(ii:ii+buff-1)
|
|
ii=ii+buff
|
|
enddo
|
|
ii=1
|
|
do i=max(j,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
|
|
abij(co(a)-nocc,co(b)-nocc,co(i),co(j))=V(ii)
|
|
c abij(co(b)-nocc,co(a)-nocc,co(j),co(i))=V(ii)
|
|
|
|
ii=ii+1
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
do j=1,nocc
|
|
do i=1,j-1
|
|
call tr(nvirt,abij(1,1,j,i),abij(1,1,i,j))
|
|
enddo
|
|
do b=1,nvirt
|
|
do a=1,b-1
|
|
abij(a,b,j,j)=abij(b,a,j,j)
|
|
enddo
|
|
enddo
|
|
enddo
|
|
return
|
|
|
|
end subroutine
|
|
c }}} *********************************************************************
|
|
c {{{ ijabread
|
|
*********************************************************************
|
|
subroutine ijabread(ijab,bsymmv,symmocc,dgroup,first,last,
|
|
$co,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
real*8 V(nvirt**3)
|
|
real*8 ijab(nocc,nocc,nvirt,nvirt)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
ii=1
|
|
do p=first(jj,bsymm,isymm,j),last(jj,bsymm,isymm,j)
|
|
read(600+jj,rec=p) V(ii:ii+buff-1)
|
|
ii=ii+buff
|
|
enddo
|
|
ii=1
|
|
do i=max(j,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
|
|
c ijab(co(a)-nocc,co(b)-nocc,co(i),co(j))=V(ii)
|
|
ijab(co(i),co(j),co(a)-nocc,co(b)-nocc)=V(ii)
|
|
ijab(co(j),co(i),co(b)-nocc,co(a)-nocc)=V(ii)
|
|
|
|
ii=ii+1
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
c do j=1,nocc
|
|
c do i=1,j-1
|
|
c call tr(nvirt,ijab(1,1,j,i),ijab(1,1,i,j))
|
|
c enddo
|
|
c do b=1,nvirt
|
|
c do a=1,b-1
|
|
c ijab(a,b,j,j)=ijab(b,a,j,j)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
return
|
|
|
|
end subroutine
|
|
c }}}
|
|
*********************************************************************
|
|
subroutine kklkread(kk,bsymmv,symmocc,dgroup,first,last,
|
|
$co,V,comp,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer ttind
|
|
c GyNL
|
|
c real*8 kk(nvirt,nvirt,(nocc-ind+1+nocc-(ind-1+n)+1)*n/2)
|
|
real*8 kk(nvirt,nvirt,*)
|
|
character comp
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
c ii=1
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
! sum_{l=nocc-ind+1)^{nocc-(j-1)+1} {l} + (k-j+1)
|
|
ttind=(2*nocc-j+2)*(j-1)/2+i-j+1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
|
|
c write(6,*)ttind
|
|
c GyNL
|
|
if(comp .eq. 'y') then
|
|
kk(co(a)-nocc,co(b)-nocc,ttind)=V(ii)
|
|
if(i.eq.j)then
|
|
kk(co(b)-nocc,co(a)-nocc,ttind)=V(ii)
|
|
endif
|
|
else if(comp .eq. 'n') then
|
|
kk(co(a)-nocc,co(b)-nocc,
|
|
$ (co(j)-1)*nocc+co(i))=V(ii)
|
|
kk(co(b)-nocc,co(a)-nocc,
|
|
$ (co(i)-1)*nocc+co(j))=V(ii)
|
|
end if
|
|
|
|
c ii=ii+1
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
c endif
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine kktoy(y,bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 y(nvirt,nvirt,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=max(j,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
y(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
$ y(co(b)-nocc,co(a)-nocc,co(i),co(j))+V(ii)
|
|
if(i.ne.j)then
|
|
y(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
$ y(co(a)-nocc,co(b)-nocc,co(j),co(i))+V(ii)
|
|
endif
|
|
if(i.eq.j.and.a.ne.b)then
|
|
y(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
$y(co(a)-nocc,co(b)-nocc,co(i),co(j))+V(ii)
|
|
endif
|
|
|
|
c ii=ii+1
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine ijkaread(ijka,bsymmv,symmocc,dgroup,
|
|
$first,last,co,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,i,j,k,p,ii,jj
|
|
integer asymm,isymm,jsymm,ksymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(nvirt**3)
|
|
real*8 ijka(nocc,nocc,nocc,nvirt)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
c ttind=1
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0)THEN
|
|
ii=1
|
|
do p=first(jj,isymm,jsymm,k),last(jj,isymm,jsymm,k)
|
|
read(600+jj,rec=p) V(ii:ii+buff-1)
|
|
ii=ii+buff
|
|
enddo
|
|
ii=1
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
ijka(co(i),co(j),co(k),co(a)-nocc)=V(ii)
|
|
ijka(co(k),co(j),co(i),co(a)-nocc)=V(ii)
|
|
|
|
ii=ii+1
|
|
enddo
|
|
c ttind=ttind+1
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine aijkread(aijk,bsymmv,symmocc,dgroup,
|
|
$first,last,co,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,i,j,k,p,ii,jj
|
|
integer asymm,isymm,jsymm,ksymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(nvirt**3)
|
|
real*8 aijk(nvirt,nocc,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
c ttind=1
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0)THEN
|
|
ii=1
|
|
do p=first(jj,isymm,jsymm,k),last(jj,isymm,jsymm,k)
|
|
read(600+jj,rec=p) V(ii:ii+buff-1)
|
|
ii=ii+buff
|
|
enddo
|
|
ii=1
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
aijk(co(a)-nocc,co(i),co(j),co(k))=V(ii)
|
|
aijk(co(a)-nocc,co(k),co(j),co(i))=V(ii)
|
|
|
|
ii=ii+1
|
|
enddo
|
|
c ttind=ttind+1
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine ks2read(ind,n,kssize,ks,
|
|
$bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,i,j,k,p,ii,jj
|
|
integer asymm,isymm,jsymm,ksymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer kssize,ind,n,ttind
|
|
real*8 ks(nocc,nvirt,kssize)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
c ttind=1
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
if(co(k).ge.ind.and.co(k).le.ind+n-1)then
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0)THEN
|
|
p=first(jj,isymm,jsymm,k)-1
|
|
ii=ibufln
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
ttind=(co(k)-ind)*(2*nocc-ind-co(k)+3)/2+
|
|
$ co(i)-co(k)+1
|
|
do a=bsymmv(asymm)+symmocc(asymm),
|
|
$ bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
ks(co(j),co(a)-nocc,ttind)=V(ii)
|
|
|
|
enddo
|
|
c ttind=ttind+1
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
endif
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine ksread(aijk,bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,i,j,k,p,ii,jj
|
|
integer asymm,isymm,jsymm,ksymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 aijk(nvirt,nocc,nocc,nocc)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0)THEN
|
|
p=first(jj,isymm,jsymm,k)-1
|
|
ii=ibufln
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
c write(6,*)ii
|
|
aijk(co(a)-nocc,co(j),co(i),co(k))=V(ii)
|
|
aijk(co(a)-nocc,co(j),co(k),co(i))=V(ii)
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine list2abread(ijkl,abij,bsymmv,symmocc,dgroup,
|
|
$first,last,co,V,irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,k,l,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,ksymm,lsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 ijkl(nocc,nocc,nocc,nocc)
|
|
integer ttind
|
|
real*8 abij(nvirt,nvirt,(nocc+1)*nocc/2)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(601,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(601,file='ijkl',access='direct',recl=irecln,STATUS='OLD')
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ij|kl> '
|
|
c write(155,*) 'read <ij|kl> '
|
|
jj=iname('ijkl')
|
|
do lsymm=1,dgroup
|
|
do l=bsymmv(lsymm),bsymmv(lsymm)+symmocc(lsymm)-1
|
|
do ksymm=lsymm,dgroup
|
|
xsymm=multpg(lsymm,ksymm)
|
|
do jsymm=lsymm,dgroup
|
|
isymm=multpg(jsymm,xsymm)
|
|
IF(isymm.ge.ksymm)THEN
|
|
IF(last(jj,jsymm,ksymm,l).ne.0)THEN
|
|
p=first(jj,jsymm,ksymm,l)-1
|
|
ii=ibufln
|
|
do k=max(l,bsymmv(ksymm)),
|
|
$ bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do j=max(l,bsymmv(jsymm)),
|
|
$ bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(k.gt.l.or.(k.eq.l.and.i.ge.j))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,6I6)') V(ii),co(i),co(k),co(j),co(l)
|
|
c itt van segfault
|
|
c write(6,'(e28.20,6I6)') V(ii),co(i),co(k),co(j),co(l)
|
|
ijkl(co(i),co(j),co(k),co(l))=V(ii)
|
|
ijkl(co(k),co(j),co(i),co(l))=V(ii)
|
|
ijkl(co(i),co(l),co(k),co(j))=V(ii)
|
|
ijkl(co(k),co(l),co(i),co(j))=V(ii)
|
|
ijkl(co(j),co(i),co(l),co(k))=V(ii)
|
|
ijkl(co(j),co(k),co(l),co(i))=V(ii)
|
|
ijkl(co(l),co(i),co(j),co(k))=V(ii)
|
|
ijkl(co(l),co(k),co(j),co(i))=V(ii)
|
|
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(601)
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=max(j,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
ttind=(co(i)-1)*co(i)/2+co(j)
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
c i<-->j a<-->b
|
|
abij(co(b)-nocc,co(a)-nocc,ttind)=V(ii)
|
|
if(i.eq.j)then
|
|
abij(co(a)-nocc,co(b)-nocc,ttind)=V(ii)
|
|
endif
|
|
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine ll2read(ind,n,ll,order,nocc,nvirt,ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer ifltln
|
|
integer nocc, nvirt
|
|
integer b,k,l, jj
|
|
character*4 order
|
|
|
|
integer ind,n
|
|
real*8 ll(nvirt, nvirt, nocc, n)
|
|
|
|
OPEN(704,file='llfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='OLD')
|
|
|
|
if(order .eq. 'abkl') then
|
|
do l = ind, ind+n-1
|
|
do k = 1, nocc
|
|
do b = 1, nvirt
|
|
jj = (l-1) * nocc*nvirt + (k-1) * nvirt + b
|
|
|
|
read(704, rec = jj) ll(1:nvirt, b, k, l-ind+1)
|
|
end do
|
|
end do
|
|
enddo
|
|
else if(order .eq. 'ablk') then
|
|
do l = 1, nocc
|
|
do k = ind, ind+n-1
|
|
do b = 1, nvirt
|
|
jj = (l-1) * nocc*nvirt + (k-1) * nvirt + b
|
|
|
|
read(704, rec = jj) ll(1:nvirt, b, l, k-ind+1)
|
|
end do
|
|
end do
|
|
enddo
|
|
end if
|
|
|
|
|
|
CLOSE(704)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine llextract(ll,bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg,ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax,ifltln
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc),coreint(nbasis,nbasis)
|
|
real*8 V(ibufln)
|
|
real*8 ll(nvirt,nvirt,nocc,nocc)
|
|
|
|
|
|
call dfillzero(ll,nvirt**2*nocc**2)
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(704,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
c OPEN(704,access='direct',recl=8*buff,STATUS='OLD')
|
|
cendif
|
|
|
|
c rewind(900)
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> 4'
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
c write(900,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
if(i.ne.j)then
|
|
ll(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
$ll(co(a)-nocc,co(b)-nocc,co(i),co(j))+2.d0*V(ii)
|
|
ll(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
$ll(co(b)-nocc,co(a)-nocc,co(i),co(j))-1.d0*V(ii)
|
|
ll(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
$ll(co(a)-nocc,co(b)-nocc,co(j),co(i))-1.d0*V(ii)
|
|
ll(co(b)-nocc,co(a)-nocc,co(j),co(i))
|
|
$=ll(co(b)-nocc,co(a)-nocc,co(j),co(i))+2.d0*V(ii)
|
|
else
|
|
ll(co(a)-nocc,co(b)-nocc,co(i),co(j))=V(ii)
|
|
ll(co(b)-nocc,co(a)-nocc,co(i),co(j))=V(ii)
|
|
endif
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
c close(900)
|
|
call llwrite(ll, nocc, nvirt, ifltln)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine aaextract(ll,aa,
|
|
$bsymmv,symmocc,dgroup,first,last,co,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg,ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax,ifltln
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,b,i,j,p,ii,jj,ij
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc),coreint(nbasis,nbasis)
|
|
real*8 V(ibufln)
|
|
real*8 ll(nvirt,nvirt,nocc,nocc)
|
|
real*8 aa(nvirt**2,nocc*(nocc+1)/2)
|
|
|
|
call dfillzero(ll,nvirt**2*nocc**2)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
c OPEN(704,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
c OPEN(704,access='direct',recl=8*buff,STATUS='OLD')
|
|
cendif
|
|
|
|
c rewind(900)
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> 4'
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=bsymmv(isymm),bsymmv(isymm)+symmocc(isymm)-1
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
c write(900,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
ll(co(a)-nocc,co(b)-nocc,co(i),co(j))=2.d0*V(ii)
|
|
ll(co(b)-nocc,co(a)-nocc,co(j),co(i))=2.d0*V(ii)
|
|
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(604)
|
|
c write(6,*)'2K'
|
|
c do j=1,nocc
|
|
c do i=1,nocc
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c write(6,'(4i3,e16.8)')a,b,i,j,ll(a,b,i,j)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
OPEN(605,file='aibj',access='direct',recl=irecln,STATUS='OLD')
|
|
c write(6,*) 'read <ai|bj> '
|
|
c write(155,*) 'read <ai|bj> '
|
|
IF(.true.)then
|
|
jj=iname('aibj')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do bsymm=1,dgroup
|
|
xsymm=multpg(jsymm,bsymm)
|
|
do isymm=jsymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(asymm.ge.bsymm)THEN
|
|
IF(last(jj,isymm,bsymm,j).ne.0)THEN
|
|
p=first(jj,isymm,bsymm,j)-1
|
|
ii=ibufln
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do i=max(j,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=max(b,bsymmv(asymm)+symmocc(asymm)),
|
|
$ bsymmv(asymm+1)-1
|
|
ii=ii+1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
c write(155,'(e28.20,6I6)') V(ii),co(a),co(b),co(i),co(j)
|
|
c aibj(co(a)-nocc,co(i),co(b)-nocc,co(j))=V(ii)
|
|
c aibj(co(a)-nocc,co(j),co(b)-nocc,co(i))=V(ii)
|
|
c aibj(co(b)-nocc,co(i),co(a)-nocc,co(j))=V(ii)
|
|
c aibj(co(b)-nocc,co(j),co(a)-nocc,co(i))=V(ii)
|
|
|
|
|
|
ll(co(a)-nocc,co(b)-nocc,co(i),co(j))=
|
|
$ll(co(a)-nocc,co(b)-nocc,co(i),co(j))-1.d0*V(ii)
|
|
if(i.ne.j)then
|
|
ll(co(a)-nocc,co(b)-nocc,co(j),co(i))=
|
|
$ll(co(a)-nocc,co(b)-nocc,co(j),co(i))-1.d0*V(ii)
|
|
endif
|
|
|
|
if(a.ne.b)then
|
|
ll(co(b)-nocc,co(a)-nocc,co(i),co(j))=
|
|
$ll(co(b)-nocc,co(a)-nocc,co(i),co(j))-1.d0*V(ii)
|
|
if(i.ne.j)then
|
|
ll(co(b)-nocc,co(a)-nocc,co(j),co(i))=
|
|
$ll(co(b)-nocc,co(a)-nocc,co(j),co(i))-1.d0*V(ii)
|
|
endif
|
|
endif
|
|
|
|
ii=ii+1
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
CLOSE(605)
|
|
c close(900)
|
|
c write(6,*)'A'
|
|
c do j=1,nocc
|
|
c do i=1,nocc
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c write(6,'(4i3,e16.8)')a,b,i,j,ll(a,b,i,j)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
|
|
C Sort ll to A
|
|
c write(6,*)'A'
|
|
do j=1,nocc
|
|
do i=1,j
|
|
ij=j*(j-1)/2+i
|
|
call dcopy(nvirt**2,ll(1,1,i,j),1,aa(1,ij),1)
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c write(6,'(4i3,e16.8)')a,b,i,j,aa(a+(b-1)*nvirt,ij)
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
enddo
|
|
call aawrite(aa, nocc, nvirt, irecln, ibufln)
|
|
|
|
return
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine bbwrite(bb, nocc, nvirt, ibufln, irecln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer ibufln, irecln, nocc, nvirt
|
|
real*8 bb(nvirt**2*nocc*(nocc+1)/2),buffer(ibufln)
|
|
integer i,lastrec,lastrecsize
|
|
C Write A to file
|
|
open(714,file='bbfile',status='unknown',access='direct',
|
|
$recl=irecln)
|
|
lastrecsize=modulo(nvirt**2*(nocc+1)*nocc/2,
|
|
$ibufln)
|
|
if(lastrecsize.eq.0)lastrecsize=ibufln
|
|
lastrec=(nvirt**2*(nocc+1)*nocc/2-lastrecsize)/ibufln+1
|
|
do i=1,lastrec-1
|
|
write(714,rec=i)bb((i-1)*ibufln+1:i*ibufln)
|
|
enddo
|
|
call dcopy(lastrecsize,bb((lastrec-1)*ibufln+1),1,buffer,1)
|
|
write(714,rec=lastrec)buffer(1:ibufln)
|
|
|
|
close(714)
|
|
return
|
|
|
|
end subroutine
|
|
|
|
|
|
*********************************************************************
|
|
subroutine aawrite(aa, nocc, nvirt, irecln, ibufln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln, ibufln
|
|
integer nocc, nvirt
|
|
real*8 aa(nvirt**2*nocc*(nocc+1)/2),buffer(ibufln)
|
|
integer i,lastrec,lastrecsize
|
|
C Write A to file
|
|
open(715,file='aafile',status='unknown',access='direct',
|
|
$recl=irecln)
|
|
lastrecsize=modulo(nvirt**2*(nocc+1)*nocc/2,
|
|
$ibufln)
|
|
if(lastrecsize.eq.0)lastrecsize=ibufln
|
|
lastrec=(nvirt**2*(nocc+1)*nocc/2-lastrecsize)/ibufln+1
|
|
do i=1,lastrec-1
|
|
write(715,rec=i)aa((i-1)*ibufln+1:i*ibufln)
|
|
enddo
|
|
call dcopy(lastrecsize,aa((lastrec-1)*ibufln+1),1,buffer,1)
|
|
write(715,rec=lastrec)buffer(1:ibufln)
|
|
|
|
close(715)
|
|
return
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine bbextract(ll,bb,nocc,nvirt,ibufln,irecln)
|
|
*********************************************************************
|
|
C write aaextract, bbread, aaread accordingly!
|
|
implicit none
|
|
integer ibufln, irecln
|
|
integer nocc, nvirt
|
|
real*8 ll(nvirt**2,nocc,nocc)
|
|
real*8 bb(nvirt**2,nocc*(nocc+1)/2)
|
|
integer ij,i,j
|
|
C Sort ll to B
|
|
c write(6,*)'B'
|
|
do j=1,nocc
|
|
do i=1,j
|
|
ij=j*(j-1)/2+i
|
|
call dcopy(nvirt**2,ll(1,i,j),1,bb(1,ij),1)
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c write(6,'(4i3,e16.8)')a,b,i,j,bb(a+(b-1)*nvirt,ij)
|
|
c enddo
|
|
c enddo
|
|
enddo
|
|
enddo
|
|
call bbwrite(bb, nocc, nvirt, ibufln, irecln)
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine aaread(aa,nocc,nvirt,ibufln,irecln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer ibufln, irecln
|
|
integer nocc, nvirt
|
|
real*8 aa(nvirt**2*(nocc+1)*nocc/2),buffer(ibufln)
|
|
integer i,lastrec,lastrecsize
|
|
lastrecsize=modulo(nvirt**2*(nocc+1)*nocc/2,
|
|
$ibufln)
|
|
if(lastrecsize.eq.0)lastrecsize=ibufln
|
|
lastrec=(nvirt**2*(nocc+1)*nocc/2-lastrecsize)/ibufln+1
|
|
open(715,file='aafile',access='direct',recl=irecln,status='old')
|
|
do i=1,lastrec-1
|
|
read(715,rec=i)aa((i-1)*ibufln+1:i*ibufln)
|
|
enddo
|
|
read(715,rec=lastrec)buffer(1:ibufln)
|
|
call dcopy(lastrecsize,buffer,1,aa((lastrec-1)*ibufln+1),1)
|
|
close(715)
|
|
return
|
|
end subroutine
|
|
|
|
|
|
*********************************************************************
|
|
subroutine bbread(bb,nocc,nvirt,ibufln,irecln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer ibufln, irecln
|
|
integer nocc, nvirt
|
|
real*8 bb(nvirt**2*(nocc+1)*nocc/2),buffer(ibufln)
|
|
integer i,lastrec,lastrecsize
|
|
lastrecsize=modulo(nvirt**2*(nocc+1)*nocc/2,
|
|
$ibufln)
|
|
if(lastrecsize.eq.0)lastrecsize=ibufln
|
|
lastrec=(nvirt**2*(nocc+1)*nocc/2-lastrecsize)/ibufln+1
|
|
open(714,file='bbfile',access='direct',recl=irecln,status='old')
|
|
do i=1,lastrec-1
|
|
read(714,rec=i)bb((i-1)*ibufln+1:i*ibufln)
|
|
enddo
|
|
read(714,rec=lastrec)buffer(1:ibufln)
|
|
call dcopy(lastrecsize,buffer,1,bb((lastrec-1)*ibufln+1),1)
|
|
close(714)
|
|
c write(6,*)'B'
|
|
c do j=1,nocc
|
|
c do i=1,j
|
|
c ij=j*(j-1)/2+i
|
|
c do b=1,nvirt
|
|
c do a=1,nvirt
|
|
c write(6,'(4i3,e16.8)')a,b,i,j,bb(a+(b-1)*nvirt+(ij-1)*nvirt**2)
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
c enddo
|
|
return
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine llwrite(ll, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
real*8 ll(nvirt, nvirt, nocc, nocc)
|
|
integer jj, b, k, l
|
|
|
|
OPEN(704,file='llfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='unknown')
|
|
|
|
do l = 1, nocc
|
|
do k = 1, nocc
|
|
do b = 1, nvirt
|
|
jj = (l-1) * nocc*nvirt + (k-1) * nvirt + b
|
|
|
|
write(704, rec = jj) ll(1:nvirt, b, k, l)
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
CLOSE(704)
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine llread(ll, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
integer b, k, l, jj
|
|
|
|
real*8 ll(nvirt, nvirt, nocc, nocc)
|
|
|
|
OPEN(704,file='llfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='OLD')
|
|
|
|
do l = 1, nocc
|
|
do k = 1, nocc
|
|
do b = 1, nvirt
|
|
jj = (l-1) * nocc*nvirt + (k-1) * nvirt + b
|
|
|
|
read(704, rec = jj) ll(1:nvirt, b, k, l)
|
|
end do
|
|
end do
|
|
enddo
|
|
|
|
CLOSE(704)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine ls2read(ind,n,ls, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
integer k, l, j, jj
|
|
|
|
integer ind,n
|
|
real*8 ls(nocc, nvirt, nocc, n)
|
|
|
|
OPEN(704,file='lsfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='OLD')
|
|
|
|
do j = ind, ind+n-1
|
|
do l = 1, nocc
|
|
do k = 1, nocc
|
|
jj = (j-1) * nocc**2 + (l-1) * nocc + k
|
|
|
|
read(704, rec = jj) ls(l, 1:nvirt, k, j-ind+1)
|
|
end do
|
|
end do
|
|
enddo
|
|
|
|
CLOSE(704)
|
|
return
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine lsextract(ls,bsymmv,symmocc,dgroup,co,first,last,V,
|
|
$irecln,ibufln,nbasis,nocc,nvirt,nirmax,multpg,ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln,ibufln,nbasis,nocc,nvirt,dgroup,nirmax,ifltln
|
|
integer bsymmv(nirmax+1),symmocc(nirmax),multpg(nirmax,nirmax)
|
|
integer a,i,j,k,p,ii,jj
|
|
integer asymm,isymm,jsymm,ksymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
real*8 ls(nvirt,nocc,nocc,nocc)
|
|
|
|
call dfillzero(ls,nvirt*nocc**3)
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(603,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(603,file='aijk',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
|
|
c write(6,*) 'read <ai|jk> '
|
|
c write(155,*) 'read <ai|jk> '
|
|
jj=iname('aijk')
|
|
do ksymm=1,dgroup
|
|
do k=bsymmv(ksymm),bsymmv(ksymm)+symmocc(ksymm)-1
|
|
do jsymm=1,dgroup
|
|
xsymm=multpg(ksymm,jsymm)
|
|
do isymm=ksymm,dgroup
|
|
asymm=multpg(isymm,xsymm)
|
|
IF(last(jj,isymm,jsymm,k).ne.0) THEN
|
|
p=first(jj,isymm,jsymm,k)-1
|
|
ii=ibufln
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do i=max(k,bsymmv(isymm)),
|
|
$ bsymmv(isymm)+symmocc(isymm)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(j),co(i),co(k)
|
|
ls(co(a)-nocc,co(i),co(j),co(k))=
|
|
$ls(co(a)-nocc,co(i),co(j),co(k))-1.d0*V(ii)
|
|
ls(co(a)-nocc,co(j),co(i),co(k))=
|
|
$ls(co(a)-nocc,co(j),co(i),co(k))+2.d0*V(ii)
|
|
if(i.ne.k)then
|
|
ls(co(a)-nocc,co(k),co(j),co(i))=
|
|
$ls(co(a)-nocc,co(k),co(j),co(i))-1.d0*V(ii)
|
|
ls(co(a)-nocc,co(j),co(k),co(i))=
|
|
$ls(co(a)-nocc,co(j),co(k),co(i))+2.d0*V(ii)
|
|
endif
|
|
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
CLOSE(603)
|
|
|
|
call lswrite(ls, nocc, nvirt, ifltln)
|
|
return
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine lswrite(ls, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
real*8 ls(nvirt, nocc, nocc, nocc)
|
|
integer jj, k, l, j
|
|
|
|
OPEN(704,file='lsfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='unknown')
|
|
|
|
do j = 1, nocc
|
|
do l = 1, nocc
|
|
do k = 1, nocc
|
|
jj = (j-1) * nocc**2 + (l-1) * nocc + k
|
|
|
|
write(704, rec = jj) ls(1:nvirt, k, l, j)
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
CLOSE(704)
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine lsread(ls, ind, n, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
real*8 ls(nvirt, nocc, nocc, n)
|
|
|
|
integer k, l, j, jj
|
|
|
|
integer ind,n
|
|
|
|
OPEN(704,file='lsfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='OLD')
|
|
|
|
do j = ind, ind + n - 1
|
|
do l = 1, nocc
|
|
do k = 1, nocc
|
|
jj = (j-1) * nocc**2 + (l-1) * nocc + k
|
|
|
|
read(704, rec = jj) ls(1:nvirt, k, l, j-ind+1)
|
|
end do
|
|
end do
|
|
enddo
|
|
|
|
CLOSE(704)
|
|
return
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine kklkwrite(kk, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
real*8 kk(nvirt, nvirt, nocc, nocc)
|
|
integer jj, b, i, j
|
|
|
|
OPEN(710,file='kkfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='unknown')
|
|
|
|
do j = 1, nocc
|
|
do i = 1, nocc
|
|
do b = 1, nvirt
|
|
jj = (j-1) * nocc*nvirt + (i-1) * nvirt + b
|
|
|
|
write(710, rec = jj) kk(1:nvirt, b, i, j)
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
CLOSE(710)
|
|
|
|
end subroutine
|
|
|
|
*********************************************************************
|
|
subroutine kklk2read(ind, n, kk, nocc, nvirt, ifltln)
|
|
*********************************************************************
|
|
implicit none
|
|
integer nocc, nvirt
|
|
integer ifltln
|
|
real*8 kk(nvirt, nvirt, nocc, n)
|
|
integer jj, b, i, j, ind, n
|
|
|
|
OPEN(710,file='kkfile',access='direct',recl=ifltln*nvirt,
|
|
$ STATUS='old')
|
|
|
|
do j = ind, ind+n-1
|
|
do i = 1, nocc
|
|
do b = 1, nvirt
|
|
jj = (j-1) * nocc*nvirt + (i-1) * nvirt + b
|
|
|
|
read(710, rec = jj) kk(1:nvirt, b, i, j-ind+1)
|
|
end do
|
|
end do
|
|
end do
|
|
|
|
CLOSE(710)
|
|
|
|
end subroutine
|
|
*********************************************************************
|
|
subroutine vvinit(abij,bsymmv,symmocc,dgroup,
|
|
$first,last,co,V,irecln,ibufln,nocc,nvirt,nbasis,nirmax,multpg)
|
|
*********************************************************************
|
|
implicit none
|
|
integer irecln, ibufln, nocc, nvirt, nbasis, dgroup
|
|
integer bsymmv(nirmax+1), symmocc(nirmax), nirmax
|
|
integer multpg(nirmax, nirmax)
|
|
integer a,b,i,j,p,ii,jj
|
|
integer asymm,bsymm,isymm,jsymm,xsymm
|
|
integer buff
|
|
integer first(0:5,8,8,nbasis),last(0:5,8,8,nbasis)
|
|
integer iname,co(nbasis)
|
|
c real*8 V(nbasis**3*nocc)
|
|
real*8 V(ibufln)
|
|
integer ttind
|
|
real*8 abij(nvirt,nvirt,(nocc+1)*nocc/2)
|
|
|
|
buff=ibufln
|
|
cif defined (Intel)
|
|
c OPEN(604,access='direct',recl=2*buff,STATUS='OLD')
|
|
celse
|
|
OPEN(604,file='abij',access='direct',recl=irecln,STATUS='OLD')
|
|
cendif
|
|
|
|
c write(6,*) 'read <ab|ij> '
|
|
c write(155,*) 'read <ab|ij> '
|
|
jj=iname('abij')
|
|
do jsymm=1,dgroup
|
|
do j=bsymmv(jsymm),bsymmv(jsymm)+symmocc(jsymm)-1
|
|
do isymm=1,dgroup
|
|
xsymm=multpg(isymm,jsymm)
|
|
do bsymm=1,dgroup
|
|
asymm=multpg(bsymm,xsymm)
|
|
IF(last(jj,bsymm,isymm,j).ne.0)THEN
|
|
p=first(jj,bsymm,isymm,j)-1
|
|
ii=ibufln
|
|
do i=max(j,bsymmv(isymm)),bsymmv(isymm)+symmocc(isymm)-1
|
|
ttind=(co(i)-1)*co(i)/2+co(j)
|
|
do b=bsymmv(bsymm)+symmocc(bsymm),bsymmv(bsymm+1)-1
|
|
do a=bsymmv(asymm)+symmocc(asymm),bsymmv(asymm+1)-1
|
|
if(ii.eq.ibufln) then
|
|
p=p+1
|
|
read(600+jj,rec=p) V(1:ibufln)
|
|
ii=0
|
|
end if
|
|
if(i.gt.j.or.(i.eq.j.and.a.ge.b))then
|
|
ii=ii+1
|
|
c write(155,'(e28.20,7I6)') V(ii),co(a),co(i),co(b),co(j)
|
|
c i<-->j a<-->b
|
|
abij(co(b)-nocc,co(a)-nocc,ttind)=V(ii)
|
|
if(i.eq.j)then
|
|
abij(co(a)-nocc,co(b)-nocc,ttind)=V(ii)
|
|
endif
|
|
|
|
endif
|
|
enddo
|
|
enddo
|
|
enddo
|
|
ENDIF
|
|
enddo
|
|
enddo
|
|
enddo
|
|
enddo
|
|
|
|
CLOSE(604)
|
|
return
|
|
end subroutine
|