      subroutine lirint(esp1)
      parameter(maxsym=8,maxorbcas=16,maxda3=300)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/opt/ihab,calcul
      character*3 calcul
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      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 /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
      character*4 hab
      logical*1 bidia
      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
      common/pr/nprint,mprint(10)
      common/rr/ idebd(maxorb*maxorb*2),idebd3(maxorb*maxsym)
     *,idebd1(maxorb)
      dimension ilond(maxsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/test/itest(100)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common/dispre/ivvvv1,ioooo2,ivovo3,ivvoo4,
     *iovvo5,ivooo6,ivoov7,ivvvc8
     *,iccvv9,icvcv10,ioocc11,iococ12
     *,icovv13,icvov14,icvoo15,icovo16
     *,icooo17,iccov18,icocv19,iccco20,icccv21,icccc22
      character*1 syspin,syspins
      common /sysp1/syspin
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common/ipoin76/ip76
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c
      common/dimis/ iadris,iadristp,maxsps
      common/tps/icpu(10)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      common/pert/schift,damp,ypertu,ycaspert
      common/c66/ y66(3,3,3,3),ye66(3,3,3,3)
      save yyst
      data yyst /.true./
c
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1
c
      dimension esp1(iadri*2)
corr      common/bid2/icas
      yw=.false.
      yw1=.false.
c     nombre max de couches ouvertes
      if(nelac-2.gt.noac) then
         maxco=noac-(nelac-2-noac)
      else
         maxco=min(nelac+2,noac)
      endif
c     dimension des conf de spin
      mmm=maxco+min(2,ninac)+min(2,nvirt)
      maxsps=c(mmm,mmm/2)
c      ip76=0
c        open(98,file='f98',status='unknown')
      ystc=.false.
      ystit1=itest(30).eq.1.and.iter.eq.1.and.iterh.le.1
      if(itest(30).eq.1) then
         ystc=.true.
         if(ystit1) then
            jint=0
            lonstc=0
            open(78,form='unformatted',status='unknown',file='CD_STOC')
            open(79,form='unformatted',status='unknown',file='CD_STOC2')
            if(irest.eq.1.or.irest.eq.3) then
               jint=1024
c--            si les files 78 ou 79 sont vides, le calcul precedent
c              avait echoue avant leur creation
               read(78,end=200)
               read(79,end=200)
c               print*,'lirint lecture 78'
c               print*,'lirint lecture 79'
               goto 201
 200           continue
               print*,'CD_STOC ou CD_STOC2 vide'
               jint=0
               irest=0
               itest(1)=0
 201           continue
               rewind 78
               rewind 79
            endif
         else
            jint=1024
            close(78)
            close(79)
            open(78,form='unformatted',status='unknown',file='CD_STOC')
            open(79,form='unformatted',status='unknown',file='CD_STOC2')
         endif
      endif
      if(nprint.ge.4) then
         write(6,*)' '
         write(6,*)'========================================== '
         write(6,*)'     Lecture des integrales   lirint'
         write(6,*)'========================================== '
         write(6,*)' '
         icpu(1)=itemps(idum)
      endif
c
c-------------------------------------------
c               boucles
c-------------------------------------------
c
c      write(6,*)'dans lirint icalc1',icalc1
      if(ytana) then
         icpu(2)=itemps(idum)
      endif
      if(itest(12).eq.1.and.icalc1.eq.0) goto 100
      if(mprint(1).eq.1) then
         do kkk=1,icalc1
            call scrida1
     *      ('b dans lirint debut$',esp1((kkk-1)*maxl0+1),ndet)
         enddo
         do kkk=1,icalc1
            call scrida1
     *      ('ab dans lirint debut$',esp1(iadri1+(kkk-1)*maxl0),ndet)
         enddo
      endif
      rewind 27
      continue
      intsc=0
      if(yga2) then
         open(56,file='CDI_GAM2',status='unknown',form='UNFORMATTED')
         open(57,file='CDP_GAM2',status='unknown',form='UNFORMATTED')
         open(58,file='CDM_GAM2',status='unknown',form='UNFORMATTED')
         lg2=0
         ig2=0
         lg2p=0
         ig2p=0
         lg2m=0
         ig2m=0
      endif
 
c
c-------------------------------------------
c     lecture des integrales generales
c-------------------------------------------
c
 
      do ln=1,l0000+1
         call lirin4(inti,intj,intk,intl,aaint,27)
         lfini=1024
         if(ln.eq.l0000+1)lfini=i0000
         do in=1,lfini
            if(ystc)intsc=intsc+1
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(itest(5).eq.1) call test5(i,j,k,l,itest(6))
            if(yw1) then
               write(75,*)'int lue',i,j,k,l,a,'$'
               call scril
            endif
c            write(6,*)'int lue',i,j,k,l,a
            call cd01(i,j,k,l,a,esp1)
            if(itest(5).eq.1) itest(6)=0
         enddo
      enddo
      if(mprint(1).eq.1) then
         do kkk=1,icalc1
            call scrida1
     *      ('ab dans lirint apr cd01$',esp1(iadri1+(kkk-1)
     &      *maxl0),ndet)
         enddo
      endif
c
c     lecture des integrales dir + ech
c
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
      rewind 33
      do ln=1,le0000+1
         call lirin4(inti,intj,intk,intl,aaint,33)
         lfini=1024
         if(ln.eq.le0000+1)lfini=ie0000
         do in=1,lfini
            if(ystc)intsc=intsc+1
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yw1) then
               write(75,*)'int ech lue pour cd01e ',i,j,k,l,a,'$'
               call scril
            endif
            call cd01e(i,j,k,l,a,esp1)
         enddo
      enddo
      if(mprint(1).eq.1) then
         do kkk=1,icalc1
            call scrida1
     *      ('ab dans lirint apr cd01e$',esp1(iadri1+(kkk-1)
     &      *maxl0),ndet)
         enddo
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'dir+ech  cpu',icpu1
         call flush(6)
         icpu(2)=itemps(idum)
      endif
