      subroutine disint
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/dim/iadri ; integer(8) iadri
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
 
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
     *,i2221,i2223,ie2221,ie2223,l2221,l2223,le2221,le2223
     *,i2222,ie2222,l2222,le2222
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *,numt(maxorb),nump(maxorb),nv
     *,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *,ygmono,ygddci,ygddc2,ygcas,ygtous
      character*4 gener
c      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
c     *,iodro(maxorb*2)
      common/espa2/ inti(1024,22),intj(1024,22),intk(1024,22),
     *intl(1024,22),aaint(1024,22)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      common/test/itest(100)
      common/pert/schift,damp,ypertu,ycaspert
      common/dispre/ivvvv1,ioooo2,ivovo3,ivvoo4,
     *iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12
     *,icovv13,icvov14,icvoo15,icovo16
     *,icooo17,iccov18,icocv19,iccco20,icccv21,icccc22
      common/opt/ihab,calcul
      dimension itypi(3,3,3,3)
      character*3 calcul
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      logical*1 bidia
      common/stp/stop
      character*8 stop
      common/c66/ y66(3,3,3,3),ye66(3,3,3,3)
      dimension nb123(3)
      integer(8) ilimi,ilimi4,nintot,nintot4,nint
      common/l0/ilimi,ilimi4,nintot,nintot4,nint,ycl
      common/pr/nprint,mprint(10)
      integer(8) nie
      dimension a63(3)
      common/wcl63_4/ aaint63_4(3,4096),m,nb_ind,
     *nint4_1_1,nint4_1_2,nint4_2_1,nint4_2_2,nint4_3,nint4_4
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |inti intj intk intl aaint
c
c
      yw=.false.
      yw1=.false.
      open(27,file='CDI_INT0',status='UNKNOWN',form='UNFORMATTED')
      open(33,file='CDE_INT0',status='UNKNOWN',form='UNFORMATTED')
      if(irest.eq.1.or.irest.eq.2) then
         call disst2
         return
      endif
      if(iadri*4.lt.1024*15*6) stop' iadri pas assez grand dans disint'
c
 
      write(6,*)' '
      write(6,*)'================================================ '
      write(6,*)'     Distribution des integrales par classes'
      write(6,*)'     oooo vvvv oovv CCvv ...'
      write(6,*)'================================================ '
      write(6,*)' '
      call flush(6)
      do i=1,3
         do j=1,3
            do k=1,3
               do l=1,3
                  itypi(l,k,j,i)=0
               enddo
            enddo
         enddo
      enddo
      i3333=0
      ie3333=0
      i1111=0
      ie1111=0
      i3131=0
      ie3131=0
      i3311=0
      ie3311=0
      i3331=0
      ie3331=0
      i1113=0
      ie1113=0
      i0000=0
      ie0000=0
      i2333=0
      ie2333=0
      ie3231=0
      i2000=0
      ie2000=0
      i2233=0
      ie2233=0
      i2323=0
      ie2323=0
      i1122=0
      ie1122=0
      i1212=0
      ie1212=0
 
      i2133=0
      ie2133=0
      i2313=0
      ie2313=0
      i2311=0
      ie2311=0
      i2131=0
      ie2131=0
      i2111=0
      ie2111=0
      i2123=0
      ie2123=0
      i2213=0
      ie2213=0
 
      l3333=0
      le3333=0
      l1111=0
      le1111=0
      l3131=0
      le3131=0
      l3311=0
      le3311=0
      l3331=0
      le3331=0
      l1113=0
      le1113=0
      l0000=0
      le0000=0
      l2333=0
      le2333=0
      l2000=0
      le2000=0
      l2233=0
      le2233=0
      l2323=0
      le2323=0
      l1122=0
      le1122=0
      l1212=0
      le1212=0
 
      l2133=0
      le2133=0
      l2313=0
      le2313=0
      l2311=0
      le2311=0
      l2131=0
      le2131=0
      l2111=0
      le2111=0
      l2123=0
      le2123=0
      l2213=0
      le2213=0
 
      i2221=0
      ie2221=0
      l2221=0
      le2221=0
      i2223=0
      ie2223=0
      l2223=0
      le2223=0
      i2222=0
      ie2222=0
      l2222=0
      le2222=0
 
      if(ygcas) goto 20
      itypi(3,3,3,3)=ivvvv1
      itypi(1,1,1,1)=ioooo2
      itypi(3,1,3,1)=ivovo3
      itypi(1,3,1,3)=ivovo3
      itypi(3,3,1,1)=ivvoo4
      itypi(1,1,3,3)=ivvoo4
      itypi(1,3,3,1)=ivoov7
      itypi(3,1,1,3)=ivoov7
      itypi(3,3,3,1)=iovvo5
      itypi(3,3,1,3)=iovvo5
      itypi(3,1,3,3)=iovvo5
      itypi(1,3,3,3)=iovvo5
      itypi(1,1,1,3)=ivooo6
      itypi(1,1,3,1)=ivooo6
      itypi(1,3,1,1)=ivooo6
      itypi(3,1,1,1)=ivooo6
      itypi(2,3,3,3)=ivvvc8
      itypi(3,2,3,3)=ivvvc8
      itypi(3,3,2,3)=ivvvc8
      itypi(3,3,3,2)=ivvvc8
      if(itest(38).eq.1) then
         itypi(2,2,3,3)=iccvv9
         itypi(2,3,2,3)=icvcv10
         itypi(3,2,3,2)=icvcv10
      endif
      if(itest(39).eq.1) then
         itypi(1,1,2,2)=ioocc11
         itypi(1,2,1,2)=iococ12
         itypi(2,1,2,1)=iococ12
      endif
      if(itest(40).eq.1) then
         itypi(1,2,3,3)=icovv13
         itypi(1,3,2,3)=icvov14
         itypi(3,1,3,2)=icvov14
      endif
      if(itest(41).eq.1) then
         itypi(1,1,2,3)=icvoo15
         itypi(1,2,1,3)=icovo16
      endif
      if(itest(42).eq.1) then
         itypi(1,1,1,2)=icooo17
         itypi(1,1,2,1)=icooo17
         itypi(1,2,1,1)=icooo17
         itypi(2,1,1,1)=icooo17
      endif
      if(itest(43).eq.1) then
         itypi(1,2,2,3)=iccov18
         itypi(1,2,3,2)=icocv19
         itypi(2,1,2,3)=icocv19
      endif
      if(itest(60).eq.1) then
         itypi(1,2,2,2)=iccco20
         itypi(2,1,2,2)=iccco20
      endif
      if(itest(61).eq.1) then
         itypi(2,2,2,3)=icccv21
      endif
      if(ygmono) then
         itypi(3,3,3,3)=-itypi(3,3,3,3)
         itypi(1,1,1,1)=-itypi(1,1,1,1)
         itypi(3,3,3,1)=-itypi(3,3,3,1)
         itypi(3,3,1,3)=-itypi(3,3,1,3)
         itypi(3,1,3,3)=-itypi(3,1,3,3)
         itypi(1,3,3,3)=-itypi(1,3,3,3)
         itypi(1,1,1,3)=-itypi(1,1,1,3)
         itypi(1,1,3,1)=-itypi(1,1,3,1)
         itypi(1,3,1,1)=-itypi(1,3,1,1)
         itypi(3,1,1,1)=-itypi(3,1,1,1)
         itypi(2,3,3,3)=-itypi(2,3,3,3)
         itypi(3,2,3,3)=-itypi(3,2,3,3)
         itypi(3,3,2,3)=-itypi(3,3,2,3)
         itypi(3,3,3,2)=-itypi(3,3,3,2)
         itypi(2,1,1,1)=-100
         itypi(1,2,1,1)=-100
         itypi(1,1,2,1)=-100
         itypi(1,1,1,2)=-100
      endif
      open(28,file='CDI_3333',status='UNKNOWN',form='UNFORMATTED')
      open(29,file='CDI_1111',status='UNKNOWN',form='UNFORMATTED')
      open(30,file='CDI_3131',status='UNKNOWN',form='UNFORMATTED')
      open(31,file='CDI_3311',status='UNKNOWN',form='UNFORMATTED')
      open(42,file='CDI_3331',status='UNKNOWN',form='UNFORMATTED')
      open(41,file='CDI_1113',status='UNKNOWN',form='UNFORMATTED')
      open(43,file='CDI_2333',status='UNKNOWN',form='UNFORMATTED')
      if(itest(38).eq.1) then
         open(34,file='CDI_2233',status='UNKNOWN',form='UNFORMATTED')
         open(35,file='CDI_2323',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(39).eq.1) then
         open(36,file='CDI_1122',status='UNKNOWN',form='UNFORMATTED')
         open(37,file='CDI_1212',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(40).eq.1) then
         open(38,file='CDI_2133',status='UNKNOWN',form='UNFORMATTED')
         open(50,file='CDI_2313',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(41).eq.1) then
         open(51,file='CDI_2311',status='UNKNOWN',form='UNFORMATTED')
         open(52,file='CDI_2131',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(42).eq.1) then
         open(53,file='CDI_2111',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(43).eq.1) then
         open(54,file='CDI_2213',status='UNKNOWN',form='UNFORMATTED')
         open(55,file='CDI_2123',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(60).eq.1) then
         open(56,file='CDI_2221',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(61).eq.1) then
         open(57,file='CDI_2223',status='UNKNOWN',form='UNFORMATTED')
      endif
 20   continue
      if(itest(62).eq.1) then
         itypi(2,2,2,2)=icccc22
         open(58,file='CDI_2222',status='UNKNOWN',form='UNFORMATTED')
      endif
