      subroutine calech(esp1,iesp,yesp,cesp,ierr)
c
c--------------------------------------------------------------------
c     CALCUL DES INTEGRALES DIRECTE + ECHANGE
c--------------------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16,maxda3=300)
      include 'maxorb.prm'
      include '../../param/maxlong.prm'
      parameter(nrec1=1024)
      common/dim/iadri ; integer(8) iadri
C      parameter(mxrec0=120000)
C      parameter(mxreci=(mxrec0/8)*8)
      dimension esp1(iadri*2)
      dimension iesp(iadri*4),yesp(*)
      character*1 cesp(*)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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
      common /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      character*4 gener
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      character*8 point
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      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/pliadri/ipliadri(2)
      save maxreci
      yw1=.false.
      yw=.false.
      print*,' '
      print*,'CALCUL DES INTEGRALES DIRECTE + ECHANGE'
      if(ipliadri(2)==0.and.yw1)
     *print*,'Longueur max des fichiers (en kb) maxlong=',maxlong
      maxrec70=(maxlong/(nrec1*(8+nind)))*1000
      maxrec=(maxrec+1)*1000
      nfil70=1
      numfil70(1)=70
      numfil70(2)=71
      numfil70(3)=72
      numfil70(4)=73
      nomfil70(1)='BID70'
      nomfil70(2)='BID70_1'
      nomfil70(3)='BID70_2'
      nomfil70(4)='BID70_3'
      icpu=itemps(idum)
      if(yw1) then
         if(ipliadri(2)==0)
     *   write(6,*)'calech  dimension disponible pour les blocs',
     *   ' d''integrales en memoire   mxreci',mxreci
      endif
c
c**************************
c--   calcul des dimensions
c**************************
      maxrec=(norb-1)*(norb-1)*(norb-2)/(2*nrec1)+1
      i1=nrec1*2+1
      i2=i1+maxrec*norb
      i3=i2+norb
c     i4=i3+norb
      i4=(i3+norb)*4-3
      i5=(i4+3)/4+nind*nrec1*norb
      i5r8=i5/2
      i6=i5+nrec1*norb*2
      if(yw1) then
         if(ipliadri(2)==0)
     *   write(6,*)'i1,i2,i3,i4,i5,i5r8,i6',i1,i2,i3,i4,i5,i5r8,i6
      endif
      ierr=0
c      print*,'avant stoech0'
      if(ipliadri(2)==0) call stoech0(itorbi,maxreci)
c      print*,'apres stoech0'
      i6log=i6*4
      j6=i5+maxreci*2
      j6log=j6*4
      j7log=j6log+maxreci
      if(yw)write(6,*)'i5,j6log,j7log',i5,j6log,j7log
      maxlog=max(j7log,i6log)
c      print*,'COUCOU1'
      ipliadri(2)=0
      if(maxlog/16+15.gt.iadri) then
         write(6,*)'iadri pas assez grand  iadri,maxlog',iadri,maxlog
         ierr=(maxlog+3)/4
         ipliadri(1)=maxlog/16+15
         ipliadri(2)=2
         return
      endif
c      print*,'COUCOU2'
c
c****************
c--   mize a zero
c****************
c
      call maz34(iesp(i2),iesp(i3),irec)
c     print*,'jrec apres maz',iesp(i3:i3+norb-1)
      ifile=70
c      print*,'COUCOU3'
      call liri00
c      print*,'COUCOU4'
c
c****************************
c--   lecture d'une integrale
c****************************
c
   1  call lirin0(i,k,j,l,b)
c     if(yw) then
c     write(75,*)'int lue1 ',i,j,k,l,b,'$'
c     call scril
c     endif
      if(l.eq.0) goto 2
      if(ygcas) then
         if(itype(i).ne.2.or.itype(j).ne.2.or.itype(k).ne.2
     *   .or.itype(l).ne.2) goto 1
      endif
      if(ygmono.and.i.ne.k.and.j.ne.l) then
         ii1=0
         ii3=0
         if(itype(i).eq.3) ii3=ii3+1
         if(itype(j).eq.3) ii3=ii3+1
         if(itype(k).eq.3) ii3=ii3+1
         if(itype(l).eq.3) ii3=ii3+1
         if(ii3.ge.3) goto 1
         if(itype(i).eq.1) ii1=ii1+1
         if(itype(j).eq.1) ii1=ii1+1
         if(itype(k).eq.1) ii1=ii1+1
         if(itype(l).eq.1) ii1=ii1+1
         if(ii1.ge.3) goto 1
       endif
c
c
c*****************************************
c     on reordonne les indices en symetrie
c*****************************************
c
      isi=itsym(i)
      isj=itsym(j)
      isk=itsym(k)
      isl=itsym(l)
      if(its(its(isi,isj),its(isk,isl)).ne.1) then
         print*,'i,j,k,l',i,j,k,l,isi,isj,isk,isl
         stop
      endif
      if(itsym(i).lt.itsym(k)) then
         ii=i
         i=k
         k=ii
      endif
      if(itsym(i).eq.itsym(k)) then
         if(i.lt.k) then
            ii=i
            i=k
            k=ii
         endif
      endif
      if(itsym(j).lt.itsym(l)) then
         ii=j
         j=l
         l=ii
      endif
      if(itsym(j).eq.itsym(l)) then
         if(j.lt.l) then
            ii=j
            j=l
            l=ii
         endif
      endif
      if(itsym(i).lt.itsym(j)) then
         ii=j
         j=i
         i=ii
         ii=k
         k=l
         l=ii
      endif
      if(itsym(i).eq.itsym(j)) then
         if(i.lt.j) then
            ii=j
            j=i
            i=ii
            ii=k
            k=l
            l=ii
         endif
      endif
      isi=itsym(i)
      isj=itsym(j)
      isk=itsym(k)
      isl=itsym(l)
      if(its(its(isi,isj),its(isk,isl)).ne.1) then
         print*,'I,j,k,l',i,j,k,l,isi,isj,isk,isl
         stop
      endif
      if(yw) then
         write(6,'(a8,4i4,f12.8)')'int lue',i,j,k,l,b
      endif