c
c------------------------------------------------
c     cas MRS : integrales specialisees
c------------------------------------------------
c
      if(gener(1:2).eq.'MR') then
         if(.not.ygcas) call cdrs(esp1,esp1(iadri1))
         if(ytana) then
            icpu1=itemps(idum)-icpu(2)
            write(6,*)'MRS      cpu',icpu1
            icpu(2)=itemps(idum)
            call flush(6)
         endif
      endif
      if(mprint(1).eq.1) then
      call scrida1
     *('ab ap cdrs       $',esp1(iadri1),ndet)
      endif
c      do kkk=1,icalc1
c         call scrida1
c     *   ('ab dans lirint ap cdrs$',esp1(iadri1+(kkk-1)*maxl0),ndet)
c      enddo
 
 100  continue
c
c------------------------------------------------
c     si lbor.eq.1 on stocke le vecteur produit
c------------------------------------------------
c
      if(lbor.eq.1) then
         rewind 82
         call ecr8bl(esp1(iadri1),nmulr,82)
      endif
c
c-------------------------------------------
c     lecture des integrales specialisees
c-------------------------------------------
c
      nn=norb*norb
      ns=norb*nsym
c      rewind 76
c
c-------------------
c   <vvvv> directes
c-------------------
c
      if(ygcas) goto 11
      open(76,form='unformatted',status='old',file='CD_ADRR1')
      open(77,form='unformatted',status='old',file='CD_DEBL1')
      if(ygmono) goto 10
      if(ypertu.and.ycaspert) goto 13
      if(calcul.eq.'M') then
         call cdr1m(idebd,nn,ilond,'CDI_3333',esp1,esp1(iadri+1)
     *   ,l3333,i3333,mdet(1),1)
      else
         call borlir(esp1)
         call cdr1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDI_3333',mdet(1)
c     *      ,1
     *   ,l3333,i3333,1)
      endif
 15   continue
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vvvv dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <vvvv> dir + ech
c-------------------
c
c     <++++>
      if(calcul.eq.'M') then
         call cdr1em(idebd,nn,ilond,'CDE_3333',esp1,esp1(iadri+1)
     *   ,mdet(2),2,le3333,ie3333)
      else