c
c-------------------------------------------
c      lecture
c-------------------------------------------
c
      jcpu=itemps(idum)
      call liri00
      ilimi=0
      ilimi4=0
      nintot4=0
      nintot=0
 1    continue
      call lirin0(i,k,j,l,a)
      !print'(a,4i4,f12.8)','lue',i,k,j,l,a
      if(j.eq.0) goto 2
      nintot=nintot+1
      if(a.eq.0.d0) goto 1
c--   on reordonne les indices en TCP
      if(itype(i).gt.itype(k)) then
         iii=i
         i=k
         k=iii
      endif
      if(itype(j).gt.itype(l)) then
         iii=j
         j=l
         l=iii
      endif
      if(itype(i).gt.itype(j).or.(itype(i).eq.itype(j).and.
     *itype(k).gt.itype(l))) then
         iii=i
         i=j
         j=iii
         iii=k
         k=l
         l=iii
      endif
      iti=itype(i)
      itj=itype(j)
      itk=itype(k)
      itl=itype(l)
      if(ygcas) then
         if(iti.ne.2.or.itj.ne.2.or.itk.ne.2
     *   .or.itl.ne.2) goto 1
      endif
      if(ypertu.and.ycaspert) then
         do kkk=1,3
            nb123(kkk)=0
         enddo
         nb123(iti)=nb123(iti)+1
         nb123(itj)=nb123(itj)+1
         nb123(itk)=nb123(itk)+1
         nb123(itl)=nb123(itl)+1
         if(nb123(2).lt.2) goto 1
         if(nb123(1).gt.1) goto 1
         if(nb123(3).gt.1) goto 1
      endif
      if(yw1) then
         ii=i
         jj=j
         kk=k
         ll=l
         call reorint(ii,jj,kk,ll)
         write(6,'(a,4i4,f12.8)')'disint int lue',ii,jj,kk,ll,a
      endif
      jtypi=itypi(iti,itj,itk,itl)
      if(jtypi.lt.0) then
         if(i.ne.k.and.j.ne.l) goto 1
         jtypi=-jtypi
         if(jtypi.eq.100) jtypi=0
      endif
      if(i.eq.k.or.j.eq.l) then
         if(i.eq.k.and.j.eq.l) goto 1
         if(jtypi.le.22) goto 5000
         call disin1(l0000,i0000,27,i,j,k,l,a,7)
c         print*,'i=k or j=l',i,j,k,l
         goto 1
      endif
 5000 continue
c     <vvvv>
      if(jtypi.eq.1) then
c         print*,'vvvv direct',i,j,k,l,a
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,-1,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,-1,1,a)
         call disin1(l3333,i3333,28,i,j,k,l,a,1)
c         write(28,*)i,j,k,l,a
c         i3333=i3333+1
         if(yw)write(6,*)'disint ecr 28'
c     <oooo>
      else if(jtypi.eq.2) then
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,1,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,1,1,a)
         isgn=1
         if(mod(itorbc(i)+itorbc(k),2).eq.0)isgn=-isgn
         if(mod(itorbc(j)+itorbc(l),2).eq.0)isgn=-isgn
         call disin1(l1111,i1111,29,i,j,k,l,isgn*a,2)
c        write(29,*)i,j,k,l,isgn*a
c         i1111=i1111+1
         if(yw)write(6,*)'disint ecr 29'
c     <vovo>
      else if(jtypi.eq.3) then
         isgn=1
         if(iti.eq.1) then
            if(mod(itorbc(i)+itorbc(k),2).eq.0)isgn=-isgn
            if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,-1,1,a)
            if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,1,1,a)
         else
            if(mod(itorbc(j)+itorbc(l),2).eq.0)isgn=-isgn
            if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,-1,1,a)
            if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,1,1,a)
         endif
         call disin1(l3131,i3131,30,i,j,k,l,isgn*a,3)
c         write(30,*)i,j,k,l,isgn*a
c         i3131=i3131+1
         if(yw)write(6,*)'disint ecr 30'
c     <vvoo>
      else if(jtypi.eq.4) then
         isgn=1
         if(iti.eq.3)then
            if(mod(itorbc(k)+itorbc(l),2).eq.1)isgn=-isgn
            call disin1(l3311,i3311,31,k,l,i,j,isgn*a,4)
            write(6,*) '1INT3311',k,l,i,j,a*isgn
            if(yw)write(6,*)'31 int sgn',k,l,i,j,isgn
         endif
         if(iti.eq.1) then
            if(mod(itorbc(i)+itorbc(j),2).eq.1)isgn=-isgn
            call disin1(l3311,i3311,31,i,j,k,l,isgn*a,4)
            if(yw)write(6,*)'31 int sgn',i,j,k,l,isgn
         endif
c         i3311=i3311+1
         if(yw)write(6,*)'disint ecr 31'
      else if(jtypi.eq.7) then
         isgn=1
         if(iti.eq.3) then
            if(mod(itorbc(k)+itorbc(j),2).eq.1)isgn=-isgn
            call disin1(l3311,i3311,31,k,j,i,l,isgn*a,4)
            write(6,*) '3INT3311',k,j,i,l,a*isgn
            if(yw)write(6,*)'31 int sgn',k,j,i,l,isgn
         endif
         if(iti.eq.1)then
            if(mod(itorbc(i)+itorbc(l),2).eq.1)isgn=-isgn
            call disin1(l3311,i3311,31,i,l,k,j,isgn*a,4)
            write(6,*) '4INT3311',i,l,k,j,a*isgn
            if(yw)write(6,*)'31 int sgn',i,l,k,j,isgn
         endif
c         i3311=i3311+1
         if(yw)write(6,*)'disint ecr 31'
c     <vvvo>
c        signe : dans abci, le mono est -c et le di est i-ab
c        en occupation, ils s'ecrivent :  xxxixxxxxc
c                                         xxx xxxxxab
c        on ramene a en i ce qui fait sauter ninac-i electrons
      else if(jtypi.eq.5) then
c        print*,'vvvo direct',i,j,k,l
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,1,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,1,1,a)
         if(iti.eq.1)then
            isgn=(1-2*mod(ninac-itorbc(i),2))
            call disin1
     *      (l3331,i3331,42,l,k,j,i,a*isgn,5)
         endif
         if(itj.eq.1)then
            isgn=(1-2*mod(ninac-itorbc(j),2))
            call disin1
     *      (l3331,i3331,42,k,l,i,j,a*isgn,5)
         endif
         if(itk.eq.1) then
            isgn=(1-2*mod(ninac-itorbc(k),2))
            call disin1
     *      (l3331,i3331,42,j,i,l,k,a*isgn,5)
         endif
         if(itl.eq.1) then
            isgn=(1-2*mod(ninac-itorbc(l),2))
            call disin1
     *      (l3331,i3331,42,i,j,k,l,a*isgn,5)
         endif
         if(yw)write(6,*)'disint ecr 42'
c     <ooov>
      else if(jtypi.eq.6) then
c        write(75,*)'disint i,j,k,l',i,j,k,l,'$'
c        call scril
c        print*,'ooov direct',i,j,k,l
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,0,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,0,1,a)
         if(iti.eq.3) then
            isgn=1
            if(mod(iabs(itorbc(j)-itorbc(l))+1,2).eq.1) isgn=-isgn
            if(mod(ninac-itorbc(k),2).eq.1) isgn=-isgn
            call disin1(l1113,i1113,41,l,k,j,i,isgn*a,6)
c            write(41,*)l,k,j,i,a*isgn
         endif
         if(itj.eq.3) then
            isgn=1
            if(mod(iabs(itorbc(i)-itorbc(k))+1,2).eq.1) isgn=-isgn
            if(mod(ninac-itorbc(l),2).eq.1) isgn=-isgn
            call disin1(l1113,i1113,41,k,l,i,j,isgn*a,6)
c            write(41,*)k,l,i,j,a*isgn
         endif
         if(itk.eq.3) then
            isgn=1
            if(mod(iabs(itorbc(l)-itorbc(j))+1,2).eq.1) isgn=-isgn
            if(mod(ninac-itorbc(i),2).eq.1) isgn=-isgn
            call disin1(l1113,i1113,41,j,i,l,k,isgn*a,6)
c            write(41,*)j,i,l,k,a*isgn
         endif
         if(itl.eq.3) then
            isgn=1
            if(mod(iabs(itorbc(k)-itorbc(i))+1,2).eq.1) isgn=-isgn
            if(mod(ninac-itorbc(j),2).eq.1) isgn=-isgn
            call disin1(l1113,i1113,41,i,j,k,l,isgn*a,6)
c            write(41,*)i,j,k,l,a*isgn
         endif
         if(yw)write(6,*)'disint ecr 41'
