      subroutine disin4(esp,yesp,icas)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/dim/iadri ; integer(8) iadri
      dimension yesp(iadri*8),esp(iadri)
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      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
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/test/itest(100)
      common/sy5/ nbts(maxsym,3),numts(maxorb,maxsym,3)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /o/ maxinto
      dimension lcateg(maxsym,maxsym,maxsym,3,3,3)
      dimension yeqv(4,4)
      integer(8) k8,iadro8
      yw1=.false.
      yw=.false.
c
c--------------------------------------------------------------
c     adressage des integrales contenant une orbitale du CAS
c     regle pour les integrales :
c     1er indice : CAS
c     autres indices : quelconques.
c
c
c--------------------------------------------------------------
c
c
c--   preparation
c
      maxinto=0
      do k=1,3
         do l=1,nsym
            nbts(l,k)=0
         enddo
      enddo
      do k=1,norb
         is=itsym(k)
         ity=itype(k)
         nbts(is,ity)=nbts(is,ity)+1
         numts(itorb(k),is,ity)=k
      enddo
 
c
      if(icas.eq.1) then
         open(28,form='unformatted',status='unknown',file='CDIO_INT0')
         open(29,file='CDI1_INT0',status='UNKNOWN',form='UNFORMATTED')
      else
         open(28,form='unformatted',status='unknown',file='CDEO_INT0')
         open(29,file='CDE1_INT0',status='UNKNOWN',form='UNFORMATTED')
      endif
      l0001=0
      i0001=0
      ir=0
      le0001=0
      ie0001=0
      ire=0
      icxxx=0
      icexxx=0
c
c--   boucle sur l'indice du CAS
      do 1 io00=1,noac
      do lty=1,3
         do kty=1,3
            do jty=1,3
               do ls=1,nsym
                  do ks=1,nsym
                     do js=1,nsym
                        lcateg(js,ks,ls,jty,kty,lty)=0
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo
      ll=0
      io=numac(io00)
      if(yw)print*,'indice CAS',io
      io0=itorb(io)
      is=itsym(io)
c
c--   boucles sur les types
      do 2 jty=1,3
      do 3 kty=1,3
      do 4 lty=1,3
c
c--   boucles sur les symetries
      jfins=nsym
c      if(icas.eq.2.and.jty.eq.2) jfins=is
      do 5 js=1,jfins
      yeqv(1,2)=jty.eq.2.and.is.eq.js
      kfins=nsym
      do 6 ks=1,nsym
      yeqv(1,3)=kty.eq.2.and.is.eq.ks
      ls=its(is,its(js,ks))
      yeqv(3,4)=lty.eq.kty.and.ls.eq.ks
      yeqv(2,4)=lty.eq.jty.and.ls.eq.js
      yeqv(1,4)=lty.eq.2.and.ls.eq.is
c
c--   nombre d'orbitales par categorie
      maxj=nbts(js,jty)
      maxk=nbts(ks,kty)
      maxl=nbts(ls,lty)
c
      maxx2=maxj*maxl
      maxx=maxk
      lcateg(js,ks,ls,jty,kty,lty)=ll
      if(yw)write(6,'('' js,ks,ls,jty,kty,lty,lcateg'',3i3,2x,3i3,
     *2x,2i7)')js,ks,ls,jty,kty,lty,
     *lcateg(js,ks,ls,jty,kty,lty)
      ll=ll+maxx*maxx2
 6    continue
 5    continue
 4    continue
 3    continue
 2    continue
      write(28) lcateg,ll
      nbint=ll
      maxinto=max(maxinto,nbint)
      if(icas.eq.1) then
         icxxx=icxxx+ll
      else
         icexxx=icexxx+ll
      endif
c
c--   lecture des integrales
c
      print*,'nombre d''integrales',nbint
      do k=1,nbint
         k8=k
         yesp(iadri*4+k8)=.false.
         esp(k)=0.d0
      enddo
      if(icas.eq.1) then
         l0=l0000
         i0=i0000
         ifil=27
      else
         l0=le0000
         i0=ie0000
         ifil=33
      endif
 
      rewind ifil
      do ln=1,l0+1
         call lirin4(inti,intj,intk,intl,aaint,ifil)