c        write(6,*)'iadri*',iadri,iadri2,iadri3,iadri4
         call borlir(esp1)
         call cdr1e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDE_3333',mdet(2),2,le3333,ie3333)
      endif
c     <---->
      if(calcul.eq.'M') then
         call cdr1em(idebd,nn,ilond,'CDE_3333',esp1,esp1(iadri+1)
     *   ,mdet(3),3,le3333,ie3333)
      else
         if(syspin.ne.'0') goto 2
         call borlir(esp1)
c       print*,'ab avant',esp1(iadri1)
         call cdr1e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDE_3333',mdet(3),3,le3333,ie3333)
c       print*,'ab apres',esp1(iadri1)
      endif
 2    continue
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vvvv dir+ech  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c      if(itest(12).eq.1.and.icalc1.eq.0) goto 16
c
c-------------------
c   <oooo> directes
c-------------------
c
c      if(yw)print*,'2  75', esp1(iadri+75)
      if(calcul.eq.'M') then
         call cdr1m(idebd,nn,ilond,'CDI_1111',esp1,esp1(iadri+1)
     *   ,l1111,i1111,mdet(4),1)
      else
         call borlir(esp1)
         call cdr1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDI_1111',mdet(4)
c     *      ,4
     *   ,l1111,i1111,1)
      endif
 16   continue
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oooo dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <oooo> dir + ech
c-------------------
c
c     <---->
      if(calcul.eq.'M') then
         call cdr1em(idebd,nn,ilond,'CDE_1111',esp1,esp1(iadri+1)
     *   ,mdet(5),5,le1111,ie1111)
      else
c        write(6,*)'iadri*',iadri,iadri2,iadri3,iadri4
         if(syspin.ne.'0') goto 5
         call borlir(esp1)
         call cdr1e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDE_1111',mdet(5),5,le1111,ie1111)
      endif
 5    continue
c     <++++>
      if(calcul.eq.'M') then
         call cdr1em(idebd,nn,ilond,'CDE_1111',esp1,esp1(iadri+1)
     *   ,mdet(6),6,le1111,ie1111)
      else
         call borlir(esp1)
         call cdr1e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDE_1111',mdet(6),6,le1111,ie1111)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oooo dir+ech  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <vovo> directes
c-------------------
c
c      if(itest(12).eq.1.and.icalc1.eq.0) goto 17
c      if(yw)print*,'3   75', esp1(iadri+75)
 10   continue
      if(calcul.eq.'M') then
         call cdr1m(idebd,nn,ilond,'CDI_3131',esp1,esp1(iadri+1)
     *   ,l3131,i3131,mdet(7),0)
         call cdr1m(idebd,nn,ilond,'CDI_3131',esp1,esp1(iadri+1)
     *   ,l3131,i3131,mdet(8),0)
      else
         call borlir(esp1)
         call cdr1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,nn,ilond,'CDI_3131',mdet(7)
c     *   ,7
     *   ,l3131,i3131,0)
         if(syspin.eq.'0') then
            call borlir(esp1)
            call cdr1(esp1,esp1(iadri1),esp1(iadri2),
     *      esp1(iadri3)
     *      ,idebd,nn,ilond,'CDI_3131',mdet(8)
c     *      ,8
     *      ,l3131,i3131,0)
         endif
      endif
 17   continue
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vovo dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <vovo> dir + ech
c-------------------
c
      close(77)
      close(76)
      if(ye66(3,1,3,1)) goto 663
      open(77,form='unformatted',status='old',file='CD_DEBL9')
      open(76,form='unformatted',status='old',file='CD_ADRR9')
      if(calcul.eq.'M') then
         do k=9,14
            call cdr1em(idebd,nn,ilond,'CDE_3131',esp1,esp1(iadri+1)
     *      ,mdet(k),k,le3131,ie3131)
         enddo
      else
         if(syspin.eq.'0') then
            ipas=1
         else
            ipas=2
         endif
         do k=9,14,ipas
            call borlir(esp1)
            call cdr1e(esp1,esp1(iadri1),esp1(iadri2),
     *      esp1(iadri3)
     *      ,idebd,nn,ilond,'CDE_3131',mdet(k),k,le3131,ie3131)
         enddo
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vovo dir+ech  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
      close(77)
      close(76)
 663  continue