c
c--------------------------------------------------------------------
c     on stocke les integrales <ijkl> telles que
c     i.gt.k   j.gt.l   (ik.gt.jl) ce qui revient a supprimer les
c     egalites
c     on lit :
c               --->---
c              |       |
c              i > j   k   l
c                  |       |
c                   --->---
c
c--------------------------------------------------------------------
c
 4    if(i.eq.j) goto 1
      if(i.eq.k) goto 1
      if(i.eq.l) goto 1
      if(j.eq.k) goto 1
      if(j.eq.l) goto 1
      if(k.eq.l) goto 1
c     if(yw) then
c     write(75,*)'int gardee',i,j,k,l,b,'$'
c     call scril
c     endif
c     print*,'jrec avant stodir',iesp(i3:i3+norb-1)
c
c*****************************************************************
c     stockage de l'integrale su la file temporaire a acces direct
c*****************************************************************
c
      call stodir(i,j,k,l,b,ifile,esp1(i5r8),
     *iesp(i1),iesp(i2),irec,iesp(i3),cesp(i4))
c     print*,'jrec apres stodir',iesp(i3:i3+norb-1)
 3    continue
 13   continue
c
c***********************
c     integrale suivante
c***********************
c
      goto 1
 2    continue
c      print*,'COUCOU5'
c
c**************************************************************
c     fin du stockage des integrales sur la file a acces direct
c**************************************************************
c
      if(yw1)write(6,*)'appel stdirf'
      call stdirf(esp1(i5r8),
     *iesp(i1),iesp(i2),irec,iesp(i3),cesp(i4))
      if(yw1)write(6,*)'retour stdirf'
c      print*,'COUCOU6'
      icpu1=itemps(idum)-icpu
      if(yw1)write(6,*)'cpu calech stockage des int',icpu1
      call flush(6)
c
c************************************************
c     relecture de la file a acces direct
c     calcul et stockage des integrales d'echange
c************************************************
c
      if(yw1)write(6,*)'appel stoech'
      mxreci=maxreci
      call stoech1(isa,esp1,iesp(i1),itorbi
     *,iesp(i2),irec,iesp(i3),cesp(i4),yesp,i5)
      if(yw1)write(6,*)'retour stoech'
      do k=1,nfil70
         close(numfil70(k),status='DELETE')
      enddo
c     stop
      end
       subroutine stodir(i,j,k,l,b,ifile,hint,krec,ninti,irec,jrec,ind)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(nrec1=1024)
c      parameter(maxrec=(maxorb-1)*(maxorb-1)*(maxorb-2)/(2*nrec1)+1)
c     parameter(maxrec=500)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
c
c----------------------------------------------------
c     STOCKAGE DES INTEGRALES SUR FILE A ACCES DIRECT
c
c     on entre dans la subroutine avec l'int i j k l
c     on regroupe les integrales par classes, en fonction de i
c     on met sa valeur numerique dans hint
c     quand hint est plein (ninti(i) a atteint la limite), on ecrit
c     hint sur la file a acces direct
c
c     ninti(orb i)=numero de l'int pour l'orb i
c     jrec(i) nb d'enr i
c     krec(k,i)  numero du keme enr i dans la liste totale
c     ind(l,k,i) l=1,3 keme jeu de 3 indices pour l'int i
c     hint(ninti(i),i)=integrale numero i de l'enr i
c     irec nb d'enr
c----------------------------------------------------
c
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension ninti(norb),jrec(norb),ind(nind,nrec1,norb)
      character*1 ind,cbid
      dimension hint(nrec1,norb),krec(maxrec,norb)
      common /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      common/pr/nprint,mprint(10)
      yw=.false.
      yw1=.false.
      ninti(i)=ninti(i)+1
      hint(ninti(i),i)=b
c      if(norb.lt.256) then
c         ind(1,ninti(i),i)=char(j)
c         ind(2,ninti(i),i)=char(k)
c         ind(3,ninti(i),i)=char(l)
c      else
cc        alors on ramene j,k,l entre 0 et 255  (dans jj,kk,ll)
cc        jjj donne la zone de l'indice jj (0 si 0-255, 1 si 256-511...)
c         call icorr0(j,jj,ind(1,ninti(i),i),jjj)
c         call icorr0(k,kk,ind(2,ninti(i),i),kkk)
c         call icorr0(l,ll,ind(3,ninti(i),i),lll)
cc        jkl stocke les 3 zones
c         jkl=jjj+kkk*4+lll*16
cc        on stocke tout en caracteres
c         ind(4,ninti(i),i)=char(jkl)
c      endif
      call encod(j,k,l,ibid,
     *ind(1,ninti(i),i),ind(2,ninti(i),i),ind(3,ninti(i),i),cbid,
     *ind(nind,ninti(i),i),3)
c     print*,'stodir',i,j,k,l
      if(yw) then
         write(6,'(a25,4i4,f12.8)')'entree stodir i j k l ',i,j,k,l,b
c        write(75,*)'entree stodir i j k l',i,j,k,l  ,b,'$'
c        call scril
         write(6,'(a25,5i6,f12.8)')'stodir ninti(i),i,ind',ninti(i),i,
     *   (ichar(ind(kkk,ninti(i),i)),kkk=1,3),b
      endif
      if(ninti(i).eq.nrec1) then
         ninti(i)=0
         irec=irec+1
         call dawr(irec,hint(1,i),ind(1,1,i))
         jrec(i)=jrec(i)+1
         if(yw1) then
            write(6,'('' i,irec,jrec(i)'',3i8)')i,irec,jrec(i)
         endif
         if(nprint.ge.3)write(6,*)'ecriture dafile i,irec',i,irec
         call verdim('depassement         jrec(i)    maxrec   ',jrec(i),
     *   maxrec)
         krec(jrec(i),i)=irec
         if(yw) then
            write(75,*)'stodir jrec(i),i,krec(jrec(i),i)',
     *      jrec(i),i,krec(jrec(i),i),'$'
            call scril
         endif
      endif
c      if(yw)write(6,*)'sortie stodir'
      return
      end
       subroutine stdirf(hint,krec,ninti,irec,jrec,ind)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(nrec1=1024)
