      subroutine adrin(nbint,ifac,bint,ind3,yint)
      use mod_script
      parameter(maxsym=8,maxorbcas=16,ngru3=2048)
      include 'maxorb.prm'
      parameter(maxda3=300)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
c                   nbint          nbint*2                 iadri*2
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-*-*-*-*-*-|
c    |     bint      |ind3 | |
c                           yint
c
      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 /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /dim/ iadri
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*5 nomfil70
      dimension bint(nbint*ifac),yint(nbint*ifac),ind3(nind,nbint*ifac)
      character*1 ind3
      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
      character*4 hab
      character*80 aa
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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
      integer(8) ilimi,ilimi4,nintot,nintot4,nint
      common/l0/ilimi,ilimi4,nintot,nintot4,nint,ycl
      common/test/itest(100)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common/sy7/inumsy(maxsym,maxorb)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      logical*1 bidia
      character*80 mono1
      common/files/ mono1
      dimension ajktmp(maxorb,maxorb)
      dimension aijjj(maxorb,maxorb)
      dimension a63(2)
      common/fil63/ ijcl21,ijcl31,ijcl41
      character*80  ijcl21,ijcl31,ijcl41
      common/pliadri/ipliadri(2)
      yw=.false.
      yw1=.false.
      nter=norb*(norb+1)/2
      if(irest.eq.1.or.irest.eq.2) then
         open(36,file='CD_JKF',form='unformatted',status='old')
         read(36) nintot,sint,ilimi,sint4,ilimi4
         print*,'irest=',irest,'    lectures du passage precedent :'
         write(6,1001)'nombre d''integrales bielectroniques ', nintot
         write(6,1002)'seuils d''elimination des integrales ',sint,sint4
         write(6,1001)'nombre d''integrales eliminees',ilimi,ilimi4
         write(6,*)' '
         write(6,*)'================================================ '
         write(6,*)' '
         call lir8(aj,nter,36)
         call lir8(ak,nter,36)
         call lir8(hmono,nter,36)
         close(36)
         do 41 l=1,nter
         f(l)=hmono(l)
 41      ajk(l)=aj(l)-ak(l)
         return
      endif
 1001 format(a40,2i12)
 1002 format(a40,2d8.2)
c
c-------------------------------------------------------
c     stockage des int du type <i k j k> et <i k k j>
c-------------------------------------------------------
c
c----test sur l'adressage des integrales
      open(81,file='CD_IJIK',status='unknown',form='UNFORMATTED')
      open(82,file='CD_IJIKd',status='unknown',form='UNFORMATTED')
      open(86,file='CD_IJIKx',status='unknown',form='UNFORMATTED')
      if(yw)print*,'adrin nbint',nbint
! Si iadri n'est pas assez grand a ce niveau,
! repartir au debut du programme
      !print*,"nbint*ifac,iadri",nbint*ifac,iadri
      ipliadri(2)=0
      if(nbint*ifac>iadri) then
         ipliadri(1)=nbint*ifac
         ipliadri(2)=1
          !print*,'Ipliadri',ipliadri
         return
      endif
      do k=1,nbint*ifac
         yint(k)=.false.
      enddo
      call cd050(ind3,nbint*ifac,yint)
c----
      nintot=1
c
c--   lecture des integrales  stockage des int directes
      ycas=ygcas.and.itest(52).eq.1
      if(itest(63).ge.1) then
         write(6,*) ' '
         write(6,*) '================================================ '
         write(6,*) '   Lecture des integrales a 2 et 3 indices  adrin'
         write(6,*) '================================================ '
         write(6,*) ' '
         open(98,status='old',file=ijcl21,form='unformatted')
         read(98) ((ajktmp(i,j),j=1,norb),i=1,norb)
         read(98) ((aijjj(i,j),j=1,norb),i=1,norb)