c
c-------------------
c   <vvvo> directes
c-------------------
c         signe : parite de noca-nocb (voir disint)
c
c      if(yw)print*,'4   75', esp1(iadri+75)
      if(ygmono) goto 1
      open(77,form='unformatted',status='old',file='CD_DEBL15')
      open(76,form='unformatted',status='old',file='CD_ADRR15')
      if(calcul.eq.'M') then
         call cdr3m(idebd,idebd3,idebd1,nn,ns,ilond,'CDI_3331',
     *   esp1,esp1(iadri+1)
     *   ,l3331,i3331,mdet(15),mdet(16))
         call cdr3m(idebd,idebd3,idebd1,nn,ns,ilond,'CDI_3331',
     *   esp1,esp1(iadri+1)
     *   ,l3331,i3331,mdet(17),mdet(18))
      else
         if(syspin.eq.'0') then
            call borlir(esp1)
            call cdr3(esp1,esp1(iadri1),esp1(iadri2),
     *      esp1(iadri3)
     *      ,idebd,idebd3,idebd1,nn,ns,ilond,
     *      'CDI_3331',mdet(15),mdet(16),
     *      l3331,i3331)
         endif
c        if(syspin.eq.'0') then
         call borlir(esp1)
         call cdr3(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,idebd3,idebd1,nn,ns,ilond,'CDI_3331'
     *   ,mdet(17),mdet(18),l3331,i3331)
c        endif
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vvvo dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <vvvo> dir + ech
c-------------------
c
      if(calcul.eq.'M') then
         call cdr3em(idebd,idebd3,idebd1,nn,ns,ilond,'CDE_3331',
     *   esp1,esp1(iadri+1)
     *   ,mdet(19),mdet(18),le3331,ie3331,2)
         call cdr3em(idebd,idebd3,idebd1,nn,ns,ilond,'CDE_3331',
     *   esp1,esp1(iadri+1)
     *   ,mdet(20),mdet(16),le3331,ie3331,3)
      else
         call borlir(esp1)
         call cdr3e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,idebd3,idebd1,nn,ns,
     *   ilond,'CDE_3331',mdet(19),mdet(18),le3331,ie3331)
         if(syspin.ne.'0') goto 3
         call borlir(esp1)
         call cdr3e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,idebd3,idebd1,nn,ns,ilond,'CDE_3331',mdet(20),
     *   mdet(16),le3331,ie3331)
 3       continue
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'vvvo dir+ech  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <ooov> directes
c-------------------
c
c      if(yw)print*,'5   75', esp1(iadri+75)
      if(calcul.eq.'M') then
         call cdr3m(idebd,idebd3,idebd1,nn,ns,ilond,'CDI_1113',
     *   esp1,esp1(iadri+1)
     *   ,l1113,i1113,mdet(21),mdet(22))
         call cdr3m(idebd,idebd3,idebd1,nn,ns,ilond,'CDI_1113',
     *   esp1,esp1(iadri+1)
     *   ,l1113,i1113,mdet(23),mdet(24))
      else
         if(syspin.eq.'0') then
            call borlir(esp1)
            call cdr3(esp1,esp1(iadri1),esp1(iadri2),
     *      esp1(iadri3)
     *      ,idebd,idebd3,idebd1,nn,ns,ilond,
     *      'CDI_1113',mdet(21),mdet(22),
     *      l1113,i1113)
         endif
c        if(syspin.eq.'0') then
         call borlir(esp1)
         call cdr3(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,idebd3,idebd1,nn,ns,ilond,'CDI_1113'
     *   ,mdet(23),mdet(24),l1113,i1113)