c      parameter(maxrec=(maxorb-1)*(maxorb-1)*(maxorb-2)/(2*nrec1)+1)
c     parameter(maxrec=500)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
c
c----------------------------------------------------
c     FIN STOCKAGE DES INTEGRALES SUR FILE A ACCES DIRECT
c
c     ninti(orb i)=numero de l'int pour l'orb i
c     jrec(i) nb d'enr i
c     krec(k,i)  numero du keme enr i dans la liste totale
c     ind(l,k,i) l=1,3 keme jeu de 3 indices pour l'int i
c     hint(ninti(i),i)=integrale numero i de l'enr i
c     irec nb d'enr
c----------------------------------------------------
c
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension ninti(norb),jrec(norb),ind(nind,nrec1,norb)
      character*1 ind
      dimension hint(nrec1,norb),krec(maxrec,norb)
      common /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      common/pr/nprint,mprint(10)
      yw=.false.
      yw1=.false.
      do ii=1,norb
         irec=irec+1
         jrec(ii)=jrec(ii)+1
         if(nprint.ge.3)write(6,*)'ecriture dafile ii,irec',ii,irec
         if(yw1) then
            write(6,'('' ii,irec,jrec(ii)'',3i8)')ii,irec,jrec(ii)
         endif
         call verdim
     *   ('depassement        jrec(ii)    maxrec   ',jrec(ii),
     *   maxrec)
c         write(6,*)'ii',ii
c         write(6,*)'jrec(ii)',jrec(ii)
         krec(jrec(ii),ii)=irec
         if(yw) then
            write(75,*)'stdirf jrec(ii),ii,krec(jrec(ii),ii),ninti(i)',
     *      jrec(ii),ii,krec(jrec(ii),ii),ninti(ii),'$'
            call scril
         endif
c         write(6,*)'ii',ii
c         write(6,*)'jrec(ii)',jrec(ii)
         call dawr(irec,hint(1,ii),ind(1,1,ii))
      enddo
      if(yw) then
         write(6,*)'fin stdirf'
         write(6,*) 'irec',irec
         write(6,*)'nb d''enr pour l''orb i  jrec',(jrec(k),k=1,norb)
         do ii=1,norb
            write(6,*)
     *      'num d''enr pour l''orb ii,krec(k,ii),(k=1,jrec(ii))',
     *      ii,(krec(k,ii),k=1,jrec(ii))
         enddo
         do i=1,norb
            write(6,*)'stdirf ii,krec(k,ii),(k=1,jrec(ii))',
     *      ii,(krec(k,ii),k=1,jrec(ii))
         enddo
         write(6,*)'nb d''int ds le dernier enr  ninti',
     *   (ninti(kk),kk=1,norb)
      endif
      do k=1,nfil70
         close(numfil70(k))
         open(numfil70(k),file=nomfil70(k),
     *   access='DIRECT',recl=nrec1*(8+nind),status='old')
      enddo
      return
      end
       subroutine stech3
c
c----------------------------------------------------------------
c     stockage des int dir+ech <a b a d>
c----------------------------------------------------------------
c
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxsym=8,ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension cint(ngru3),cintx(ngru3),ind3(4,ngru3)
      character*1 ind3
      common/adr/iadr0(maxsym),nbint
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      yw=.false.
      close(81)
      close(82)
      close(86)
      open(81,file='CD_IJIK',status='old',form='UNFORMATTED')
      open(82,file='CD_IJIKd',status='old',form='UNFORMATTED')
      open(86,file='CD_IJIKx',status='old',form='UNFORMATTED')
c      rewind 81
c      rewind 82
c      rewind 86
      kk=ngru3
      ifin=0
c      print*,'nbint',nbint
      do k=1,nbint
         kk=kk+1
         if(kk.gt.ngru3) then
            ideb=ifin+1
            ifin=min(ideb+ngru3-1,nbint)
            long=ifin-ideb+1
            kk=1
            call lir8(cint,long,82)
            call lir8(cintx,long,86)
            read(81) ((ind3(kkk,l),kkk=1,nind),l=1,long)
         endif
c         if(norb.lt.256) then
c            ia=icar(ind3(1,kk))
c            ib=icar(ind3(2,kk))
c            id=icar(ind3(3,kk))
c         else
c            jkl=ichar(ind3(4,kk))
c            jjj=mod(jkl,4)
c            kkk=mod(jkl-jjj,16)/4
c            lll=jkl/16
c            call irroc0(ia,ind3(1,kk),jjj)
c            call irroc0(ib,ind3(2,kk),kkk)
c            call irroc0(id,ind3(3,kk),lll)
c         endif
         call decod(ind3(nind,kk),ind3(1,kk),ia,ib,id,ibid,3)
         ic=ia
         if(yw)print*,'stech3 ia,ib,ic,id',ia,ib,ic,id
         if(ia.ne.ib.and.ic.ne.id.and.ia.ne.id) then
            hhh=cint(kk)-cintx(kk)
            if(yw)print'(a,3f12.8)','1hhh',hhh,cint(kk),cintx(kk)
            if(ia.le.0.or.ia.gt.maxorb) then
               print*,'ia,ib,id',ia,ib,id
               print*,'1jkl,jjj,kkk,lll',jkl,jjj,kkk,lll
               print*,'kk',kk
               stop
            endif
            if(ib.le.0.or.ib.gt.maxorb) then
               print*,'ia,ib,id',ia,ib,id
               print*,'2jkl,jjj,kkk,lll',jkl,jjj,kkk,lll
               print*,'kk',kk
            endif
            if(id.le.0.or.id.gt.maxorb) then
               print*,'ia,ib,id',ia,ib,id
               print*,'3jkl,jjj,kkk,lll',jkl,jjj,kkk,lll
               print*,'kk',kk
               print*,icar(ind3(3,kk))
            endif
            iia=isbrot(ia)
            iib=isbrot(ib)
            iid=isbrot(id)
c
c--         signe : - si le saut ib --> id se fait par dessus ia
            if(yw)print*,'calech',iia,iib,iid
            if((iid-iia)*(iib-iia).lt.0)
     *      hhh=-hhh
            if(yw)print'(a,f12.8)','2hhh',hhh
c--         signe : - si ia est inactive
            if(itype(ia).eq.1)
     *      hhh=-hhh
            if(yw)print'(a,f12.8)','3hhh',hhh
            call ecr0e(ia,ib,ic,id,hhh)
         endif
      enddo
c      print*,'destruction 82'
      call flush(6)
      close(81)
      close(82)
      close(86)
      return
      end
       subroutine stoech0(itorbi,maxreci)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxorbcas=16,maxsym=8,maxda3=300)
      include 'maxorb.prm'
      common /dim/iadri
      parameter(nrec1=1024)