c     <vvvC>
      else if(jtypi.eq.8) then
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,0,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,0,1,a)
c        print*,'coucou8' ,i,j,k,l
         if(iti.eq.2) then
            call disin1(l2333,i2333,43,i,j,k,l,a,8)
         else if(itj.eq.2) then
            call disin1(l2333,i2333,43,j,i,l,k,a,8)
         else if(itk.eq.2) then
            call disin1(l2333,i2333,43,k,j,i,l,a,8)
         else if(itl.eq.2) then
            call disin1(l2333,i2333,43,l,k,j,i,a,8)
         endif
c     <CCvv>
      else if(jtypi.eq.9) then
         if(itest(38).eq.1)call disin1(l2233,i2233,34,i,j,k,l,a,9)
c     <CvCv>
      else if(jtypi.eq.10) then
         if(itest(38).eq.1) then
            if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
            if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
            if(iti.eq.2) then
               call disin1(l2323,i2323,35,i,j,k,l,a,10)
            else
               call disin1(l2323,i2323,35,j,i,l,k,a,10)
            endif
         endif
c     <ooCC>
      else if(jtypi.eq.11) then
c            print'(a20,4i3,f12.8)','dcoucou11' ,k,l,i,j,a
         if(itest(39).eq.1)call disin1(l1122,i1122,36,k,l,i,j,a,11)
c     <oCoC>
      else if(jtypi.eq.12) then
         if(itest(39).eq.1) then
            if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
            if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
c            print'(a20,4i3,f12.8)','dcoucou12' ,i,j,k,l,a
            if(iti.eq.2) then
               call disin1(l1212,i1212,37,i,j,k,l,a,12)
            else
               call disin1(l1212,i1212,37,j,i,l,k,a,12)
            endif
         endif
c     <oCvv>
      else if(jtypi.eq.13) then
         call disin1(l2133,i2133,38,j,i,l,k,a,13)
c     <ovCv>
      else if(jtypi.eq.14) then
         if(yw)print'(a20,4i3,f12.8)','dcoucou14' ,k,l,i,j,a
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         call disin1(l2313,i2313,50,k,l,i,j,a,14)
c     <ooCv>
      else if(jtypi.eq.15) then
         call disin1(l2311,i2311,51,k,l,i,j,a,15)
c     <oCov>
      else if(jtypi.eq.16) then
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         call disin1(l2131,i2131,52,j,i,l,k,a,16)
c     <oooC>
c      else if(jtypi.eq.17.and.i.ne.k) then
      else if(jtypi.eq.17) then
c         if(i.eq.j) then
c            print'(a20,4i3,f12.8)','Coucou17' ,l,i,j,k,a
c            call disin1(l2111,i2111,53,l,i,j,k,a,17)
c         else
c            print'(a20,4i3,f12.8)','coucou17' ,l,k,j,i,a
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         call disin1(l2111,i2111,53,l,k,j,i,a,17)
c         endif
c     <oCCv>
      else if(jtypi.eq.18) then
         if(yw)print'(a20,4i3,f12.8)','coucou18' ,k,j,i,l,a
         call disin1(l2213,i2213,54,k,j,i,l,a,18)
c     <oCvC>
      else if(jtypi.eq.19) then
         if(yw)print'(a20,4i3,f12.8)','dcoucou19' ,j,i,l,k,a
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         call disin1(l2123,i2123,55,j,i,l,k,a,19)
c     <CCCo>
      else if(jtypi.eq.20) then
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         call disin1(l2221,i2221,56,l,k,j,i,a,20)
c     <CCCv>
      else if(jtypi.eq.21) then
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         call disin1(l2223,i2223,57,i,j,k,l,a,21)
c     <CCCC>
      else if(jtypi.eq.22) then
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         call disin1(l2222,i2222,58,i,j,k,l,a,22)
      else
         if(yw)write(6,*)'disint ecr 27',i,j,k,l,a
         if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,1,a)
         if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,1,a)
         if(yw)print'(a20,4i3,f12.8,i6)',
     *   'generales dir',i,j,k,l,a,jtypi
         call disin1(l0000,i0000,27,i,j,k,l,a,7)
      endif
      goto 1
 2    continue
      call disin2(7,27)
      if(ygcas) goto 22
      call disin2(1,28)
      call disin2(2,29)
      call disin2(3,30)
      call disin2(4,31)
      call disin2(5,42)
      call disin2(6,41)
      call disin2(8,43)
      close(28)
      close(29)
      close(30)
      close(31)
      close(42)
      close(41)
      close(43)
      if(itest(38).eq.1) then
         call disin2(9,34)
         call disin2(10,35)
         close(34)
         close(35)
      endif
      if(itest(39).eq.1) then
         call disin2(11,36)
         call disin2(12,37)
         close(36)
         close(37)
      endif
      if(itest(40).eq.1) then
         call disin2(13,38)
         call disin2(14,50)
         close(38)
         close(50)
      endif
      if(itest(41).eq.1) then
         call disin2(15,51)
         call disin2(16,52)
         close(51)
         close(52)
      endif
      if(itest(42).eq.1) then
         call disin2(17,53)
         close(53)
      endif
      if(itest(43).eq.1) then
         call disin2(18,54)
         call disin2(19,55)
         close(54)
         close(55)
      endif
      if(itest(60).eq.1) then
         call disin2(20,56)
         close(56)
      endif
      if(itest(61).eq.1) then
         call disin2(21,57)
         close(57)
      endif
      if(itest(62).eq.1) then
         call disin2(22,58)
         close(58)
      endif
 22   continue
      jcpu1=itemps(idum)-jcpu
      write(6,*)'distribution des integrales directes -> cpu',jcpu1
      call flush(6)
c
c---------------------------------------
c     lecture des integrales dir + ech
c---------------------------------------
c
      jcpu=itemps(idum)
      if(ygcas) goto 21
      if(itest(43).eq.1) then
 
         itypi(1,2,2,3)=0
         itypi(1,2,3,2)=0
         itypi(2,1,2,3)=0
         itypi(1,3,2,2)=iccov18
         itypi(2,1,2,3)=icocv19
         itypi(1,2,2,3)=icocv19
         if(itest(60).eq.1) then
            itypi(2,1,2,2)=iccco20
         endif
      endif
      open(34,file='CDE_3333',status='UNKNOWN',form='UNFORMATTED')
      open(35,file='CDE_1111',status='UNKNOWN',form='UNFORMATTED')
      open(36,file='CDE_3131',status='UNKNOWN',form='UNFORMATTED')
      open(37,file='CDE_3311',status='UNKNOWN',form='UNFORMATTED')
      open(38,file='CDE_3331',status='UNKNOWN',form='UNFORMATTED')
      open(43,file='CDE_1113',status='UNKNOWN',form='UNFORMATTED')
      open(28,file='CDE_2333',status='UNKNOWN',form='UNFORMATTED')
      if(itest(38).eq.1) then
         open(29,file='CDE_2233',status='UNKNOWN',form='UNFORMATTED')
         open(30,file='CDE_2323',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(39).eq.1) then
         open(31,file='CDE_1122',status='UNKNOWN',form='UNFORMATTED')
         open(41,file='CDE_1212',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(40).eq.1) then
         open(42,file='CDE_2133',status='UNKNOWN',form='UNFORMATTED')
         open(50,file='CDE_2313',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(41).eq.1) then
         open(51,file='CDE_2311',status='UNKNOWN',form='UNFORMATTED')
         open(52,file='CDE_2131',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(42).eq.1) then
         open(53,file='CDE_2111',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(43).eq.1) then
         open(54,file='CDE_2213',status='UNKNOWN',form='UNFORMATTED')
         open(55,file='CDE_2123',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(60).eq.1) then
         open(56,file='CDE_2221',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(61).eq.1) then
         open(57,file='CDE_2223',status='UNKNOWN',form='UNFORMATTED')
      endif
 21   continue
      if(itest(62).eq.1) then
         open(58,file='CDE_2222',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(63)==0) then
         call liri0e
         n_dir_ech=1
      else
         call liri00
         ilimi=0
         ilimi4=0
         nintot4=0
         nintot=0
      endif
c4    continue
      if(nprint.ge.1) print*,'nintoe',nintoe
      nie=0
!
! Boucle generale sur les integrales d'echange
!
      nb_ind=min(norb,4)
      do
         if(itest(63)==0) then
!         Print*,'n_dir_ech',n_dir_ech
!           itest(63)==0 : on lit une integrale d'echange
            nie=nie+1
            if(nie>nintoe) exit
!            print*,'nie',nie,nintoe
            call lirine(ii,jj,kk,ll,aa)
!            print'(a,4i4,f12.8)','lueech',ii,jj,kk,ll,aa
            nlec=1
         else
! on lit n_dir integrales directes
! (n_dir==3 si 4 indices differents, 2 si 3 indices differents)
! on les stocke dans a63(1:2) ou a63(1:2)
! nlec : nb d'int dir-ech existantes pour le jeu d'indices
! ii1,kk1,jj1,ll1
            call lirin0(ii2,kk2,jj2,ll2,a63(1))
            if(ii2==0) goto 3
            ncas=nb_ind-1
            if(ncas<2) exit
            if(ncas==3) then
               ii1=ii2
               jj1=jj2
               kk1=kk2
               ll1=ll2