c        endif
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'ooov dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c-------------------
c   <ooov> dir + ech
c-------------------
c
      if(calcul.eq.'M') then
         call cdr3em(idebd,idebd3,idebd1,nn,ns,ilond,'CDE_1113',
     *   esp1,esp1(iadri+1)
     *   ,mdet(25),mdet(24),le1113,ie1113,2)
         call cdr3em(idebd,idebd3,idebd1,nn,ns,ilond,'CDE_1113',
     *   esp1,esp1(iadri+1)
     *   ,mdet(26),mdet(22),le1113,ie1113,3)
      else
         call borlir(esp1)
         call cdr3e(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,idebd,idebd3,idebd1,nn,ns,
     *   ilond,'CDE_1113',mdet(25),mdet(24),le1113,ie1113)
         if(syspin.eq.'0') then
            call borlir(esp1)
            call cdr3e(esp1,esp1(iadri1),esp1(iadri2),
     *      esp1(iadri3)
     *      ,idebd,idebd3,idebd1,nn,ns,ilond,'CDE_1113',mdet(26),
     *      mdet(22),le1113,ie1113)
         endif
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'ooov dir+ech  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c----------------------------------------------------
c   <oovv> directes pour < 0 | oo vv >
c----------------------------------------------------
c
      close(77)
      close(76)
      if(gener.eq.'DDCI'.or.gener.eq.'DDci'.or.gener.eq.'DDC2') goto 1
      if(y66(1,1,3,3)) goto 661
      open(77,form='unformatted',status='old',file='CD_DEBL27')
      open(76,form='unformatted',status='old',file='CD_ADRR27')
      if(calcul.eq.'M') then
         call cdr5m('CDI_3311',esp1,esp1(iadri+1)
     *   ,mdet(27),l3311,i3311,1)
      else
         call borlir(esp1)
         call cdr5(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,'CDI_3311',mdet(27),27,l3311,i3311)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oovv dir  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
      close(77)
      close(76)
 661  continue
c      call scrida1
c     *('ab ap cdr5        $',esp1(iadri1),ndet)
c
c----------------------------------------------------
c   <oovv> dir+ech pour < 0 | oo vv > ++++
c----------------------------------------------------
c
      open(77,form='unformatted',status='old',file='CD_DEBL30')
      open(76,form='unformatted',status='old',file='CD_ADRR30')
      if(calcul.eq.'M') then
         call cdr5m('CDE_3311',esp1,esp1(iadri+1)
     *   ,mdet(30),le3311,ie3311,2)
      else
         call borlir(esp1)
         call cdr5(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,'CDE_3311',mdet(30),30,le3311,ie3311)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oovv dir + ech++++  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c      call scrida1
c     *('ab ap cdr5e       $',esp1(iadri1),ndet)
c
c----------------------------------------------------
c   <oovv> dir+ech pour < 0 | oo vv > ----
c----------------------------------------------------
c
      if(syspin.ne.'0') goto 1
      if(calcul.eq.'M') then
         call cdr5m('CDE_3311',esp1,esp1(iadri+1)
     *   ,mdet(31),le3311,ie3311,3)
      else
         call borlir(esp1)
         call cdr5(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3)
     *   ,'CDE_3311',mdet(31),31,le3311,ie3311)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oovv dir + ech----  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
      close(77)
      close(76)
 1    continue
      if(mprint(1).eq.1) then
      call scrida1
     *('ab ap cdr5e       $',esp1(iadri1),ndet)
      endif
c
c----------------------------------------------------
c   <oovv> directes pour < o v | o v >  <++|-->
c----------------------------------------------------
c
c      do kkk=1,icalc1
c         call scrida1
c     *   ('ab dans lirint ovov00$',esp1(iadri1+(kkk-1)*maxl0),ndet)
c      enddo
      if(y66(1,1,3,3)) goto 662
      open(77,form='unformatted',status='old',file='CD_DEBL28')
      open(76,form='unformatted',status='old',file='CD_ADRR28')
      if(calcul.eq.'M') then
         call cdr7m(idebd,nn,ilond,'CDI_3311'
     *   ,esp1((iadri1+1)/2)
     *   ,esp1,l3311,i3311,mdet(28),esp1(iadri+1))
      else
      if(mprint(1).eq.1) then
      call scrida1
     *('ab av cdr7        $',esp1(iadri1),ndet)
      endif
         call borlir(esp1)
         call cdr7(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3),
     *   idebd,nn,ilond,'CDI_3311'
     *   ,l3311,i3311,mdet(28))
      if(mprint(1).eq.1) then
      call scrida1
     *('ab ap cdr7        $',esp1(iadri1),ndet)
      endif
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'oovv ++--  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
      close(77)
      close(76)
 662  continue