c      parameter(maxrec=(maxorb-1)*(maxorb-1)*(maxorb-2)/(2*nrec1)+1)
C      parameter(mxrec0=120000)
C      parameter(mxreci=(mxrec0/8)*8)
c      parameter (xreci1=(iadri*8-maxorb*(nrec1*3+2+maxrec)
c     *-nrec1*2)/2.25d0)
c      parameter (xreci2=(iadri*8-maxorb*(nrec1*3+2+maxrec)
c     *-nrec1*2*(1+maxorb))/0.25d0)
c      parameter(mx1=xreci1,mx2=xreci2)
c      parameter (mxreci=mx1)
c     parameter(mxreci=min(mx1,mx2))
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/pr/nprint,mprint(10)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      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 /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      common/opt/ihab,calcul
      character*3 calcul
      dimension itorbi(norb)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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
      common/test/itest(100)
      yw=.false.
      yw1=.false.
      ninte=0
      nintoe=0
      ilime=0
      maxreci=0
c----------boucle sur la 1ere orbitale
      do 1 ia=1,norb
c      if(ytana)write(6,*)'1ere orbitale ',ia
      iia=itorbi(ia)
      isa=itsym(ia)
c------------calcul de idepi----------
c
      idep0=0
      do kkk=1,nsym
         do lll=1,nsym
            idepi(lll,kkk)=-1
         enddo
      enddo
      do isb=1,isa
         do 20 isc=1,isa
         if(yw) then
            write(75,*)'isa,isb,isc',isa,isb,isc,'$'
            call scril
         endif
         isd=its(isa,its(isb,isc))
c           if(yw)write(6,*)'isa,isb,isc,isd',isa,isb,isc,isd
c           if(isd.gt.isb) goto 20
         idepi(isc,isd)=idep0
c           on a ia > ib > ic      et   ia > id > ic
c           ifin est le nombre de valeurs possibles du couple (ib,id)
         if(isa.eq.isb) then
c              alors isc.eq.isd
            if(isb.eq.isc) then
c                 alors ils sont tous egaux
               ifin=(iia-3)*(iia-2)*(iia-1)/3
            else
               ifin=norbs(isc)*(norbs(isc)-1)/2*(iia-1)
            endif
         else
            if(isa.eq.isc) then
c                 alors isa.eq.isc.ne.isb.eq.isd
               ifin=norbs(isc)*(norbs(isc)-1)*(iia-1)
            else
               if(isb.eq.isc) then
c                    alors isa=isd
                  ifin=norbs(isc)*(norbs(isc)-1)*(iia-1)
               else
c                    alors ils sont tous differents
                  ifin=norbs(isb)*norbs(isc)*norbs(isd)
               endif
            endif
         endif
         idep0=idep0+ifin
c      if(idep0.gt.maxreci) then
c         print*,'ia,isa,isb,isc',ia,isa,isb,isc,idep0
c      endif
      call flush(6)
         if(yw)write(6,*)'idepi,ifin,idep0',ifin,idep0
 20      continue
      enddo
c--   calcul des nouvelles dimensions
      mxreci=idep0
      maxreci=max(maxreci,mxreci)
 1    continue
c      print*,'maxreci',maxreci
      return
      end
       subroutine stoech1(isa,esp1,krec,itorbi,
     *ninti,irec,jrec,indtmp,yesp,i5)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxsym=8,maxda3=300)
      include 'maxorb.prm'
      include '../../param/maxlong.prm'
      common /dim/iadri
      parameter(nrec1=1024)
c      parameter(maxrec=(maxorb-1)*(maxorb-1)*(maxorb-2)/(2*nrec1)+1)
C      parameter(mxrec0=120000)
C      parameter(mxreci=(mxrec0/8)*8)
c      parameter (xreci1=(iadri*8-maxorb*(nrec1*3+2+maxrec)
c     *-nrec1*2)/2.25d0)
c      parameter (xreci2=(iadri*8-maxorb*(nrec1*3+2+maxrec)
c     *-nrec1*2*(1+maxorb))/0.25d0)
c      parameter(mx1=xreci1,mx2=xreci2)
c      parameter (mxreci=mx1)
c     parameter(mxreci=min(mx1,mx2))
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/pr/nprint,mprint(10)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      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 /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      common/opt/ihab,calcul
      character*3 calcul
      dimension ninti(norb),jrec(norb)
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension indtmp(nind,nrec1),esp1(iadri*2)
      character*1 indtmp
      dimension krec(maxrec,norb)
      dimension yesp(*)
      dimension itorbi(norb)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      yw=.false.
      yw1=.false.
      ninte=0
      nintoe=0
      ilime=0
      if(yw) then
         write(6,*)'entree stoech1 norb',norb
         do i=1,norb
            write(6,*)'stoech1 i,krec(k,i),(k=1,jrec(i))',
     *      i,(krec(k,i),k=1,jrec(i))
         enddo
      endif
c      print*,'ouverture file CDV_INCH'
c      print*,'open32'
      open(32,file='CDV_INCH',status='UNKNOWN',
     *form='UNFORMATTED')
      call filesplit('OPEN',32,maxlong,idum,irec)
c
c-------------------------------------------------------------
c     stockage des integrales + echange a 3 indices <ijik> ...
c-------------------------------------------------------------
c
      if(ytana)icpu=itemps(idum)
      call stech3
      if(ytana)icpu1=itemps(idum)-icpu
      if(ytana)print*,'cpu dans stech3 ',icpu1
c
c-------------------------------------------------
c     stockage des integrales + echange
c
c     type des integrales stockees
c               ---->----
c              |         |
c              ia > ib   ic < id
c                    |         |
c                     ---->----
c
c     pour les symetries, on a
c               ------>=-----
c              |             |
c              isa >  isb    isc  < isd
c                     |             |
c                      ------>=-----
c
c     ou bien
c               ------>=-----
c              |             |
c              isa  = isb    isc =  isd
c                     |             |
c                      ------>=-----
c
c-------------------------------------------------
c
      if(yw) then
         write(75,*)'nsym,norbs',nsym,norbs,'$'
         call scril
      endif
      inte=0