!              print'(a,4i4,4f12.8)','<LUEECH01>',ii2,jj2,kk2,ll2,a63(1)
               call lirin0(ii2,kk2,jj2,ll2,a63(2))
!              print'(a,4i4,4f12.8)','<LUEECH02>',ii2,jj2,kk2,ll2,a63(2)
               call lirin0(ii2,kk2,jj2,ll2,a63(3))
!              print'(a,4i4,4f12.8)','<LUEECH03>',ii2,jj2,kk2,ll2,a63(3)
               nlec=3
               n_dir_ech=3
            else
               ii1=jj2
               jj1=ii2
               kk1=ll2
               ll1=kk2
!              print'(a,4i4,4f12.8)','<LUEECH00>',ii2,kk2,jj2,ll2,a63(1)
               call lirin0(ii2,kk2,jj2,ll2,a63(2))
!              print'(a,4i4,4f12.8)','<LUEECH0>',ii2,kk2,jj2,ll2,a63(2)
               nlec=1
               n_dir_ech=1
            endif
!           Print*,'n_dir_ech',n_dir_ech
!
! A ce niveau-la, a63 contient les 3 ou 2 int directes
 
         endif
C      do 4 nie=1,nintoe
!
! Boucle sur le nombre de lectures des integrales
!
! itest(63)==0 nlec==1 (on a lu directement l'int d'echange)
! itest(63)/=0, 4 indices differents nlec==3)
!               (on a lu 3 integrales directes, on les combine pour
!               obtenir 3 int dir-ech)
! itest(63)/=0, 3 indices differents nlec==1)
!               idem, mais on combine 2 int dir pour obtenir 1 dif-ech
 
         do ilec=1,nlec
            if(itest(63)/=0) then
!             print'(a,4i4,4f12.8)','<ii1,jj1,kk1,ll1>',ii1,jj1,kk1,ll1
               if(n_dir_ech==3) then
! cas a 4 indices differents
                  if(ilec==1) then
                     aa=a63(1)-a63(2)
                     ii=ii1
                     jj=jj1
                     kk=kk1
                     ll=ll1
!                    print'(a,4i4,4f12.8)','<LUEECH1>',ii,jj,kk,ll,aa
!     *               ,a63(1:nlec)
                  else if(ilec==2) then
                     aa=a63(3)-a63(2)
                     ii=ii1
                     jj=kk1
                     kk=jj1
                     ll=ll1
!                    print'(a,4i4,4f12.8)','<LUEECH2>',ii,jj,kk,ll,aa
!     *               ,a63(1:nlec)
                  else if(ilec==3) then
                     aa=a63(3)-a63(1)
                     ii=ii1
                     jj=ll1
                     kk=jj1
                     ll=kk1
!                    print'(a,4i4,4f12.8)','<LUEECH3>',ii,jj,kk,ll,aa
!     *               ,a63(1:nlec)
                  endif
               else
! cas a 3 indices differents
                  aa=a63(1)-a63(2)
                  ii=ii1
                  jj=jj1
                  kk=kk1
                  ll=ll1
!                 print'(a,4i4,3f12.8,2i4)','<LUEECH4>',ii,jj,kk,ll,aa
!     *            ,a63(1:2)
!     *            ,ilec,nlec
c
c--               signe : ii et kk sont les indices communs
!                 singne - si le saut jj --> ll se fait par dessus ii
                  iii=isbrot(ii)
                  jjj=isbrot(jj)
                  lll=isbrot(ll)
                  isgn=1
                  if((jjj-iii)*(lll-iii).lt.0) isgn=-isgn
c--               signe : - si ii est inactive
                  if(itype(ii).eq.1) isgn=-isgn
                  aa=isgn*aa
!                  print'(a,10i4)','isgn',ii,jj,kk,ll,itype(ii),isgn
               endif
            endif
!
! A ce niveau, ii,jj,kk,ll,aa contient l'integrale dir-ech
            if(yw)print*,'ygcas',ygcas,gener,ii,jj,kk,ll,aa
            if(ygcas) then
               if(itype(ii).ne.2.or.itype(jj).ne.2.or.itype(kk).ne.2
     *         .or.itype(ll).ne.2) goto 4
            endif
            if(ypertu.and.ycaspert) then
               do kkk=1,3
                  nb123(kkk)=0
               enddo
               nb123(itype(ii))=nb123(itype(ii))+1
               nb123(itype(jj))=nb123(itype(jj))+1
               nb123(itype(kk))=nb123(itype(kk))+1
               nb123(itype(ll))=nb123(itype(ll))+1
               if(nb123(2).lt.2) goto 4
               if(nb123(1).gt.1) goto 4
               if(nb123(3).gt.1) goto 4
            endif
            i=ii
            j=jj
            k=kk
            l=ll
            a=aa
            if(yw1) then
               a8=a
               i8=i
               j8=j
               k8=k
               l8=l
               if(i8.lt.j8) then
                  iii=i8
                  i8=j8
                  j8=iii
                  a8=-a8
               endif
               if(k8.lt.l8) then
                  iii=k8
                  k8=l8
                  l8=iii
                  a8=-a8
               endif
               if(i8.lt.k8.or.(i8.eq.k8.and.j8.lt.l8)) then
                  iii=i8
                  i8=k8
                  k8=iii
                  iii=j8
                  j8=l8
                  l8=iii
               endif
               write(75,*)'1 disint int ech lue',i8,j8,k8,l8,a8,'$'
               call scril
            endif
c
c--   ordonnancement des indices en TCP
            if(i.eq.k) then
               if(itype(ll).lt.itype(jj)) then
                  j=ll
                  l=jj
               endif
            else
               if(itype(ii).le.itype(jj)) then
                  i=ii
                  j=jj
                  a=aa
               else
                  i=jj
                  j=ii
                  a=-aa
               endif
               if(itype(kk).le.itype(ll)) then
                  k=kk
                  l=ll
               else
                  k=ll
                  l=kk
                  a=-a
               endif
            endif
            if(i.eq.0.or.i.eq.0.or.i.eq.0.or.i.eq.0) then
               print *,'I,J,K,L',i,j,k,l,ii,jj,kk,ll
               print *,'I,J,K,L',iii11,jjj11,kkk11,lll11
               print *,'nie',nie
            endif
            if(itype(k).lt.itype(i).or.(itype(k).eq.itype(i)
     *      .and.itype(l).lt.itype(j))) then
               iii=i
               i=k
               k=iii
               jjj=j
               j=l
               l=jjj
            endif
c
c      if(a.eq.0.d0) goto 4
            if(yw1) then
               a8=a
               i8=i
               j8=j
               k8=k
               l8=l
               if(i8.lt.j8) then
                  iii=i8
                  i8=j8
                  j8=iii
                  a8=-a8
               endif
               if(k8.lt.l8) then
                  iii=k8
                  k8=l8
                  l8=iii
                  a8=-a8
               endif
               if(i8.lt.k8.or.(i8.eq.k8.and.j8.lt.l8)) then
                  iii=i8
                  i8=k8
                  k8=iii
                  iii=j8
                  j8=l8
                  l8=iii
               endif
               write(75,*)'2 disint int ech lue',i8,j8,k8,l8,a8,'$'
               call scril
               if(j.eq.l)print*,'J=L'
            endif
            iti=itype(i)
            itj=itype(j)
            itk=itype(k)
            itl=itype(l)
            itii=itype(ii)
 
 
            itjj=itype(jj)
            itkk=itype(kk)
            itll=itype(ll)
            jtypi=itypi(iti,itj,itk,itl)
            if(yw)print*,'jtypi',jtypi
            if(jtypi.lt.0) then
               if(i.ne.k.and.j.ne.l.and.i.ne.l.and.j.ne.k) goto 4
               jtypi=-jtypi
               if(jtypi.eq.100) jtypi=0
            endif
c     <vvvv>
            if(jtypi.eq.1) then
c     print*,'vvvv',i,j,k,l,a
               if(i.eq.k) then
                  call fockdd(i,j,l,iti,itj,itl,-1,2,a)
c           i=k on a change le signe dans stech3 si i est entre j et l
c           il ne fallait pas
                  if((isbrot(j)-isbrot(i))*(isbrot(l)-isbrot(i)).lt.0) a
     &            =-a
               endif
               call disin1(le3333,ie3333,34,i,j,k,l,a,1)
c         write(34,*)i,j,k,l,a
c         ie3333=ie3333+1
c     <oooo>
            else if(jtypi.eq.2) then
               isgn=1
c     print*,'oooo',i,j,k,l
               if(i.eq.k) then
                  call fockdd(i,j,l,iti,itj,itl,-1,2,a)
                  isgn=-1
c           i=k on a change le signe dans stech3 si i est entre j et l
c           il ne fallait pas
                  if((itorbc(j)-itorbc(i))*(itorbc(l)-itorbc(i)).lt.0)
     *            a=-a
               endif
               if(mod(itorbc(i)+itorbc(k),2).eq.0)isgn=-isgn
               if(mod(itorbc(j)+itorbc(l),2).eq.0)isgn=-isgn
               call disin1(le1111,ie1111,35,i,j,k,l,isgn*a,2)