c
c----------------------------------------------------
c   <Cvvv> directes pour < I v | v v >  <+-|+->
c----------------------------------------------------
c
      if(ygmono) goto 12
      if(ivvvc8.eq.0) goto 12
      open(77,form='unformatted',status='old',file='CD_DEBL32')
      open(76,form='unformatted',status='old',file='CD_ADRR32')
      jtest=itest(12)
      jcalc=icalc1
c     icalc1 est mis a 1 pour supprimer le multiracines dans CVVV
c     du a une erreur
      icalc1=1
      if(calcul.eq.'M') then
         call cdc1m(idebd,idebd(nn+1),nn,ilond,'CDI_2333'
     *   ,esp1(iadri1),esp1((iadri1+1)/2)
     *   ,esp1,l2333,i2333,mdet(1),mdet(32),32)
      else
         call borlir(esp1)
         call cdc1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3),
     *   idebd,idebd(nn+1),nn,ilond,'CDI_2333'
     *   ,l2333,i2333,mdet(1),mdet(32),32)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'Cvvv +-+-  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c----------------------------------------------------
c   <Cvvv> directes pour < I v | v v >  <-+|-+>
c----------------------------------------------------
c
      if(calcul.eq.'M') then
         call cdc1m(idebd,idebd(nn+1),nn,ilond,'CDI_2333'
     *   ,esp1(iadri1),esp1((iadri1+1)/2)
     *   ,esp1,l2333,i2333,mdet(1),mdet(33),33)
      else
         if(syspin.ne.'0') goto 4
         call borlir(esp1)
         call cdc1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3),
     *   idebd,idebd(nn+1),nn,ilond,'CDI_2333'
     *   ,l2333,i2333,mdet(1),mdet(33),33)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'Cvvv -+-+  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
c
c----------------------------------------------------
c   <Cvvv> dir+ech pour < I v | v v >  <--|-->
c----------------------------------------------------
c
      if(calcul.eq.'M') then
         call cdc1m(idebd,idebd(nn+1),nn,ilond,'CDE_2333',esp1(iadri1)
     *   ,esp1((iadri1+1)/2)
     *   ,esp1,le2333,ie2333,mdet(2),mdet(34),34)
      else
         call borlir(esp1)
         call cdc1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3),
     *   idebd,idebd(nn+1),nn,ilond,'CDE_2333'
     *   ,le2333,ie2333,mdet(2),mdet(34),34)
      endif
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'Cvvv ----  cpu',icpu1
         icpu(2)=itemps(idum)
         call flush(6)
      endif
 4    continue
c
c----------------------------------------------------
c   <Cvvv> dir+ech pour < I v | v v >  <++|++>
c----------------------------------------------------
c
      if(calcul.eq.'M') then
         call cdc1m(idebd,idebd(nn+1),nn,ilond,'CDE_2333',esp1(iadri1)
     *   ,esp1((iadri1+1)/2)
     *   ,esp1,le2333,ie2333,mdet(3),mdet(35),35)
      else
         call borlir(esp1)
         call cdc1(esp1,esp1(iadri1),esp1(iadri2),
     *   esp1(iadri3),
     *   idebd,idebd(nn+1),nn,ilond,'CDE_2333'
     *   ,le2333,ie2333,mdet(3),mdet(35),35)
      endif
      if(mprint(1).eq.1)call scrida1
     *('ab dans lirint fin$',esp1(iadri1),ndet)
      icalc1=jcalc
      itest(12)=jtest
      close(77)
      close(76)
 12   continue
 13   continue
 11   continue
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         write(6,*)'Cvvv ++++  cpu',icpu1
         print*,'fin lecture int',lbor,syspin
         call flush(6)
         icpu(2)=itemps(idum)
      endif