c----------boucle sur la 1ere orbitale
 
 
C     provisoire
      do 1 ia=1,norb
c      print*,'ia',ia
 
 
 
 
 
 
      if(ytana)icpu=itemps(idum)
      iia=itorbi(ia)
      isa=itsym(ia)
      if(yw) then
         write(75,*)'boucle ia  ia,jrec(ia),ninti(ia),nrec1',
     *   ia,jrec(ia),ninti(ia),nrec1,'$'
         call scril
      endif
c------------calcul de idepi----------
c
      idep0=0
      do kkk=1,nsym
         do lll=1,nsym
            idepi(lll,kkk)=-1
         enddo
      enddo
      do isb=1,isa
         do 20 isc=1,isa
         if(yw) then
            write(75,*)'isa,isb,isc',isa,isb,isc,'$'
            call scril
         endif
         isd=its(isa,its(isb,isc))
c           if(yw)write(6,*)'isa,isb,isc,isd',isa,isb,isc,isd
c           if(isd.gt.isb) goto 20
         idepi(isc,isd)=idep0
c           if(yw)write(6,*)'ia,iia,isb,isc,isd,idepi(isc,isd)',ia,iia,
c     *             isb,isc,isd,idepi(isc,isd),ifin,idep0
c           on a ia > ib > ic      et   ia > id > ic
c           ifin est le nombre de valeurs possibles du couple (ib,id)
         if(isa.eq.isb) then
c              alors isc.eq.isd
            if(isb.eq.isc) then
c                 alors ils sont tous egaux
               ifin=(iia-3)*(iia-2)*(iia-1)/3
            else
               ifin=norbs(isc)*(norbs(isc)-1)/2*(iia-1)
            endif
         else
            if(isa.eq.isc) then
c                 alors isa.eq.isc.ne.isb.eq.isd
               ifin=norbs(isc)*(norbs(isc)-1)*(iia-1)
            else
               if(isb.eq.isc) then
c                    alors isa=isd
                  ifin=norbs(isc)*(norbs(isc)-1)*(iia-1)
               else
c                    alors ils sont tous differents
                  ifin=norbs(isb)*norbs(isc)*norbs(isd)
               endif
            endif
         endif
         idep0=idep0+ifin
         if(yw)write(6,*)'idepi,ifin,idep0',ifin,idep0
 20      continue
      enddo
c--   calcul des nouvelles dimensions
c      mxreci=idep0
      if(yw1)print*,'isa,mxreci',isa,mxreci
      i5r8=i5/2
      i6=i5+mxreci*2
      i6log=i6*4
      i7log=i6log+mxreci
      if(yw)write(6,*)'i5,i6,i6log,i7log',i5,i6,i6log,i7log
      if(i7log/16+15.gt.iadri) then
         write(6,*)'iadri pas assez grand  iadri,i7log'
     *   ,iadri,i7log
         stop
      endif
      do is1=1,nsym
         if(yw.or.nprint.ge.4) then
            write(75,*)'ia',ia,' is1,idepi(is1,is2),is2=1,nsym)'
     *      ,is1,(idepi(is1,is2),is2=1,nsym),'$'
            call scril
         endif
      enddo
c      print*,'avant stoech'
      call stoech(esp1,krec,itorbi,
     *ninti,irec,jrec,indtmp,esp1(i5r8),yesp(i6log),ia)
      if(ytana)icpu1=itemps(idum)-icpu
      if(ytana)print*,'cpu dans stech1, boucle',ia,'  ',icpu1
      if(ytana) call flush(6)
 1    continue
      write(6,*)'nombre d''integrales dir+ech eliminees',ilime
      print*,' '
      call ecr0ef
      return
      end
       subroutine stoech(hintmp,krec,itorbi,
     *ninti,irec,jrec,indtmp,hh,yhh,ia)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxsym=8,maxda3=300)
      include 'maxorb.prm'
      parameter(nrec1=1024)
c      parameter(maxrec=(maxorb-1)*(maxorb-1)*(maxorb-2)/(2*nrec1)+1)
C      parameter(mxrec0=120000)
C      parameter(mxreci=(mxrec0/8)*8)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/pr/nprint,mprint(10)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      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 /clh/ idepi(maxsym,maxsym),maxrec,mxreci
      common/opt/ihab,calcul
      character*3 calcul
      dimension ninti(norb),jrec(norb)
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension indtmp(nind,nrec1),hintmp(nrec1)
      character*1 indtmp
      dimension krec(maxrec,norb)
      dimension hh(mxreci)
      dimension yhh(mxreci)
      dimension itorbi(norb)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      yw=.false.
      yw1=.false.
      nbint=0
c      yw=ia.gt.256
      do i=1,mxreci
         yhh(i)=.false.
         hh(i)=0.d0
      enddo
c
c----------------------------------------------------------------
c         lecture de la file a acces direct et mise en memoire des
c         integrales d'echange
c
c         compte tenu des conditions d'inegalite precedentes,
c         on lit soit :
c         une int directe    4 3 2 1
c         une int directe    4 2 3 1
c         une int d'echange  4 3 1 2
c         si  4 3 1 2    ok, on a bien un echange
c         si  4 3 2 1    4 1 2 3   est un echange et est a stocker
c         si  4 2 3 1    4 1 3 2   n'est pas un echange
c         donc, si ia ib ic id est directe, on stocke ia id ic ib si
c         ib>ic
c----------------------------------------------------------------
c
c---------lecture des matrices sur la file a acces direct
      if(yw)write(6,*)'on lit les mat sur ad ia,jrec(ia)=',ia,jrec(ia)
c     print*,'jrec',jrec(1:norb)
c
c*************************************************************
c     boucle sur les enregistrements contenants des integrales
c     dont le 1er indice est ia
c     le numero de ces enregistrements est donne par krec
c*************************************************************
c
      do 3 irec=1,jrec(ia)
c      print*,'irec',irec
c     print*,'ia,jrec(ia),ninti(ia)',ia,jrec(ia),ninti(ia)
      ifin=nrec1
      if(irec.eq.jrec(ia)) ifin=ninti(ia)
      if(ifin.eq.0) goto 3
      if(yw) then
         write(75,*)'lect da irec,ia,krec(irec,ia)=',
     *   irec,ia,krec(irec,ia),'$'
         call scril
      endif