C         print*,'ajk'
C         call mscript(ajktmp(1:norb,1:norb))
C         print*,'aijjj'
C         call mscript(aijjj(1:norb,1:norb))
C         stop
         ij=0
         do i=1,norb
            do j=1,i
               ij=ij+1
               aj(ij)=ajktmp(i,j)
               ak(ij)=ajktmp(j,i)
            enddo
         enddo
         nintot=nintot+norb*norb
         if(ycas) open(99,status='unknown',file='IJCAS3')
      else
         write(6,*) ' '
         write(6,*) '================================================ '
         write(6,*) '     Lecture des integrales sur ijcl  (subr adrin)'
         write(6,*) '================================================ '
         write(6,*) ' '
         if(ycas) open(99,status='unknown',file='IJCAS')
      endif
      do k=1,nbint*ifac
         yint(k)=.false.
         bint(k)=0.d0
      enddo
 
      if(itest(63).eq.0) then
         call liri00
   1     continue
         call lirin0(i,j,k,l,a)
         if(k.eq.0) goto 2
         nintot=nintot+1
         if(yw)write(6,*)'int lue',i,k,j,l,a
         if(i.eq.j.and.k.eq.l) then
            imin=min(i,k)
            imax=max0(i,k)
            aj(imax*(imax-1)/2+imin)=a
         endif
         if((i.eq.l.and.j.eq.k).or.(i.eq.k.and.j.eq.l)) then
            imin=min(i,j)
            imax=max0(i,j)
            ak(imax*(imax-1)/2+imin)=a
         endif
         if(ycas) then
            ybon=itype(i).eq.2.and.itype(j).eq.2.and
     *      .itype(k).eq.2.and.itype(l).eq.2
            ybon=ybon.or.i.eq.j
            ybon=ybon.or.k.eq.l
            if(.not.ybon) goto 1
            write(99,'(4i4,d20.12)') i,j,k,l,a
c               print*,'ecr 99',i,j,k,l,a
         endif
         call cd05(i,k,j,l,a,ind3,bint,yint,nbint)
         if(ifac.eq.2) then
            call cd05x(i,k,j,l,a,bint(nbint+1),yint(nbint+1))
         endif
         goto 1
 2       continue
      else if(itest(63).ge.1) then
         call liri00363(3)
 631     continue
         call lirin3063(i,j,k,a63)
         if(yw)
     *   write(6,'(a,3i4,2f12.8,i6)')'int 3 lue',i,k,j,a63(1:2),nintot
         if(k.eq.0) goto 632
         nintot=nintot+1
         if(ycas) then
c ATTENTION : on stockait TOUTES les int pour gener='CAS'
c on ne stocke maintenant que celles a 3 indices
c Il faudra stocker les autres plus tard
            ybon=itype(i).eq.2.and.itype(j).eq.2.and
     *      .itype(k).eq.2
            if(.not.ybon) goto 631
            write(99,'(4i4,d20.12)') i,j,k,a
         endif
         call cd0563(i,j,k,a63(1),ind3,bint,yint,nbint)
         goto 631
 632     continue
c On lit maintenant les integrales a 2 indices
!          print*,'ajktmp'
!         do i=1,norb
!            do j=1,i-1
!               call cd0563(i,j,j,ajktmp(i,j),ind3,bint,yint,nbint)
!            enddo
! 731        continue
!         enddo
          if(yw)print*,'aijjj'
         do ii=1,norb
            do jj=1,ii-1
           !print*,'ii1',ii,jj,itsym(ii),itsym(jj)
               if(itsym(ii).ne.itsym(jj)) goto 731
               i=ii
               j=jj
               call cd0563(j,i,j,aijjj(j,i),ind3,bint,yint,nbint)
 731           continue
            enddo
           ! print*,'coucou'
            do jj=ii+1,norb
           !print*,'ii2',ii,jj,itsym(ii),itsym(jj)
               if(itsym(ii).ne.itsym(jj)) goto 733
               i=ii
               j=jj
               call cd0563(j,j,i,aijjj(j,i),ind3,bint,yint,nbint)
 733           continue
            enddo
         enddo
 
      endif
 
      ifin=0
      do kk=1,nbint,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,nbint)
         write(81)((ind3(kkk,ll),kkk=1,nind),ll=ideb,ifin)
      enddo
      call ecr8bl(bint,nbint,82)
      if(ifac.eq.2) call ecr8bl(bint(nbint+1),nbint,86)
c
c-----------------------------------------------
c     stockage des integrales monoelectroniques
c-----------------------------------------------
c
      open(36,file='CD_JKF',form='unformatted',status='unknown')
      !print*,'info ecrite sur CD_JKF',nintot,sint,ilimi,sint4,ilimi4
      write(36) nintot,sint,ilimi,sint4,ilimi4
      call ecr8(aj,nter,36)
      call ecr8(ak,nter,36)
      if(ycl) then
         nn=norb*(norb+1)/2
         do kk=1,nn
            hmono(kk)=0.d0
         enddo
         imin=min(i,j)
         imax=max0(i,j)
         hmono(imax*(imax-1)/2+imin)=a
         if(ycas) write(99,'(4i4,d20.12)') i,j,k,l,a
         do ii=1,nn-1
c            do jj=1,ii
c               if(its(ii,jj).ne.1) goto 26
               call lirin0(i,j,k,l,a)
               if(i.eq.0) goto 266
               if(ycas) write(99,'(4i4,d20.12)') i,j,k,l,a
               imin=min(i,j)
               imax=max0(i,j)
               hmono(imax*(imax-1)/2+imin)=a
               if(i.eq.norb.and.j.eq.norb) goto 5
 26             continue