c     <vovo>
            else if(jtypi.eq.3) then
c     print*,'vovo',i,j,k,l
               isgn=1
               if(iti.eq.1) then
                  if(i.eq.k) isgn=-1
                  if(mod(itorbc(i)+itorbc(k),2).eq.0)isgn=-isgn
                  if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,isgn,2,a)
                  if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,-isgn,2,a)
                  call disin1(le3131,ie3131,36,j,i,l,k,isgn*a,3)
               else
                  if(mod(itorbc(j)+itorbc(l),2).eq.0)isgn=-isgn
                  if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,-isgn,2,a)
                  if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,isgn,2,a)
                  call disin1(le3131,ie3131,36,i,j,k,l,isgn*a,3)
               endif
               if(yw)write(6,*)'disint ecr 36'
            else if(jtypi.eq.7) then
c        print*,'voov',i,j,k,l
               isgn=-1
               if(iti.eq.1) then
                  if(mod(itorbc(i)+itorbc(l),2).eq.0)isgn=-isgn
               else
                  if(mod(itorbc(j)+itorbc(k),2).eq.0)isgn=-isgn
               endif
               if(i.eq.l)call fockdd(i,j,k,iti,itj,itk,-isgn,2,a)
               if(j.eq.k)call fockdd(j,i,l,itj,iti,itl,isgn,2,a)
               call disin1(le3131,ie3131,36,i,j,l,k,isgn*a,3)
               if(yw)write(6,*)'disint ecr 36'
c     <vvoo>
            else if(jtypi.eq.4) then
               isgn=1
               if(iti.eq.3) then
                  if(mod(itorbc(k)+itorbc(l),2).eq.0)isgn=-1
                  call disin1(le3311,ie3311,37,k,l,i,j,isgn*a,4)
               endif
               if(iti.eq.1) then
                  if(mod(itorbc(i)+itorbc(j),2).eq.0)isgn=-1
                  call disin1(le3311,ie3311,37,i,j,k,l,isgn*a,4)
               endif
               if(yw)write(6,*)'disint ecr 37'
c     <vvvo>
            else if(jtypi.eq.5) then
c         print*,'vvvo',i,j,k,l
               if(i.eq.k) then
c           signe : alors l'integrale est ecrite vovv soit ajab
c           le saut de j vers b se fait par-dessus ninac-j electrons
c           et forcement par-dessus a
                  isgn=-1
                  ipar=ninac+itorbc(j)
                  if(mod(ipar,2).eq.1) isgn=-isgn
c           signe dans fockdd : si le saut j --> b passe par-dessus a
c           don si b.gt.a   signe -
                  jsgn=1
                  if(l.gt.k) jsgn=-1
                  call fockdd(i,j,l,iti,itj,itl,jsgn,2,a)
                  call disin1(le3331,ie3331,38,k,l,i,j,isgn*a,5)
                  goto 12
               endif
c        signe : dans abci, le mono est t->c et le di est it->ab
c        en occupation, ils s'ecrivent :  xxxixx xxxc
c                                         xxx xx xxxba
c        on ramene b en i ce qui fait sauter ninac-i electrons
c        selon l'ordre t/i on saute le trou t ou non
c        l'effet sur le signe est pris en compte dans gende3 a la
c        generation du determinant it->ab
               if(iti.eq.1) then
                  if(k.lt.l) call disin1(le3331,ie3331,38,
     *            k,l,j,i,-a*(1-2*mod(ninac-itorbc(i),2)),5)
                  if(k.gt.l) call disin1(le3331,ie3331,38,
     *            l,k,j,i,a*(1-2*mod(ninac-itorbc(i),2)),5)
               endif
               if(itj.eq.1) then
                  if(k.lt.l) call disin1(le3331,ie3331,38,
     *            k,l,i,j,a*(1-2*mod(ninac-itorbc(j),2)),5)
                  if(k.gt.l) call disin1(le3331,ie3331,38,
     *            l,k,i,j,-a*(1-2*mod(ninac-itorbc(j),2)),5)
               endif
               if(itk.eq.1) then
                  if(i.lt.j) call disin1(le3331,ie3331,38,
     *            i,j,l,k,-a*(1-2*mod(ninac-itorbc(k),2)),5)
                  if(i.gt.j) call disin1(le3331,ie3331,38,
     *            j,i,l,k,a*(1-2*mod(ninac-itorbc(k),2)),5)
               endif
               if(itl.eq.1) then
                  if(i.lt.j) call disin1(le3331,ie3331,38,
     *            i,j,k,l,a*(1-2*mod(ninac-itorbc(l),2)),5)
                  if(i.gt.j) call disin1(le3331,ie3331,38,
     *            j,i,k,l,-a*(1-2*mod(ninac-itorbc(l),2)),5)
               endif
 12            continue
c         ie3331=ie3331+1
               if(yw)write(6,*)'disint ecr 38'
c     <ooov>
            else if(jtypi.eq.6) then
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,0,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,0,2,a)
c        signe : dans ijka, le mono est k->p et le di est ij->ap
c        en occupation :  xxx xxixxxjxxxp
c                         xxxkxx xxx xxxap
c        on doit ramener i en k et a en j :    xxxixx xxxjxxxp
c                                              xxxkxx xxxaxxxp
c        on a saute   * i-k-1 el,   ninac-j el
c        le signe est donc donne par la parite de ninac+i+j+k+1
c        tous les autres ordonnancements i,j,k donnent i+j+k
c
c        cas d'une integrale <ijia>
c        on a alors un simple saut de j vers a
c        le saut par-dessus le CAS est pris en compte dans gende3
c        s'il n'y a ni autre trou ni autre part, on saute ninac-j el
c        s'il y a un trou a dr de j (-)
c        s'il y a une part a g de a (-)
c        ces 2 dernieres conditions dependent du determinant
c        (a prendre en compte dans gende3)
c         print*,'ooov',i,j,k,l
               if(i.eq.k) then
                  isgn=1
                  ipar=ninac+itorbc(j)
                  if(mod(ipar,2).eq.1) isgn=-isgn
                  call disin1(le1113,ie1113,43,i,j,k,l,isgn*a,6)
                  goto 11
               endif
               isgn=-1
               if(iti.eq.3) then
                  ipar=ninac+itorbc(j)+itorbc(k)+itorbc(l)
                  if(mod(ipar,2).eq.1) isgn=-isgn
                  if(k.lt.l)call disin1(le1113,ie1113,43,k,l,j,i,-isgn*a
     &            ,6)
                  if(k.gt.l)call disin1(le1113,ie1113,43,l,k,j,i,isgn*a,
     &            6)
               else if(itj.eq.3) then
                  ipar=ninac+itorbc(i)+itorbc(k)+itorbc(l)
                  if(mod(ipar,2).eq.1) isgn=-isgn
                  if(k.lt.l)call disin1(le1113,ie1113,43,k,l,i,j,isgn*a,
     &            6)
                  if(k.gt.l)call disin1(le1113,ie1113,43,l,k,i,j,-isgn*a
     &            ,6)
               else if(itk.eq.3) then
                  ipar=ninac+itorbc(i)+itorbc(j)+itorbc(l)
                  if(mod(ipar,2).eq.1) isgn=-isgn
                  if(i.lt.j)call disin1(le1113,ie1113,43,i,j,l,k,-isgn*a
     &            ,6)
                  if(i.gt.j)call disin1(le1113,ie1113,43,j,i,l,k,isgn*a,
     &            6)
               else if(itl.eq.3) then
                  ipar=ninac+itorbc(i)+itorbc(j)+itorbc(k)
                  if(mod(ipar,2).eq.1) isgn=-isgn
                  if(i.lt.j)call disin1(le1113,ie1113,43,i,j,k,l,isgn*a,
     &            6)
                  if(i.gt.j)call disin1(le1113,ie1113,43,j,i,k,l,-isgn*a
     &            ,6)
               endif
 11            continue
               if(yw)write(6,*)'disint ecr 43'
c     <Cvvv>
            else if(jtypi.eq.8) then
               if(ii.eq.kk)call fockdd(ii,jj,ll,itii,itjj,itll,0,2,aa)
               if(jj.eq.ll)call fockdd(jj,ii,kk,itjj,itii,itkk,0,2,aa)
               if(itii.eq.2) then
                  call disin1(le2333,ie2333,28,ii,jj,ll,kk,-aa,8)
               else if(itjj.eq.2) then
                  call disin1(le2333,ie2333,28,jj,ii,ll,kk,aa,8)
               else if(itkk.eq.2) then
                  call disin1(le2333,ie2333,28,kk,ll,jj,ii,-aa,8)
               else if(itll.eq.2) then
                  call disin1(le2333,ie2333,28,ll,kk,jj,ii,aa,8)
               endif
c     <CCvv>
            else if(jtypi.eq.9) then
               if(itest(38).eq.1)call disin1(le2233,ie2233,29,i,j,k,l,a,
     &         9)
c     <CvCv>
            else if(jtypi.eq.10) then