c-------on lit un bloc d'integrales
      call dare(krec(irec,ia),hintmp,indtmp(1,1))
      ifin=nrec1
      if(irec.eq.jrec(ia)) ifin=ninti(ia)
      if(yw) then
         write(75,*)'irec,jrec(ia),ia,ifin,ninti(ia)',
     *   irec,jrec(ia),ia,ifin,ninti(ia),'$'
         call scril
         write(75,*)'indtmp(1,k),k=1,ifin',
     *   (ichar(indtmp(1,k)),k=1,ifin),'$'
         call scril
         write(75,*)'indtmp(2,k),k=1,ifin',
     *   (ichar(indtmp(2,k)),k=1,ifin),'$'
         call scril
         write(75,*)'indtmp(3,k),k=1,ifin',
     *   (ichar(indtmp(3,k)),k=1,ifin),'$'
         call scril
      endif
      do 5 k=1,ifin
cc     on lit les idices de 0 a 255
c      if(norb.lt.256) then
c         ib=icar(indtmp(1,k))
c         ic=icar(indtmp(2,k))
c         id=icar(indtmp(3,k))
c      else
cc        on decode jkl, indice des zones
cc         jkl=mod(ichar(indtmp(4,k)),256)
c         jkl=ichar(indtmp(4,k))
c         jjj=mod(jkl,4)
c         kkk=mod(jkl-jjj,16)/4
c         lll=jkl/16
cc        on decode les caracteres de indtmp
c         call irroc0(ib,indtmp(1,k),jjj)
c         call irroc0(ic,indtmp(2,k),kkk)
c         call irroc0(id,indtmp(3,k),lll)
c         if(ib.le.0.or.ib.gt.norb) stop 'ib'
c         if(ic.le.0.or.ic.gt.norb) stop 'ic'
c         if(id.le.0.or.id.gt.norb) stop 'id'
c         if(jkl.gt.0) then
cc            print*,'jkl,ib,ic,id',jkl,ib,ic,id
cc            if(ib.eq.256.and.ic.eq.254.and.id.eq.255) yw=.true.
c            call flush(6)
c         endif
c      endif
      call decod(indtmp(nind,k),indtmp(1,k),ib,ic,id,ibid,3)
      if(yw)print*,'k,ia,ib,ic,id',k,ia,ib,ic,id
c--------on reordonne les indices en symetrie
      if(its(its(itsym(ia),itsym(ib)),its(itsym(ic),itsym(id)))
     *   .ne.1) then
         print*,'ia,ib,ic,id',ia,ib,ic,id,itsym(ia),itsym(ib),
     *   itsym(ic),itsym(id)
         print*,'4jkl,jjj,kkk,lll',jkl,jjj,kkk,lll
         print*,icar(indtmp(1,k)),icar(indtmp(2,k)),icar(indtmp(3,k))
         stop
      endif
      if(itsym(ib).lt.itsym(id)) then
         ii=ib
         ib=id
         id=ii
      endif
      if(yw) then
         write(75,*)'stoech indices int',ia,ib,ic,id,'$'
         call scril
      endif
c--------on saute si on n'a pas une integrale d'echange
      if(itsym(ic).gt.itsym(id)) goto 25
      if(itsym(ic).eq.itsym(id)) then
         if(ic.gt.id) goto 25
      endif
      if(yw)write(6,*)'stoech c''est une int d''ech, on adresse'
      call flush(6)
c-------on adresse <4 3 1 2>
c      write(6,*)'idepi',idepi
      if(yw)print*,'avant adrie'
      call flush(6)
      call adrie(ia,ib,ic,id,jrang,idepi,itorbi)
      if(yw)print*,'apres adrie'
      call flush(6)
      if(jrang.gt.mxreci) then
         write(6,*)'int',ia,ib,ic,id
      endif
      nbint=max0(nbint,jrang)
      call verdim('Depassement          jrang    mxreci    ',
     *jrang,mxreci)
      if(yw)write(6,*)'mat lue sur 70',ia,ib,ic,id,hintmp(k),jrang
      call flush(6)
      hh(jrang)=hintmp(k)
      if(yhh(jrang)) then
         write(6,*)'1deja adresse ',ia,ib,ic,id,jrang
c         call adriebis(ia,ib,ic,id,jrang,idepi,itorbi)
         stop
      endif
      hh(jrang)=hintmp(k)
      yhh(jrang)=.true.
      goto 5
 25   continue
c--------si ib>ic ....
      if(itsym(ic).gt.itsym(ib)) goto 5
      if(itsym(ic).eq.itsym(ib)) then
         if(ic.gt.ib) goto 5
      endif
      if(yw)write(6,*)'stoech c''est une int dir-ech, on adresse'
      call flush(6)
c-------....on adresse  ia id ic ib (<4 1 2 3>)
c      write(6,*)'idepi',idepi
      call adrie(ia,id,ic,ib,jrang,idepi,itorbi)
      if(jrang.gt.mxreci) then
         write(6,*)'int',ia,ib,ic,id
      endif
      nbint=max0(nbint,jrang)
      call verdim('depassement          jrang    mxreci    ',
     *jrang,mxreci)
      if(yw)write(6,*)'mat lue sur 70',ia,id,ic,ib,hintmp(k),jrang
      call flush(6)
      if(yhh(jrang)) then
         write(6,*)'2deja adresse ',ia,id,ic,ib,jrang
c         call adriebis(ia,ib,ic,id,jrang,idepi,itorbi)
         stop
      endif
      hh(jrang)=hintmp(k)
      yhh(jrang)=.true.
 5    continue
      if(yw)write(6,*)'sortie boucle 5'
      call flush(6)
 3    continue
c
c----------------------------------------------------------------
c                operation int+echange, puis stockage
c----------------------------------------------------------------
c
      if(yw)write(6,*)'operation int + echange'
      call flush(6)
c       lecture des matrices sur la file a acces direct
      do 13 irec=1,jrec(ia)
c-------on lit un bloc d'integrales
      call dare(krec(irec,ia),hintmp,indtmp(1,1))
      ifin=nrec1
      if(irec.eq.jrec(ia)) ifin=ninti(ia)
      do 15 k=1,ifin