c            enddo
         enddo
 266     continue
      else
c         open(8,file=mono1,form='unformatted',status='old')
c        essai de lecture en blocs de symetrie
         rewind 8
         read(8) aa
 16      continue
         read(8) aa
         !print*,aa
         read(8)
         read(8)
         !print*,'coucou',index(aa,'ONEINT MATRIX (SYM)')
         if(index(aa,'ONEINT MATRIX (SYM)').eq.0) goto 16
         !print*,'coucou1'
         !print*,'index',index(aa,'ONEINT MATRIX (SYM)')
         backspace (8)
         backspace (8)
         read(8) nn,nsym
         !print*,'nn,nsym',nn,nsym
         call lir8(ajk,nn,8)
         !do k=1,nn
         !print'(i8,f10.6)',k,ajk(k)
         !enddo
         !stop
         rewind 8
         read(8) aa
         goto 17
 18      continue
         read(8) aa
         read(8)
         read(8)
c        essai de lecture en triangle
         if(index(aa,'ONEINT MATRIX (TOTAL)').eq.0) goto 18
         !print*,'index',index(aa,'ONEINT MATRIX (TOTAL)')
         backspace (8)
         backspace (8)
         read(8) nn,nsym
         call lir8(ajk,nn,1)
 17      continue
         close(8)
         kk=0
         do is=1,nsym
            do i=1,norbs(is)
               ii=inumsy(is,i)
               do j=1,i
                  jj=inumsy(is,j)
                  kk=kk+1
                  hmono(ii*(ii-1)/2+jj)=ajk(kk)
                  if(yw)print'(a,3i4,f12.8)',
     *            'hmono',is,i,j,hmono(ii*(ii-1)/2+jj)
               enddo
            enddo
         enddo
      endif
      kk=0
 5    continue
      rewind 26
c      if(stop.ne.'FIN') then
      call ecr8(hmono,nter,36)
c      print*, 'aj',(aj(k),k=1,36)
c      print*, 'ak',(ak(k),k=1,36)
c      print*, 'hmono',(hmono(k),k=1,36)
      close(36)
c      endif
 15   do l=1,nter
         f(l)=hmono(l)
         ajk(l)=aj(l)-ak(l)
      enddo
      
C      print*,'HMONO'
C      ifin=0
C      do i=1,norb
C         ideb=ifin+1
C         ifin=ifin+i
C         print'(10f8.4)',hmono(ideb:ifin)
C      enddo
C      stop
               
c---------------------------------------------------------
c     lecture des integrales  stockage des int d'echange
c---------------------------------------------------------
      if(ifac.eq.2) goto 200
      do k=1,nbint
         yint(k)=.false.
         bint(k)=0.d0
      enddo
      if(itest(63).eq.0) then
         call liri00
 3       continue
c         read(26,*)i,j,k,l,a
 6       call lirin0(i,j,k,l,a)
         if(k.eq.0) goto 4
         if(yw)write(6,*)'int lue',i,k,j,l,a
         if(ycas) then
            if(itype(i).ne.2.or.itype(i).ne.2.or
     *      .itype(i).ne.2.or.itype(i).ne.2) goto 6
         endif
         call cd05x(i,k,j,l,a,bint,yint)
         goto 3
 4       continue
      else if(itest(63).ge.1) then
         call liri00363(3)
 633     continue
         call lirin3063(i,j,k,a63)
         if(k.eq.0) goto 634
         if(yw)write(6,*)'int lue',i,k,j,a
         if(ycas) then
            ybon=itype(i).eq.2.and.itype(j).eq.2.and
     *      .itype(k).eq.2
            if(.not.ybon) goto 633
         endif
         call cd05x63(i,j,k,a63(2),bint,yint)
         goto 633
 634     continue
         close(98)
         do k=1,nbint
         if(yw)print*,'yint',k,yint(k)
         enddo
c On lit maintenant les integrales a 2 indices
         do ii=1,norb
            do jj=1,ii-1
           if(yw)print*,'ii1',ii,jj,itsym(ii),itsym(jj)
               if(itsym(ii).ne.itsym(jj)) goto 735
               i=ii
               j=jj
               call cd05x63(j,i,j,aijjj(j,i),bint,yint)
 735           continue
            enddo
            do jj=ii+1,norb
           if(yw)print*,'ii2',ii,jj,itsym(ii),itsym(jj)
               if(itsym(ii).ne.itsym(jj)) goto 736
               i=ii
               j=jj
               call cd05x63(j,j,i,aijjj(j,i),bint,yint)
 736           continue
            enddo
         enddo