c
c----------------------------------------------------
c   fin lecture des integrales
c----------------------------------------------------
c
      if(lbor.eq.1) then
c        a ce moment-la, b a ete perdu dans le traitement des
c        integrales precedentes
         rewind 81
         call lir8bl(esp1,nmulr,81)
      endif
      if(syspin.ne.'0') then
         if(icalc1.eq.0) then
            call syspi11(esp1(iadri1),ndet)
         else
            do kkk=1,icalc1
               call syspi11(esp1(iadri1+(kkk-1)*maxl0),ndet)
            enddo
         endif
      endif
      if(mprint(1).eq.1)call scrida1
     *('ab dans lirint apr sym spin$',esp1(iadri1),ndet)
c
      syspins=syspin
      syspin='0'
      syspin=syspins
      if(ystit1.and.itest(30).ne.0.and.yyst) then
         yyst=.false.
         iden=(l0000+le0000)*1024+i0000+ie0000
         if(iden.ne.0)
     *   print'(12x,''processus lents : integrales stockees :'',
     *   i10,''  ('',i3,''%)'')',intsc,
     *   intsc*100/((l0000+le0000)*1024+i0000+ie0000)
         print*,' '
      endif
      if(itest(31).le.2.and.itest(30).eq.1.and.ystit1) then
         write(79) jnb
c         print*,'lirint ecriture 79'
      endif
c     ystit1=.false.
      if(ytana) then
         icpu1=itemps(idum)-icpu(2)
         print*,'return lirint  cpu',icpu1
         call flush(6)
         icpu(2)=itemps(idum)
      endif
      return
      end
       subroutine test5(i,j,k,l,itest6)
      parameter(maxsym=8,maxda3=300,maxorbcas=16)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      itest6=0
      iti=itype(i)
      itj=itype(j)
      itk=itype(k)
      itl=itype(l)
c      if(iti.eq.2.and.itj.eq.3.and.itk.eq.1.and.itl.eq.3)itest6=1
c      if(iti.eq.3.and.itj.eq.2.and.itk.eq.3.and.itl.eq.1)itest6=1
c      if(iti.eq.1.and.itj.eq.3.and.itk.eq.2.and.itl.eq.3)itest6=1
c      if(iti.eq.3.and.itj.eq.1.and.itk.eq.3.and.itl.eq.2)itest6=1
      if(iti.eq.2)itest6=1
      if(itj.eq.2)itest6=1
      if(itk.eq.2)itest6=1
      if(itl.eq.2)itest6=1
c      if(itest6.eq.1)write(98,*)'lirint',i,j,k,l
      return
      end
       subroutine borli0
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter (maxda3=300)
      common /dim/ iadri
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/pr/nprint,mprint(10)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      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
      yw=.false.
c
c---------------------------------------------------------------
c     Cas ou on doit relire B et AB
c
c     Etape 1         B(nmulr)    V2(mdet1)
c     Etape 2         V3(mdet2)   V2(mdet1)
c     Etape 2         V3(mdet2)   AB(nmulr)
c
c    B(1),AB(iadri1),V3(iadri2),V2(iadri3)
c---------------------------------------------------------------
c
      iforc=itest(15)
c      print*,'itest(12)',itest(12)
      mmdet=0
      do k=1,8
         mmdet=max(mmdet,mdet(k))
      enddo
      do k=9,14
         mmdet=max(mmdet,mdet(k))
      enddo
      do k=15,27
         mmdet=max(mmdet,mdet(k))
      enddo
      do k=28,29
         mmdet=max(mmdet,mdet(k))
      enddo
      do k=30,39
         mmdet=max(mmdet,mdet(k))
      enddo
c
c--   racines 1 par 1
      if(itest(12).eq.0) then
         nmulr=ndet
         maxl0=ndet
         maxl=max0(nmulr,mmdet)
      else