c         print*,'jtypi10',i,j,k,l,a
               if(itest(38).eq.1) then
                  if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
                  if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
c           print*,'icvcv10 ech',i,j,k,l,a
                  if(iti.eq.2) then
                     call disin1(le2323,ie2323,30,i,j,k,l,a,10)
                  else
                     call disin1(le2323,ie2323,30,j,i,l,k,a,10)
                  endif
               endif
c     <ooCC>
            else if(jtypi.eq.11) then
               if(itest(39).eq.1)call disin1(le1122,ie1122,31,k,l,i,j,a,
     &         11)
c     <oCoC>
            else if(jtypi.eq.12) then
               if(itest(39).eq.1) then
                  if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
                  if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
                  if(iti.eq.2) then
                     call disin1(le1212,ie1212,41,i,j,k,l,a,12)
                  else
                     call disin1(le1212,ie1212,41,j,i,l,k,a,12)
                  endif
               endif
c     <oCvv>
            else if(jtypi.eq.13) then
               call disin1(le2133,ie2133,42,j,i,l,k,a,13)
c     <ovCv>
            else if(jtypi.eq.14) then
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               if(iti.eq.1) then
                  call disin1(le2313,ie2313,50,k,l,i,j,a,14)
               else
                  call disin1(le2313,ie2313,50,l,k,j,i,a,14)
               endif
c     <ooCv>
            else if(jtypi.eq.15) then
               if(yw)print'(a20,4i3,f12.8)','coucou15 k,l,i,j',k,l,i,j,a
               call disin1(le2311,ie2311,51,k,l,i,j,a,15)
c     <oCov>
            else if(jtypi.eq.16) then
               if(yw)print*,'itypi16 i,j,k,l',i,j,k,l
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               call disin1(le2131,ie2131,52,j,i,l,k,a,16)
c     <oooC>
c      else if(jtypi.eq.17.and.i.ne.k.and.j.ne.l) then
            else if(jtypi.eq.17) then
               if(yw)print'(a20,4i3,f12.8)','itypi17 l,k,j,i',l,k,j,i
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               if(i.lt.j.and.i.ne.k) then
                  call disin1(le2111,ie2111,53,l,k,i,j,-a,17)
               else
                  call disin1(le2111,ie2111,53,l,k,j,i,a,17)
               endif
c     <ovCC>
            else if(jtypi.eq.18) then
               if(yw)print'(a20,4i3,f12.8)','itypi18 k,l,i,j',k,l,i,j
               call disin1(le2213,ie2213,54,k,l,i,j,a,18)
c     <oCvC>
            else if(jtypi.eq.19) then
               if(yw)print'(a20,4i3,f12.8)','itypi19 k,l,i,j',k,l,i,j,a
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(yw)print'(a20,4i3,f12.8)','coucou19' ,i,j,k,l,a
               if(i.eq.k) then
                  call disin1(le2123,ie2123,55,i,j,k,l,a,19)
               else
                  call disin1(le2123,ie2123,55,j,i,k,l,-a,19)
               endif
c     <CCCo>
            else if(jtypi.eq.20) then
               if(yw)print*,'coucou20',l,k,j,i
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(iti.eq.1) then
                  if(yw)print*,'1coucou20',l,k,j,i
                  call disin1(le2221,ie2221,56,l,k,j,i,a,20)
               else if(itj.eq.1) then
                  if(yw)print*,'2coucou20',k,l,i,j
                  call disin1(le2221,ie2221,56,k,l,i,j,a,20)
               endif