!          print*,'ajktmp ech'
!         do i=1,norb
!            do j=1,i-1
!               call cd05x63(i,j,j,ajktmp(j,i),ind3,bint,yint,nbint)
!            enddo
! 732        continue
!         enddo
      endif
      call ecr8bl(bint,nbint,86)
 
 200  if(ycas) then
         close(99)
         close(26)
         open(26,status='old',file='IJCAS')
         ycl=.true.
      endif
 
 
c
c--   lecture des integrales  stockage des int d'echange
      if(yw1) print*,'fin adrin'
      return
      end
       subroutine lirine(i,j,k,l,a)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      character*1 iint,jnt,knt,lnt,ijklnt
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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
      common/test/itest(100)
      ninte=ninte+1
      if(ninte.gt.4096) then
         if(norb.lt.256) then
            !print*,'read32'
            call filesplit('READ',32,12*4096,idum,irec)
            read(32) iint,jnt,knt,lnt,aaint
         else
            !print*,'read32'
            call filesplit('READ',32,13*4096,idum,irec)
            read(32) iint,jnt,knt,lnt,aaint,ijklnt
         endif
         ninte=1
      endif
c      if(norb.lt.256) then
c         i=ichar(iint(ninte))
c         j=ichar(jnt(ninte))
c         k=ichar(knt(ninte))
c         l=ichar(lnt(ninte))
c         if(i.lt.0) i=i+256
c         if(j.lt.0) j=j+256
c         if(k.lt.0) k=k+256
c         if(l.lt.0) l=l+256
c      else
c         call decodi(ijklnt(ninte),k1,k2,k3,k4)
c         call irroc0(i,iint(ninte),k1)
c         call irroc0(j,jnt(ninte),k2)
c         call irroc0(k,knt(ninte),k3)
c         call irroc0(l,lnt(ninte),k4)
c      endif
      call decod1(ijklnt(ninte),iint(ninte),jnt(ninte),
     *knt(ninte),lnt(ninte),
     *i,j,k,l,4)
c        write(6,*)'lirine ninte iint,jnt,knt,lnt'
c    *   ,iint(ninte),jnt(ninte),knt(ninte),lnt(ninte)
c        write(6,*)'lirine i,j,k,l',i,j,k,l
      a=aaint(ninte)
      return
      entry liri0e
      call filesplit('REWIND',32,0,idum,irec)
      rewind 32
      if(norb.lt.256) then
            !print*,'read32'
         call filesplit('READ',32,12*4096,idum,irec)
         read(32) iint,jnt,knt,lnt,aaint
      else
            !print*,'read32'
         call filesplit('READ',32,13*4096,idum,irec)
         read(32) iint,jnt,knt,lnt,aaint,ijklnt
      endif
      ninte=0
      return
      end
 
       subroutine cd050(ind3,nbint,yint)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/calch/nind,maxrec70,nfil70,numfil70(4),nomfil70(4)
      character*5 nomfil70
      character*1 ind3(nind,nbint),cbid
      common/dim/iadri ; integer(8) iadri
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/sy7/inumsy(maxsym,maxorb)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
 
c
c-----------------------------------------
c     stockage des int du type <i k j k>
c     generation de tous les triplets d'indices
c-----------------------------------------
c
      dimension yint(nbint)
      yw=.false.
c     nnnn=0
c     print*,'norbs',(norbs(k),k=1,nsym)
      do icom=1,norb
         do is=1,nsym
            do maxis=2,norbs(is)
               maxi=inumsy(is,maxis)
               do minis=1,maxis-1
                  mini=inumsy(is,minis)
c                 nnnn=nnnn+1
                  call adri(icom,mini,maxi,iadr)
                  if(yw)write(6,*)'adr icom,maxi,mini,iadr'
     *            ,icom,maxi,mini,iadr
                  if(yint(iadr)) then
                     write(6,*)'adrin deja',icom,maxi,mini,iadr
                     stop
                  endif
                  yint(iadr)=.true.
c                  if(norb.lt.256) then
c                     ind3(1,iadr)=char(icom)
c                     ind3(2,iadr)=char(mini)
c                     ind3(3,iadr)=char(maxi)
c                  else
c                     call icorr0(icom,jj,ind3(1,iadr),jjj)
c                     call icorr0(mini,kk,ind3(2,iadr),kkk)
c                     call icorr0(maxi,ll,ind3(3,iadr),lll)
c                     jkl=jjj+kkk*4+lll*16
c                     ind3(4,iadr)=char(jkl)
c                  endif
                  call encod(icom,mini,maxi,ibid,ind3(1,iadr),
     *            ind3(2,iadr),ind3(3,iadr),cbid,ind3(nind,iadr),3)
               enddo
            enddo
         enddo
      enddo
      return
      end