c
c--   multiracine
         maxl=max0(mmdet,ndet)
         maxl0=maxl
         maxrac=min(iadri,maxl*nvec)/maxl
         maxl=maxl*maxrac
         nmulr=ndet*maxrac
         mmdet=mmdet*maxrac
c        correction :
         mmdet=max(mmdet,ndet)
      endif
c
c--   choix de la repartition des vecteurs en fonction de
c     l'espace disponible
      if(nmulr+nmulr+mmdet+mmdet.gt.iadri+iadri.or.iforc.eq.1) then
         iadri3=maxl+1
         iadri2=1
         iadri1=iadri3
         lbor=1
         if(yw)print*,'borlir contraction',iadri1,iadri2,iadri3
      else
         iadri1=nmulr+1
         iadri2=nmulr+nmulr+1
         iadri3=nmulr+nmulr+mmdet+1
         lbor=0
         maxl0=ndet
         if(yw)print*,'borlir sans contraction'
     *   ,iadri1,iadri2,iadri3
      endif
      if(itest(12).eq.1) then
         if(yw)print*,'repartition de l''espace :'
         if(yw)print*,'nmulr=',nmulr,'    mmdet=',mmdet,'    maxl=',maxl
         if(yw)print*,'maxrac=',maxrac,'      maxl0=',maxl0
 
      endif
      return
      end
       subroutine borlir(esp1)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common /dim/ iadri
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      dimension esp1(*)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      yw=.false.
c
c---------------------------------------------------------------
c     Cas ou on doit relire B et AB
c
c     Etape 1         B(nmulr)    V2(mdet1)
c     Etape 2         V3(mdet2)   V2(mdet1)
c     Etape 2         V3(mdet2)   AB(nmulr)
c
c    B(1),AB(iadri1),V3(iadri2),V2(iadri3)
c---------------------------------------------------------------
c
      if(lbor.eq.1) then
c        a ce moment-la, b a ete perdu dans le traitement des
c        integrales precedentes
         rewind 81
         call lir8bl(esp1,nmulr,81)
c        ...et ab va etre perdu dans le traitement des
c        integrales suivantes
         rewind 82
         call ecr8bl(esp1(iadri1),nmulr,82)
c          print*,'borlir ecriture ab',esp1(iadri1)
      endif
      return
      end
       subroutine lirin4(inti,intj,intk,intl,aaint,ifil)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      include 'maxorb.prm'
      common/test/itest(100)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      character*1 cnti(1024),cntj(1024),cntk(1024),cntl(1024)
     *,ijklnt(1024)
      if(itest(26).eq.1) then
         if(norb.lt.256) then
            read(ifil)cnti,cntj,cntk,cntl,aaint
c            do k=1,1024
c               inti(k)=ichar(cnti(k))
c               intj(k)=ichar(cntj(k))
c               intk(k)=ichar(cntk(k))
c               intl(k)=ichar(cntl(k))
c               if(inti(k).le.0) inti(k)=inti(k)+256
c               if(intj(k).le.0) intj(k)=intj(k)+256
c               if(intk(k).le.0) intk(k)=intk(k)+256
c               if(intl(k).le.0) intl(k)=intl(k)+256
c            enddo
         else
            read(ifil)cnti,cntj,cntk,cntl,aaint,ijklnt
c            do k=1,1024
c               call decodi(ijklnt(k),k1,k2,k3,k4)
c               call irroc0(inti(k),cnti(k),k1)
c               call irroc0(intj(k),cntj(k),k2)
c               call irroc0(intk(k),cntk(k),k3)
c               call irroc0(intl(k),cntl(k),k4)
c            enddo
         endif
         do k=1,1024
            call decod1(ijklnt(k),cnti(k),cntj(k),cntk(k),cntl(k),
     *      inti(k),intj(k),intk(k),intl(k),4)
         enddo
      else
         print*,'lirin4 avant lec'
         call flush(6)
         read(ifil)inti,intj,intk,intl,aaint
         print*,'lirin4 apres lec'
         call flush(6)
      endif
c      do k=1,20
c         print*,'lirin4',inti(k),intj(k),intk(k),intl(k),aaint(k)
c      enddo
      return
      end