c      if(norb.lt.256) then
c         ib=icar(indtmp(1,k))
c         ic=icar(indtmp(2,k))
c         id=icar(indtmp(3,k))
c      else
c         jkl=ichar(indtmp(4,k))
c         jjj=mod(jkl,4)
c         kkk=mod(jkl-jjj,16)/4
c         lll=jkl/16
c         call irroc0(ib,indtmp(1,k),jjj)
c         call irroc0(ic,indtmp(2,k),kkk)
c         call irroc0(id,indtmp(3,k),lll)
c      endif
      call decod(indtmp(nind,k),indtmp(1,k),ib,ic,id,ibid,3)
      if(yw) then
         write(75,*)'stoech2 indices int',ia,ib,ic,id,'$'
         call scril
      call flush(6)
      endif
c------on saute les integrales d'echange
      if(itsym(ic).lt.itsym(id)) goto 18
      if(itsym(ic).eq.itsym(id)) then
         if(ic.lt.id) goto 18
      endif
c
c--------------------------------------------------------------
c     on a une integrale directe
c     ia   ib   ic > id
c     autre ecriture 4 3 2 1  ou  4 2 3 1
c     si on a 4 3 2 1  il faut stocker <4 3 2 1> - <4 3 1 2> (cas 1)
c     si on a 4 2 3 1  il faut stocker <4 2 3 1> - <4 2 1 3> (cas 2)
c                                  ET  <4 1 3 2> - <4 1 2 3>
c     le test a faire est ib >? ic
c--------------------------------------------------------------
c
      if(yw)print*,'on a une int directe'
      call flush(6)
c------on stocke <ia,ib,ic,id> - ech
      if(itsym(ib).lt.itsym(ic)) goto 19
      if(itsym(ib).eq.itsym(ic)) then
         if(ib.lt.ic) goto 19
      endif
c
c  ---on est dans le cas <4 3 2 1>
c  ---int d'echange correspondante <4 3 1 2>
      call adrie(ia,ib,id,ic,jrang,idepi,itorbi)
      if(yw) then
         write(6,'(a,4i4,3f12.8,i6)')
     *   'ecriture1 sur CDV_INCH ia,ib,ic,id,jrang'
     *   ,ia,ib,ic,id,hintmp(k),hh(jrang),hintmp(k)-hh(jrang),jrang
      call flush(6)
      endif
c     write(32,*)ia,ib,ic,id,hintmp(k)-hh(jrang)
      call ecr0e(ia,ib,ic,id,hintmp(k)-hh(jrang))
      goto 18
 19   continue
c
c  ---on est dans le cas <4 2 3 1>
c  ---int d'echange correspondante <4 2 1 3> a trouver en <4 3 1 2>
      call adrie(ia,ic,id,ib,jrang,idepi,itorbi)
      if(yw) then
         write(6,'(a,4i4,3f12.8,i6)')
     *   'ecriture2 sur CDV_INCH ia,ic,id,ib,jrang'
     *   ,ia,ib,ic,id,hintmp(k),hh(jrang),hintmp(k)-hh(jrang),jrang
      call flush(6)
      endif
c     write(32,*)ia,ib,ic,id,hintmp(k)-hh(jrang)
      call ecr0e(ia,ib,ic,id,hintmp(k)-hh(jrang))
c  ---puis stocker <4 1 3 2> - <4 1 2 3>
      call adrie(ia,id,ib,ic,jrang,idepi,itorbi)
      if(yw) then
         write(6,'(a,4i4,3f12.8,i6)')
     *   'ecriture3 sur CDV_INCH ia,id,ib,ic,jrang'
     *   ,ia,ib,ic,id,hintmp(k),hh(jrang),hintmp(k)-hh(jrang),jrang
      call flush(6)
      endif
c     write(32,*)ia,id,ic,ib,hintmp(k)-hh(jrang)
      call ecr0e(ia,id,ic,ib,hintmp(k)-hh(jrang))
c
 18   continue
 15   continue
 13   continue
c 1    continue
      return
      end
       subroutine maz34(ninti,jrec,irec)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(nrec1=1024)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension ninti(*),jrec(*)
      irec=0
      do 1 i=1,norb
      jrec(i)=0
 1    ninti(i)=0
      open(70,file='BID70',
     *access='DIRECT',recl=nrec1*(8+nind),status='unknown')
      return
      end
       subroutine dare(irec,hint,ind)
      parameter(nrec1=1024)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension hint(nrec1),ind(nrec1*nind)
      character*1 ind
      yw=.false.
      k=(irec-1)/maxrec70
      if(yw)print*,'maxrec70,irec,k',maxrec70,irec,k
      ifile=numfil70(1+k)
      kkrec=irec-k*maxrec70
      if(yw)print*,'dare ifile,kkrec',ifile,kkrec
      read(ifile,rec=kkrec)hint,ind
      return
      end
       subroutine dawr(irec,hint,ind)
      parameter(nrec1=1024)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*7 nomfil70
      dimension hint(nrec1),ind(nrec1*nind)
      character*1 ind
      yw=.false.
      maxfil70=4
      kkrec=irec-(nfil70-1)*maxrec70
      if(kkrec.gt.maxrec70) then
         if(nfil70.gt.maxfil70) then
            print*,'trop de files 70'
            stop
         endif
         nfil70=nfil70+1
         ifile=numfil70(nfil70)
         kkrec=irec-(nfil70-1)*maxrec70
         print*,'ouverture ',nomfil70(nfil70),numfil70(nfil70)
         open(numfil70(nfil70),file=nomfil70(nfil70),
     *   access='DIRECT',recl=nrec1*(8+nind),status='unknown')
      endif
      ifile=numfil70(nfil70)
      if(yw)print*,'dawr ecr, ifil,kkrec',ifile,kkrec
      write(ifile,rec=kkrec)hint,ind
      return
      end
       subroutine ecr0e(i,j,k,l,a)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxda3=300)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      character*4 hab
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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
      character*1 iint,jnt,knt,lnt,ijklnt
      common/wcle/ aaint(4096),iint(4096),jnt(4096),knt(4096),lnt(4096)
      common/wcle1024/ ijklnt(4096)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      yw=.false.
c      4 cartes commentees provisoirement
c      if(dabs(a).eq.0.d0) then
c         ilime=ilime+1
c         return
c      endif
      ninte=ninte+1
      nintoe=nintoe+1
      ni=i
      nj=j
      nk=k
      nl=l