c         read(ifil)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.l0+1)lfini=i0
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yw1) then
               write(75,*)'int lue ',i,j,k,l,a,'$'
               call scril
            endif
c--         correction du signe - de stech3
            if(i.eq.k.and.icas.ne.1) then
               iia=isbrot(i)
               iib=isbrot(j)
               iid=isbrot(l)
               if((iid-iia)*(iib-iia).lt.0) a=-a
            endif
c--         on reordonne les indices
            if(icas.eq.1) then
               if(i.eq.io) then
                  call stoo(i,j,k,l,a,lcateg,esp,yesp)
                  if(l.ne.j)call stoo(i,l,k,j,a,lcateg,esp,yesp)
               endif
               if (k.eq.io.and.k.ne.i) then
                  call stoo(k,j,i,l,a,lcateg,esp,yesp)
                  if(l.ne.j)call stoo(k,l,i,j,a,lcateg,esp,yesp)
               endif
               if (i.ne.j.or.k.ne.l) then
                  if(j.eq.io) then
                     call stoo(j,i,l,k,a,lcateg,esp,yesp)
                     if(k.ne.i)call stoo(j,k,l,i,a,lcateg,esp,yesp)
                  endif
                  if(l.eq.io.and.l.ne.j) then
                     call stoo(l,i,j,k,a,lcateg,esp,yesp)
                     if(k.ne.i)call stoo(l,k,j,i,a,lcateg,esp,yesp)
                  endif
               endif
            else
               if(i.eq.io) then
                  call stooe(i,j,k,l,a,lcateg,esp,yesp)
                  if(l.ne.k)call stooe(i,j,l,k,-a,lcateg,esp,yesp)
               endif
               if (j.eq.io.and.i.ne.j) then
                  call stooe(j,i,k,l,-a,lcateg,esp,yesp)
                  if(l.ne.k)call stooe(j,i,l,k,a,lcateg,esp,yesp)
               endif
               if(i.ne.k.or.j.ne.l) then
                  if (k.eq.io) then
                     call stooe(k,l,i,j,a,lcateg,esp,yesp)
                     if(i.ne.j)call stooe(k,l,j,i,-a,lcateg,esp,yesp)
                  endif
                  if (l.eq.io.and.k.ne.l) then
                     call stooe(l,k,i,j,-a,lcateg,esp,yesp)
                     if(j.ne.i)call stooe(l,k,j,i,a,lcateg,esp,yesp)
                  endif
               endif
            endif
c
c--         si l'integrale n'a pas de C, on la remet dans 29
            if(itype(i).ne.2.and.itype(j).ne.2.and.itype(k)
     *      .ne.2.and.itype(l).ne.2) then
               ir=ir+1
               call disin1(l0001,i0001,29,i,j,k,l,a,1)
            endif
         enddo
      enddo
      call ecr8(esp,nbint,28)
 1    continue
      call disin2(1,29)
      write(6,*)'nombre d''integrales Cxxx,',
     *icxxx,icexxx
      if(icas.eq.1) then
         l0000=l0001
         i0000=i0001
      else
         le0000=l0001
         ie0000=i0001
      endif
      close(ifil,status='delete')
      close(28)
      close(29)
      if(icas.eq.1) then
         open(ifil,form='unformatted',status='old',file='CDI1_INT0')
      else
         open(ifil,form='unformatted',status='old',file='CDE1_INT0')
      endif
      write(6,*)'nombre d''integrales restantes ',
     *l0001*1024+i0001,le0001*1024+ie0001
