mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-18 04:30:53 +01:00
176 lines
5.1 KiB
Fortran
176 lines
5.1 KiB
Fortran
|
|
implicit none
|
|
|
|
integer nal,nbe,nval,nvbe,imem,maxcor,imem1,iout,i,j,k,a,b,c,abc
|
|
integer it2list1,it2list2,its,iw,it,ivooo,ivvoo,iabci,recln,kmax
|
|
integer kmin,jk,ij,ni,ef,ik,ac,ab,bc,pr,prold,total,recperocc
|
|
integer ibufln,irecln,irest,icurrent
|
|
|
|
real*8 scr(*),tb2(nvbe*(nvbe-1)/2,nbe*(nbe-1)/2),ta1(nval,nal)
|
|
real*8 tb1(nvbe,nbe),ddot,et,fa(nal+nval,nal+nval),ets,tmp
|
|
real*8 fb(nbe+nvbe,nbe+nvbe),tscalea(nal),epaa(nal,nal)
|
|
real*8 ta2(nval*(nval-1)/2,nal*(nal-1)/2)
|
|
|
|
logical error,inj,ini,qscale
|
|
|
|
character*6 aijkaa,abijaa
|
|
character*8 abciaaaa
|
|
|
|
if (nval.gt.2) then
|
|
it2list1=0
|
|
it2list2=it2list1+nval*nval*nal*(nal-1)/2
|
|
its=it2list2+nval*(nval-1)*nal*nal/2
|
|
iw=its+nval*nval*(nval-1)/2
|
|
it=iw+nval*(nval-1)*(nval-2)/6
|
|
ivooo=it+nval*(nval-1)*(nval-2)/6
|
|
ivvoo=ivooo+nval*nal*nal*(nal-1)/2
|
|
iabci=ivvoo+nval*(nval-1)*nal*(nal-1)/4
|
|
recln=nval*nval*(nval-1)/2
|
|
recperocc=recln/ibufln
|
|
if (mod(recln,ibufln).gt.0) recperocc=recperocc+1
|
|
c Checking the allocated memory
|
|
if (iabci+3*recln.gt.maxcor-imem+imem1) then
|
|
|
|
write(*,*)
|
|
write(iout,*) 'Insufficient memory!'
|
|
write(iout,"(' Requested: ',f6.2,' GB')")
|
|
&dble((iabci+3*recln)*8)/1024**3
|
|
write(iout,"(' Available: ',f6.2,' GB')")
|
|
&dble((maxcor-imem+imem1)*8)/1024**3
|
|
write(*,*)
|
|
error=.true.
|
|
return
|
|
|
|
endif
|
|
|
|
call xxyyunb(ta2,nval,nval,nal,nal,scr(it2list1+1))
|
|
call yyxxunb(ta2,nval,nval,nal,nal,scr(it2list2+1))
|
|
|
|
if (nal.gt.1.and.nval.gt.0) then
|
|
open(16,file=aijkaa,form='unformatted')
|
|
read(16) scr(ivooo+1:ivvoo)
|
|
close(16)
|
|
endif !nal>1,nval>0
|
|
|
|
open(16,file=abijaa,form='unformatted')
|
|
read(16) scr(ivvoo+1:iabci)
|
|
close(16)
|
|
|
|
c open(16,file=abciaaaa,access='direct',recl=8*recln)
|
|
open(16,file=abciaaaa,access='direct',recl=irecln)
|
|
|
|
kmax=0
|
|
kmin=0
|
|
|
|
jk=0
|
|
do k=1,nal
|
|
ij=0
|
|
|
|
c Reading a vvvo block if necessary
|
|
if (k.gt.kmax) then
|
|
ni=(maxcor-imem+imem1-iabci)/recln
|
|
ni=ni-2
|
|
if (ni.gt.nal-kmax) ni=nal-kmax
|
|
|
|
do i=1,ni
|
|
call getlst(16,(kmax+i-1)*recperocc+1,
|
|
& scr(iabci+(i-1)*recln+1),recln)
|
|
c read(16,rec=kmax+i) scr(iabci+(i-1)*recln+1:
|
|
c &iabci+i*recln)
|
|
enddo
|
|
|
|
kmin=kmax+1
|
|
kmax=kmax+ni
|
|
endif
|
|
|
|
do j=1,k-1
|
|
jk=jk+1
|
|
if (icurrent+j-1.le.irest) then
|
|
ij = ij + j-1
|
|
icurrent = icurrent + j-1
|
|
cycle
|
|
endif
|
|
|
|
c Checking if the record needed for j is in the memory
|
|
if (j.lt.kmin) then
|
|
c read(16,rec=j) scr(iabci+ni*recln+1:
|
|
c &iabci+(ni+1)*recln)
|
|
call getlst(16,(j-1)*recperocc+1,scr(iabci+ni*recln+1),recln)
|
|
inj=.false.
|
|
else
|
|
inj=.true.
|
|
endif
|
|
|
|
do i=1,j-1
|
|
ef=nval*(nval-1)/2
|
|
ij=ij+1
|
|
ik=(k-1)*(k-2)/2+i
|
|
icurrent=icurrent+1
|
|
if (icurrent.le.irest) cycle
|
|
|
|
c Checking if the record needed for i is in the memory
|
|
if (i.lt.kmin) then
|
|
c read(16,rec=i) scr(iabci+(ni+1)*recln+1:
|
|
c &iabci+(ni+2)*recln)
|
|
call getlst(16,(i-1)*recperocc+1,scr(iabci+(ni+1)*recln+1),
|
|
& recln)
|
|
ini=.false.
|
|
else
|
|
ini=.true.
|
|
endif
|
|
|
|
c Calculating taaa
|
|
c vvvoa
|
|
if (ini) then
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&scr(it2list1+(jk-1)*nval**2+1),nval,scr(iabci+(i-kmin)*recln+1),
|
|
&ef,0.d0,scr(its+1),nval)
|
|
else
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&scr(it2list1+(jk-1)*nval**2+1),nval,scr(iabci+(ni+1)*recln+1),ef,
|
|
&0.d0,scr(its+1),nval)
|
|
endif
|
|
|
|
if (inj) then
|
|
call dgemm('n','t',nval,ef,nval,-1.d0,
|
|
&scr(it2list1+(ik-1)*nval**2+1),nval,scr(iabci+(j-kmin)*recln+1),
|
|
&ef,1.d0,scr(its+1),nval)
|
|
else
|
|
call dgemm('n','t',nval,ef,nval,-1.d0,
|
|
&scr(it2list1+(ik-1)*nval**2+1),nval,scr(iabci+ni*recln+1),ef,
|
|
&1.d0,scr(its+1),nval)
|
|
endif
|
|
|
|
call dgemm('n','t',nval,ef,nval,1.d0,
|
|
&scr(it2list1+(ij-1)*nval**2+1),nval,scr(iabci+(k-kmin)*recln+1),
|
|
&ef,1.d0,scr(its+1),nval)
|
|
c voooa
|
|
call dgemm('n','t',nval,ef,nal,-1.d0,
|
|
&scr(ivooo+(jk-1)*nval*nal+1),nval,scr(it2list2+(i-1)*nal*ef+1),
|
|
&ef,1.d0,scr(its+1),nval)
|
|
|
|
call dgemm('n','t',nval,ef,nal,1.d0,
|
|
&scr(ivooo+(ik-1)*nval*nal+1),nval,scr(it2list2+(j-1)*nal*ef+1),
|
|
&ef,1.d0,scr(its+1),nval)
|
|
|
|
call dgemm('n','t',nval,ef,nal,-1.d0,
|
|
&scr(ivooo+(ij-1)*nval*nal+1),nval,scr(it2list2+(k-1)*nal*ef+1),
|
|
&ef,1.d0,scr(its+1),nval)
|
|
|
|
|
|
c Antisymmetrizing and building Waaa
|
|
c
|
|
C$OMP PARALLEL DO Schedule(Dynamic) Default(Shared)
|
|
C$OMP& PRIVATE(abc,a,b,c,ac,ab,bc)
|
|
do c=1,nval
|
|
do b=1,c-1
|
|
bc=(c-1)*(c-2)/2+b
|
|
do a=1,b-1
|
|
ac=(c-1)*(c-2)/2+a
|
|
ab=(b-1)*(b-2)/2+a
|
|
abc=(c-1)*(c-2)*(c-3)/6+(b-1)*(b-2)/2+a
|
|
|
|
c T(a,a,a)
|
|
scr(it+abc)=(scr(its+(bc-1)*nval+a)-
|
|
&scr(its+(ac-1)*nval+b)+scr(its+(ab-1)*nval+c))
|