c     <CCCv>
            else if(jtypi.eq.21) then
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               call disin1(le2223,ie2223,57,i,j,k,l,a,21)
c     <CCCC>
            else if(jtypi.eq.22) then
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               call disin1(le2222,ie2222,58,i,j,k,l,a,22)
            else
               if(yw)write(6,*)'disint ecr 33'
               if(i.eq.k)call fockdd(i,j,l,iti,itj,itl,2,2,a)
               if(j.eq.l)call fockdd(j,i,k,itj,iti,itk,2,2,a)
               if(yw)print'(a20,4i3,f12.8)','generales ech',i,j,k,l,a
               call disin1(le0000,ie0000,33,i,j,k,l,a,7)
            endif
            iii11=i
            jjj11=j
            kkk11=k
            lll11=l
 4          continue
            ncas=nb_ind-1
         enddo
      enddo
 3    continue
      call disin2(7,33)
      if(ygcas) goto 23
      call disin2(1,34)
      call disin2(2,35)
      call disin2(3,36)
      call disin2(4,37)
      call disin2(5,38)
      call disin2(6,43)
      call disin2(8,28)
      if(itest(38).eq.1) then
         call disin2(9,29)
         call disin2(10,30)
      endif
      if(itest(39).eq.1) then
         call disin2(11,31)
         call disin2(12,41)
      endif
      close(34)
      close(35)
      close(36)
      close(37)
      close(38)
      close(43)
      close(28)
      if(itest(38).eq.1) then
         close(29)
         close(30)
      endif
      if(itest(39).eq.1) then
         close(31)
         close(41)
      endif
      if(itest(40).eq.1) then
         call disin2(13,42)
         call disin2(14,50)
         close(42)
         close(50)
      endif
      if(itest(41).eq.1) then
         call disin2(15,51)
         call disin2(16,52)
         close(51)
         close(52)
      endif
      if(itest(42).eq.1) then
         call disin2(17,53)
         close(53)
      endif
      if(itest(43).eq.1) then
         call disin2(18,54)
         call disin2(19,55)
         close(54)
         close(55)
      endif
      if(itest(60).eq.1) then
         call disin2(20,56)
         close(56)
      endif
      if(itest(61).eq.1) then
         call disin2(21,57)
         close(57)
      endif
      if(itest(62).eq.1) then
         call disin2(22,58)
         close(58)
      endif
 23   continue
      jcpu1=itemps(idum)-jcpu
      write(6,*)'distribution des integrales directes + echange -> cpu'
     *,jcpu1
      call flush(6)
      write(6,*)' '
      write(6,*)'repartition des integrales     '
     *//'     directes/directes+echange'
      write(6,*)'nombre d''integrales vvvv     ',
     *l3333*1024+i3333,le3333*1024+ie3333
      write(6,*)'nombre d''integrales oooo     ',
     *l1111*1024+i1111,le1111*1024+ie1111
      write(6,*)'nombre d''integrales vovo     ',
     *l3131*1024+i3131,le3131*1024+ie3131
      write(6,*)'nombre d''integrales vvoo     ',
     *l3311*1024+i3311,le3311*1024+ie3311
      write(6,*)'nombre d''integrales vvvo     ',
     *l3331*1024+i3331,le3331*1024+ie3331
      write(6,*)'nombre d''integrales ooov     ',
     *l1113*1024+i1113,le1113*1024+ie1113
      write(6,*)'nombre d''integrales Cvvv     ',
     *l2333*1024+i2333,le2333*1024+ie2333
      if(itest(38).eq.1) then
         write(6,*)'nombre d''integrales CCvv     ',
     *   l2233*1024+i2233,le2233*1024+ie2233
         write(6,*)'nombre d''integrales CvCv     ',
     *   l2323*1024+i2323,le2323*1024+ie2323
      endif
      if(itest(39).eq.1) then
         write(6,*)'nombre d''integrales ooCC     ',
     *   l1122*1024+i1122,le1122*1024+ie1122
         write(6,*)'nombre d''integrales oCoC     ',
     *   l1212*1024+i1212,le1212*1024+ie1212
      endif
      if(itest(40).eq.1) then
         write(6,*)'nombre d''integrales Covv     ',
     *   l2133*1024+i2133,le2133*1024+ie2133
         write(6,*)'nombre d''integrales Cvov     ',
     *   l2313*1024+i2313,le2313*1024+ie2313
      endif
      if(itest(41).eq.1) then
         write(6,*)'nombre d''integrales Cvoo     ',
     *   l2311*1024+i2311,le2311*1024+ie2311
         write(6,*)'nombre d''integrales Covo     ',
     *   l2131*1024+i2131,le2131*1024+ie2131
      endif
      if(itest(42).eq.1) then
         write(6,*)'nombre d''integrales Cooo     ',
     *   l2111*1024+i2111,le2111*1024+ie2111
      endif
      if(itest(43).eq.1) then
         write(6,*)'nombre d''integrales CCov     ',
     *   l2213*1024+i2213,le2213*1024+ie2213
         write(6,*)'nombre d''integrales CoCv     ',
     *   l2123*1024+i2123,le2123*1024+ie2123
      endif
      if(itest(60).eq.1) then
         write(6,*)'nombre d''integrales CCCo     ',
     *   l2221*1024+i2221,le2221*1024+ie2221
      endif
      if(itest(61).eq.1) then
         write(6,*)'nombre d''integrales CCCv     ',
     *   l2223*1024+i2223,le2223*1024+ie2223
      endif
      if(itest(62).eq.1) then
         write(6,*)'nombre d''integrales CCCC     ',
     *   l2222*1024+i2222,le2222*1024+ie2222
      endif
      write(6,*)'nombre d''integrales restantes',
     *l0000*1024+i0000,le0000*1024+ie0000
      write(6,*)' '
      if(itest(27).eq.1) close(26,status='delete')
      call flush(6)
      call disst1
      print*,' '
      print*,'======================================================='
      print*,'Nombre d''integrales',nintot
      print*,
     *'Seuils d''elimination des integrales, integrales eliminees'
      print'(a,d12.3,/,a,i11,a,i11)',
     *' Toutes integrales (sint)',sint,'   gardees :',nintot-ilimi,
     *'   eliminees :',ilimi
      print'(a,d12.3,/,a,i11,a,i11)',
     *' int a 4 indices  (sint4)',sint4,'   gardees :',nintot4-ilimi4,
     *'   eliminees :',ilimi4
      print*,'======================================================='
      return
      end
       subroutine disin1(llll,iiii,ifil,i,j,k,l,a,ll)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/test/itest(100)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/espa2/ inti(1024,22),intj(1024,22),intk(1024,22),
     *intl(1024,22),aaint(1024,22)
      character*1 cnti(1024),cntj(1024),cntk(1024),cntl(1024)
      character*1 ijklnt(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c---------------------------------------------------------
c     ecriture des integrales au cours de leur calcul
c---------------------------------------------------------
c
c     write(ifil,*)i,j,k,l,a
c     iiii=iiii+1
      if(yga2) then
         if(a.eq.0.d0) then
            write(6,'(a7,i3,3x,4i3,2f12.8)')'Disin1',ifil,i,j,k,l,a,a+a
            stop
         endif
         aa=a
         if(a.gt.0.d0) then
            a=a-1.d0
         else if(a.lt.0.d0) then
            a=a+1.d0
         endif
      endif
      iiii=iiii+1
      inti(iiii,ll)=i
      intj(iiii,ll)=j
      intk(iiii,ll)=k
      intl(iiii,ll)=l
      aaint(iiii,ll)=a
c      print*,'a dans disin1',a
      if(yw)print'('' disin1'',a16,6i4,f10.6)'
     *,'ll,iiii,i,j,k,l',ll,iiii,i,j,k,l,a
      if(yw.or.(yga2.and.yw1)) then
         write(6,'(a7,i3,3x,4i3,2f12.8,2i5,i2)')
     *   'disin1',ifil,i,j,k,l,a,a+a,llll,iiii,ll
c      print*,'dis1 fil56',inti(1,1),intj(1,1),intk(1,1),intl(1,1)
c      print*,'dis1 fil57',inti(1,2),intj(1,2),intk(1,2),intl(1,2)
c      print*,'dis1 fil58',inti(1,3),intj(1,3),intk(1,3),intl(1,3)
      endif
      if(iiii.eq.1024) then
         llll=llll+1
         iiii=0
         if(itest(26).eq.1) then
            do kk=1,1024
               call encod(inti(kk,ll),intj(kk,ll),
     *         intk(kk,ll),intl(kk,ll),
     *         cnti(kk),cntj(kk),cntk(kk),cntl(kk),ijklnt(kk),4)
            enddo
            if(norb.lt.256) then
               write(ifil) cnti,cntj,cntk,cntl
     *         ,(aaint(kk,ll),kk=1,1024)
            else
               write(ifil) cnti,cntj,cntk,cntl
     *         ,(aaint(kk,ll),kk=1,1024),ijklnt
            endif
c            if(norb.lt.256) then
c               do kk=1,1024
c                  cnti(kk)=char(inti(kk,ll))
c                  cntj(kk)=char(intj(kk,ll))
c                  cntk(kk)=char(intk(kk,ll))
c                  cntl(kk)=char(intl(kk,ll))
c               enddo
c               write(ifil) cnti,cntj,cntk,cntl
c     *         ,(aaint(kk,ll),kk=1,1024)
c            else
c               do kk=1,1024
c                  call icorr0(inti(kk,ll),ii,cnti(kk),icod)
c                  call icorr0(intj(kk,ll),ii,cntj(kk),jcod)
c                  call icorr0(intk(kk,ll),ii,cntk(kk),kcod)
c                  call icorr0(intl(kk,ll),ii,cntl(kk),lcod)
c                  jkl=icod+jcod*4+kcod*16+lcod*64
c                  ijklnt(kk)=char(jkl)
c               enddo
c               write(ifil) cnti,cntj,cntk,cntl
c     *         ,(aaint(kk,ll),kk=1,1024),ijklnt
c            endif
         else
            write(ifil)(inti(kk,ll),kk=1,1024)
     *      ,          (intj(kk,ll),kk=1,1024)
     *      ,          (intk(kk,ll),kk=1,1024)
     *      ,          (intl(kk,ll),kk=1,1024)
     *      ,  (aaint(kk,ll),kk=1,1024)
         endif
      endif
      if(yga2)a=aa
      return
      end
       subroutine disin2(ll,ifil)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/test/itest(100)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/espa2/ inti(1024,22),intj(1024,22),intk(1024,22),
     *intl(1024,22),aaint(1024,22)
      character*1 cnti(1024),cntj(1024),cntk(1024),cntl(1024)
      character*1 ijklnt(1024)
c
c---------------------------------------------------------
c     ecriture des integrales a la fin de leur calcul
c---------------------------------------------------------
c
      if(itest(26).eq.1) then
         do kk=1,1024
            call encod(inti(kk,ll),intj(kk,ll),
     *      intk(kk,ll),intl(kk,ll),
     *      cnti(kk),cntj(kk),cntk(kk),cntl(kk),ijklnt(kk),4)
         enddo
         if(norb.lt.256) then
            write(ifil) cnti,cntj,cntk,cntl
     *      ,(aaint(kk,ll),kk=1,1024)
         else
            write(ifil) cnti,cntj,cntk,cntl
     *      ,(aaint(kk,ll),kk=1,1024),ijklnt
         endif
c         if(norb.lt.256) then
c            do k=1,1024
c               cnti(k)=char(inti(k,ll))
c               cntj(k)=char(intj(k,ll))
c               cntk(k)=char(intk(k,ll))
c               cntl(k)=char(intl(k,ll))
c            enddo
c            write(ifil) cnti,cntj,cntk,cntl
c     *      ,(aaint(kk,ll),kk=1,1024)
c         else
c            do kk=1,1024
c               call icorr0(inti(kk,ll),ii,cnti(kk),icod)
c               call icorr0(intj(kk,ll),ii,cntj(kk),jcod)
c               call icorr0(intk(kk,ll),ii,cntk(kk),kcod)
c               call icorr0(intl(kk,ll),ii,cntl(kk),lcod)
c               jkl=icod+jcod*4+kcod*16+lcod*64
c               ijklnt(kk)=char(jkl)
c            enddo
c            write(ifil) cnti,cntj,cntk,cntl
c     *      ,(aaint(kk,ll),kk=1,1024),ijklnt
c         endif
      else
         write(ifil)(inti(k,ll),k=1,1024)
     *   ,          (intj(k,ll),k=1,1024)
     *   ,          (intk(k,ll),k=1,1024)
     *   ,          (intl(k,ll),k=1,1024)
     *   ,          (aaint(k,ll),k=1,1024)
      endif
      return
      end
       subroutine fockdd(i,j,l,iti,itj,itl,isgn,isgn2,a)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/test/itest(100)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      yw=.false.
c
c----------------------------------------------------------------
c     mise de l'operateur de fock dans les integrales bielectroniques
c
c     nelac .ge. 2 :
c     on remarque que np+nC-nt=nelac
c     F apparait en + dans np+nC int, en - dans nt int
c     au total, il apparait nelac fois
c     MOINS l'int nulle <xxxy>
c     donc si on a o-->o                 F apparait nelac+1 fois
c     donc si on a v ou C-->v ou C       F apparait nelac-1 fois
c     donc si on a o-->v ou C            F apparait nelac fois
c     ==> on corrige <xyxz> par F/(nelac+i), i=-1,0, ou 1
c
c     nelac .eq. 1 :
c     dans la formule precedente, il y probleme avec le
c     denominateur (nelac-1)
c        on met F dans toutes les integrales, comme pour nelac.eq.2
c        sauf dans les sauts sans inactive
c        dans ce cas on met 0 dans <.a.a> et <.A.A>
c        et -F/2 dans <.i.i>
c        ainsi les interactions les plus nombreuses
c        <ij C ac | ij C bc> sont calculees sans erreur
c        <i C a | i C b> sont calculees a moitie
c        <. . a | . . b> ne sont pas calculees
c
c     nelac .eq. 0 :
c     cas (le plus frequent) d'une interaction entre 2 diexcites
c     o --> o  F apparait 2 fois dans les part et 1 fois dans les trous
c              ==> on met F dans les part et -F dans les trous
c     v --> v  coherent avec le choix precedent  F - 2( F+F )
c     cas d'une interaction entre 2 mono  : encore OK
c     cas d'une interaction mono --> di
c     o-->v
c     ************a finir   itest(16)=0 si nelac=0  pour l'instant
c
 
c----------------------------------------------------------------
c
      if(itest(16).eq.0) return
c     call wrd(f,9)
      ll=max(j,l)
      jj=min(j,l)
      lljj=ll*(ll-1)/2+jj
c      print*,'ll,jj,lljj',ll,jj,lljj,f(lljj)
c      write(6,'(a32,4i3,f12.8)')'fockdd i j i l ',i,j,i,l,a
c      write(6,'(a32,4i3,f12.8)')'fockdd iti itj itl ',iti,itj,itl
      if(nelac.eq.0) then
         if(iabs(isgn).gt.1) stop'fockdd'
         a=a+isgn*f(lljj)
      else if (nelac.eq.1) then
         jsgn2=1
         if(isgn2.eq.2) then
c           on est dans les integrales d'echange
c           il faut changer le signe si i est inactive
c           il faut changer le signe j-l saute i
            if(iti.eq.1) jsgn2=-jsgn2
            iia=isbrot(i)
            iib=isbrot(j)
            iid=isbrot(l)
            if((iid-iia)*(iib-iia).lt.0) jsgn2=-jsgn2
         endif
c        on met F dans toutes les integrales, comme pour nelac.eq.2
c        sauf dans les sauts sans inactive
c        dans ce cas on met 0 dans <.a.a> et <.A.A>
c        et -F/2 dans <.i.i>
c        ainsi les interactions les plus nombreuses
c        <ij C ac | ij C bc> sont calculees sans erreur
c        <i C a | i C b> sont calculees a moitie
c        <. . a | . . b> ne sont pas calculees
         if(iti.eq.1) then
            if(itj.eq.1) then
               if(itl.eq.1) then
                  a=a+jsgn2*f(lljj)/2
               else
                  a=a+jsgn2*f(lljj)
               endif
            else
               if(itl.eq.1) then
                  a=a+jsgn2*f(lljj)
               else
                  a=a-jsgn2*f(lljj)/2
               endif
            endif
         else
            if(itj.eq.1) then
               if(itl.eq.1) then
                  a=a+jsgn2*f(lljj)/2
               else
                  a=a+jsgn2*f(lljj)
               endif
            else
               if(itl.eq.1) then
                  a=a+jsgn2*f(lljj)
               endif
            endif
         endif
      else if (nelac.ge.2) then
         if(yw)
     *   write(6,'(a32,4i3,2f12.8)')'1fockdd i j i l ',i,j,i,l,a,f(lljj)
         jsgn2=iabs(isgn2)
         ksgn2=isgn2/jsgn2
         if(jsgn2.eq.2) then
c           on est dans les integrales d'echange
c           il faut changer le signe si i est inactive
c           il faut changer le signe j-l saute i
            jsgn2=ksgn2
            if(iti.eq.1) jsgn2=-jsgn2
            iia=isbrot(i)
            iib=isbrot(j)
            iid=isbrot(l)
            if((iid-iia)*(iib-iia).lt.0) jsgn2=-jsgn2
         endif
         if(itj.eq.1) then
            if(itl.eq.1) then
               a=a+jsgn2*f(lljj)/(nelac+1)
            else
               a=a+jsgn2*f(lljj)/(nelac)
            endif
         else
            if(itl.eq.1) then
               a=a+jsgn2*f(lljj)/(nelac)
            else
               a=a+jsgn2*f(lljj)/(nelac-1)
            endif
         endif
      endif
      if(yw)
     *write(6,'(a32,4i3,2f12.8)')'2fockdd i j i l ',i,j,i,l,a,f(lljj)
      return
      end
       subroutine disst2
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/test/itest(100)
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
     *,i2221,i2223,ie2221,ie2223,l2221,l2223,le2221,le2223
     *,i2222,ie2222,l2222,le2222
      read(74)
     *i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
     *,i2221,i2223,ie2221,ie2223,l2221,l2223,le2221,le2223
     *,i2222,ie2222,l2222,le2222
c      open(27,file='CDI_INT0',status='UNKNOWN',form='UNFORMATTED')
      open(28,file='CDI_3333',status='UNKNOWN',form='UNFORMATTED')
      open(29,file='CDI_1111',status='UNKNOWN',form='UNFORMATTED')
      open(30,file='CDI_3131',status='UNKNOWN',form='UNFORMATTED')
      open(31,file='CDI_3311',status='UNKNOWN',form='UNFORMATTED')
      open(42,file='CDI_3331',status='UNKNOWN',form='UNFORMATTED')
      open(41,file='CDI_1113',status='UNKNOWN',form='UNFORMATTED')
      open(43,file='CDI_2333',status='UNKNOWN',form='UNFORMATTED')
      if(itest(38).eq.1) then
         open(34,file='CDI_2233',status='UNKNOWN',form='UNFORMATTED')
         open(35,file='CDI_2323',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(39).eq.1) then
         open(36,file='CDI_1122',status='UNKNOWN',form='UNFORMATTED')
         open(37,file='CDI_1212',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(40).eq.1) then
         open(38,file='CDI_2133',status='UNKNOWN',form='UNFORMATTED')
         open(50,file='CDI_2313',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(41).eq.1) then
         open(51,file='CDI_2311',status='UNKNOWN',form='UNFORMATTED')
         open(52,file='CDI_2131',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(42).eq.1) then
         open(53,file='CDI_2111',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(43).eq.1) then
         open(54,file='CDI_2213',status='UNKNOWN',form='UNFORMATTED')
         open(55,file='CDI_2123',status='UNKNOWN',form='UNFORMATTED')
      endif
      close(28)
      close(29)
      close(30)
      close(31)
      close(42)
      close(41)
      close(43)
      close(34)
      close(35)
      close(36)
      close(37)
      close(38)
      close(50)
      close(51)
      close(52)
      close(53)
      close(54)
      close(55)
c      open(33,file='CDE_INT0',status='UNKNOWN',form='UNFORMATTED')
      open(34,file='CDE_3333',status='UNKNOWN',form='UNFORMATTED')
      open(35,file='CDE_1111',status='UNKNOWN',form='UNFORMATTED')
      open(36,file='CDE_3131',status='UNKNOWN',form='UNFORMATTED')
      open(37,file='CDE_3311',status='UNKNOWN',form='UNFORMATTED')
      open(38,file='CDE_3331',status='UNKNOWN',form='UNFORMATTED')
      open(43,file='CDE_1113',status='UNKNOWN',form='UNFORMATTED')
      open(28,file='CDE_2333',status='UNKNOWN',form='UNFORMATTED')
      if(itest(38).eq.1) then
         open(29,file='CDE_2233',status='UNKNOWN',form='UNFORMATTED')
         open(30,file='CDE_2323',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(39).eq.1) then
         open(31,file='CDE_1122',status='UNKNOWN',form='UNFORMATTED')
         open(41,file='CDE_1212',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(40).eq.1) then
         open(42,file='CDE_2133',status='UNKNOWN',form='UNFORMATTED')
         open(50,file='CDE_2313',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(41).eq.1) then
         open(51,file='CDE_2311',status='UNKNOWN',form='UNFORMATTED')
         open(52,file='CDE_2131',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(42).eq.1) then
         open(53,file='CDE_2111',status='UNKNOWN',form='UNFORMATTED')
      endif
      if(itest(43).eq.1) then
         open(54,file='CDE_2213',status='UNKNOWN',form='UNFORMATTED')
         open(55,file='CDE_2123',status='UNKNOWN',form='UNFORMATTED')
      endif
      close(34)
      close(35)
      close(36)
      close(37)
      close(38)
      close(43)
      close(28)
      close(29)
      close(30)
      close(31)
      close(41)
      close(42)
      close(50)
      close(51)
      close(52)
      close(53)
      close(54)
      close(55)
      return
      end
       subroutine disst1
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common /nin/i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
     *,i2221,i2223,ie2221,ie2223,l2221,l2223,le2221,le2223
     *,i2222,ie2222,l2222,le2222
      write(74)
     *i3333,ie3333,i1111,ie1111,i3131,ie3131
     *,i3311,ie3311,i3331,ie3331,i1113,ie1113,i0000,ie0000
     *,l3333,le3333,l1111,le1111,l3131,le3131
     *,l3311,le3311,l3331,le3331,l1113,le1113,l0000,le0000
     *,i2333,ie2333,l2333,le2333,i2000,ie2000,l2000,le2000
     *,i2233,ie2233,l2233,le2233,i1122,ie1122,l1122,le1122
     *,i2323,ie2323,l2323,le2323,i1212,ie1212,l1212,le1212
     *,i2133,ie2133,l2133,le2133,i2313,ie2313,l2313,le2313
     *,i2311,ie2311,l2311,le2311,i2131,ie2131,l2131,le2131
     *,i2111,ie2111,l2111,le2111,i2123,ie2123,l2123,le2123
     *,i2213,ie2213,l2213,le2213
     *,i211a,i211b,i211c,l211a,l211b,l211c
     *,i2221,i2223,ie2221,ie2223,l2221,l2223,le2221,le2223
     *,i2222,ie2222,l2222,le2222
      close(74)
      return
      end
       subroutine reorint(i,j,k,l)
      if(i.lt.k) call ech(i,k)
      if(j.lt.l) call ech(j,l)
      if(i.lt.j.or.(i.eq.j.and.k.lt.l)) then
         call ech(i,j)
         call ech(k,l)
      endif
      return
      end