c      if(icas.eq.2)stop
      return
      end
       subroutine adrio(j,k,l,lcateg,iadro)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/sy5/ nbts(maxsym,3),numts(maxorb,maxsym,3)
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      dimension lcateg(nsym,nsym,nsym,3,3,3)
      yw=.false.
      jty=itype(j)
      kty=itype(k)
      lty=itype(l)
      js=itsym(j)
      ks=itsym(k)
      ls=itsym(l)
      jo=itorb(j)
      ko=itorb(k)
      lo=itorb(l)
      jl=lo+(jo-1)*nbts(ls,lty)
      maxx=nbts(ks,kty)
      iadro=ko+(jl-1)*maxx+lcateg(js,ks,ls,jty,kty,lty)
      if(yw)then
         write(75,*)'iadro lcateg,jo,ko,lo,j,k,l,jl,maxx',
     *   lcateg(js,ks,ls,jty,kty,lty),jo,ko,lo,j,k,l,jl,maxx,'$'
         call scril
      endif
      return
      end
       subroutine adrioe(j,k,l,lcateg,iadro)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/sy5/ nbts(maxsym,3),numts(maxorb,maxsym,3)
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      dimension lcateg(nsym,nsym,nsym,3,3,3)
      yw=.false.
      jty=itype(j)
      kty=itype(k)
      lty=itype(l)
      js=itsym(j)
      ks=itsym(k)
      ls=itsym(l)
      jo=itorb(j)
      ko=itorb(k)
      lo=itorb(l)
      kl=lo+(ko-1)*nbts(ls,lty)
      maxx=nbts(js,jty)
      iadro=jo+(kl-1)*maxx+lcateg(js,ks,ls,jty,kty,lty)
      if(yw) then
         write(75,*)'iadro lcateg,jo,ko,lo,j,k,l,kl,maxx',
     *   lcateg(js,ks,ls,jty,kty,lty),jo,ko,lo,j,k,l,kl,maxx,'$'
         call scril
      endif
      return
      end
       subroutine stoo(i,j,k,l,a,lcateg,esp,yesp)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/dim/iadri ; integer(8) iadri
      dimension lcateg(nsym,nsym,nsym,3,3,3)
      dimension yesp(iadri*8),esp(iadri)
      integer(8) iadro8
      yw1=.false.
      aa=a
c--   si le saut se fait dans le CAS, signe moins pour un saut
c     vers une symetrie inferieure
      if(itype(k).eq.2.and.((k-i)*(itsym(k)-itsym(i)).lt.0)) aa=-aa
      if(itype(j).eq.2.and.itype(l).eq.2
     *.and.((l-j)*(itsym(l)-itsym(j)).lt.0)) aa=-aa
      call adrio(j,k,l,lcateg,iadro)
      iadro8=iado
      if(yesp(iadri*4+iadro8)) then
         write(75,*)'disin4 deja vu',i,j,k,l,'   ',iadro8,'$'
         call scril
         stop
      endif
c     print'('' TROUS?'',6i5)', io00,iadro,i,j,k,l
      yesp(iadri*4+iadro8)=.true.
      if(yw1) then
         write(75,*)'___________________disin4 '
     *   ,i,j,k,l,' iadri ',iadro,aa,'$'
         call scril
      endif
      esp(iadro)=aa
      return
      end
       subroutine stooe(i,j,k,l,a,lcateg,esp,yesp)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/dim/iadri ; integer(8) iadri
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      dimension lcateg(nsym,nsym,nsym,3,3,3)
      dimension yesp(iadri*8),esp(iadri)
      integer(8) iadro8
      yw1=.false.
      iia=isbrot(i)
      iib=isbrot(j)
      iic=isbrot(k)
      iid=isbrot(l)
      aa=a
c
c     if(itype(j).eq.2.and.j.gt.i) return
c     print*,'yesp',yesp(iadri*4+1:iadri*4+40)
c--   si le saut se fait dans le CAS, signe moins pour un saut
c     vers une symetrie inferieure
      if(itype(k).eq.2.and.((k-i)*(itsym(k)-itsym(i)).lt.0)) aa=-aa
      if(itype(j).eq.2.and.itype(l).eq.2
     *.and.((l-j)*(itsym(l)-itsym(j)).lt.0)) aa=-aa
c     croisement ?
      if((iid-iic)*(iib-iic)*(iid-iia)*(iib-iia).lt.0) aa=-aa
      call adrioe(j,k,l,lcateg,iadro)
      iadro8=iadro
      if(yesp(iadri*4+iadro8)) then
         write(75,*)'disin4 deja vu',i,j,k,l,'   ',iadro8,'$'
         call scril
         stop
      endif
c     print'('' TROUS?'',6i5)', io00,iadro,i,j,k,l
      yesp(iadri*4+iadro8)=.true.
      if(yw1) then
         write(75,*)'___________________disin4 ech '
     *   ,i,j,k,l,' iadri ',iadro,aa,'$'
         call scril
      endif
      esp(iadro)=aa
      return
      end