c      if(norb.ge.256) then
cc        on ramene ni,nj,nk,nl dans la zone 0-255
cc        icorr,jcorr... indiquent les zones de ni,nj...
c         call correch(ni,icorr)
c         call correch(nj,jcorr)
c         call correch(nk,kcorr)
c         call correch(nl,lcorr)
c         ijklcorr=icorr+jcorr*4+kcorr*16+lcorr*64
c         ijklnt(ninte)=char(ijklcorr)
c      endif
c      iint(ninte)=char(ni)
c      jnt(ninte)=char(nj)
c      knt(ninte)=char(nk)
c      lnt(ninte)=char(nl)
      call encod(ni,nj,nk,nl,iint(ninte),jnt(ninte),
     *knt(ninte),lnt(ninte),ijklnt(ninte),4)
c        write(6,*)'ecr0e ninte iint,jnt,knt,lnt'
c    *   ,iint(ninte),jnt(ninte),knt(ninte),lnt(ninte)
c        write(6,*)'ecr0e i,j,k,l',i,j,k,l
      !write(6,'('' ecr0e '',4i4,f12.8)')i,j,k,l,a
      ii=i
      jj=j
      kk=k
      ll=l
      isgn=1
      if(ii.lt.jj) then
         ii=j
         jj=i
         isgn=-isgn
      endif
      if(kk.lt.ll) then
         kk=l
         ll=k
         isgn=-isgn
      endif
      if(ii.lt.kk.or.(ii.eq.kk.and.jj.lt.ll)) then
      iii=ii
      ii=kk
      kk=iii
      iii=jj
      jj=ll
      ll=iii
      endif
      if(yw)write(6,'('' ecr0e '',4i4,f12.8)')ii,jj,kk,ll,a*isgn
      aaint(ninte)=a
      if(ninte.ne.4096) return
      entry ecr0ef
      if(norb.lt.256) then
         call filesplit('WRITE',32,12*4096,idum,irec)
         write(32) iint,jnt,knt,lnt,aaint
      else
         call filesplit('WRITE',32,13*4096,idum,irec)
         write(32) iint,jnt,knt,lnt,aaint,ijklnt
      endif
      ninte=0
      return
      end
       subroutine correch(ni,icorr)
      icorr=ni/256
      if(ni.lt.256) return
      ni=mod(ni,256)
      return
      end
       subroutine calech63(esp1,iesp,yesp,cesp,ierr)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      include 'maxorb.prm'
      parameter(maxsym=8,maxorbcas=16,maxda3=300)
      common/fil63/ ijcl21,ijcl31,ijcl41
      character*80  ijcl21,ijcl31,ijcl41
      integer*2 iint(4096),jnt(4096),knt(4096),lnt(4096)
      dimension aa(3,4096)
      integer(8) ilime,nintoe,ninte
      common/l0e/ilime,nintoe,ninte
      dimension ajktmp(maxorb,maxorb)
      common /orb/ enuc,eref,norb,noca,nocb
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      include '../../param/maxlong.prm'
      yw=.false.
c
c--------------------------------------------------------------------
c     CALCUL DES INTEGRALES DIRECTE + ECHANGE
c--------------------------------------------------------------------
c
      print*,' '
      call cpu_time(t1)
      print*,'================================================='
      print*,'Fabrication du fichier d''int (direct - echange)'
      print*,'================================================='
      open(32,file='CDV_INCH',status='UNKNOWN',
     *form='UNFORMATTED')
      call filesplit('OPEN',32,maxlong,idum,irec)
      nintoe=0
      ninte=0
! 2 indices
      open(98,file=ijcl21,form='unformatted',status='old')
         read(98) ((ajktmp(k,l),k=1,norb),l=1,norb)
         do i=1,norb
            do j=1,i-1
               call ecr0e(i,j,i,j,ajktmp(i,j)-ajktmp(j,i))
            enddo
         enddo
      close(98)
! 3 indices
      open(98,file=ijcl31,form='unformatted',status='old')
      n=4096
 3    continue
      n=n+1
      if(n.gt.4096) then
         read(98)iint,jnt,knt,((aa(kk,ll),kk=1,2),ll=1,4096)
         n=1
      endif
      i=iint(n)
      k=jnt(n)
      j=knt(n)
      if(k.eq.0) goto 4
      iia=isbrot(i)
      iib=isbrot(j)
      iid=isbrot(k)
      hhh=aa(1,n)-aa(2,n)
      if(yw)print'(a,6i4,f12.8)','CALECH63',i,j,k,iia,iib,iid,hhh
c--   signe : - si le saut ib --> id se fait par dessus ia
      if((iid-iia)*(iib-iia).lt.0) hhh=-hhh
      if(yw)print*,'2hhh',hhh
c--   signe : - si ia est inactive
      if(itype(i).eq.1) hhh=-hhh
c <i,j,k,l> ecrit en notation physique
      call ecr0e(i,j,i,k,hhh)
c      print*,'ECHANGE ECRIT',i,j,k,l
      goto 3
 4    continue
      close(98)
! 4 indices
! on lit maxorb sur 98
      open(98,file=ijcl41,form='unformatted',status='old')
      read(98) maxlong_98
      close(98)
! on ouvre
      open(98,file=ijcl41,form='unformatted',status='old')
      call filesplit('OPEN',98,maxlong_98,idum,idum2)
      call filesplit('READ',98,4,ichange,idum2)
      read(98) maxlong_98
      n=4096
 1    continue
      n=n+1
      if(n.gt.4096) then
         call filesplit('READ',98,65536*2,ichange,idum2)
         read(98)iint,jnt,knt,lnt,aa
         n=1
      endif
      i=iint(n)
      j=jnt(n)
      k=knt(n)
      l=lnt(n)
      if(k.eq.0) goto 2
c <i,j,k,l> ecrit en notation physique
      call ecr0e(i,j,k,l,aa(1,n)-aa(2,n))
      call ecr0e(i,k,j,l,aa(3,n)-aa(2,n))
      call ecr0e(i,l,j,k,aa(3,n)-aa(1,n))
c      print*,'ECHANGE ECRIT',i,j,k,l
      goto 1
 2    continue
      close(98)
      call ecr0ef
      call cpu_time(t0)
      print'(a,f10.1,a)','cpu',t0-t1,' sec'
      return
      end
