      subroutine prede3(iesp,idebd,idebd3,iadrr,
     *nor1,nor2,nor3,nordeb,num1
     *,num2,num3,ispi1,ispi2,ispi3,inddet,is)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,maxdetc=12870)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |            iadrr              |
c
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd(norb,norb),ilond(maxsym),idebd3(norb,nsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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 /det/ndet,mdet(50),nbdet_cas
      dimension iesp(maxorbcas*maxdetc*2),iadrr(iadri*4),num1(*),num2(*)
     *,num3(*)
      common/test/itest(100)
      integer(8) :: ndet8
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      yw=.false.
      yw1=.false.
      if(itest(44).eq.2
c     *.and.(inddet.eq.15.or.inddet.eq.15.or.inddet.eq.15
c     *.or.inddet.eq.15)
     *) then
         call prede3s(iesp,idebd,idebd3,iadrr,
     *   iadrr(iadri*2+1),iadrr(iadri*3+1),
     *   nor3,nordeb,num1
     *   ,num2,num3,ispi1,ispi2,ispi3,inddet,is)
         return
      endif
      if(yw1)print*,'entree prede3',inddet
      ndet8=ndet
      do k=1,min(ndet8*2,iadri*4)
         iadrr(k)=0
      enddo
      kdet=0
c     write(6,*)'num1',(num1(k),k=1,nor1)
c     write(6,*)'num2',(num2(k),k=1,nor2)
c     write(6,*)'num3',(num3(k),k=1,nor3)
      do k=1,nor1
         io1=num1(k)
         ldeb=1
         if(nordeb.eq.-1) ldeb=k+1
         do l=ldeb,nor2
            io2=num2(l)
            idebd(io1,io2)=kdet+1
c           si is=1 on symetrise idebd
            if(is.eq.1) idebd(io2,io1)=kdet+1
            if(yw1)write(6,'('' ----predet orb,k,l,io1,io2'',4i5)')
     *      k,l,io1,io2
            do m=1,nor3
               io3=num3(m)
               idebd3(io3,its(itsym(io1),itsym(io2)))=kdet+1
     *         -idebd(io1,io2)
c               write(6,*)'k,l,m,io1,io2,io3',k,l,m,io1,io2,io3
               kdet0=kdet+1
               if(yw)print*,'avant gende3'
               call gende3(iesp,
     *         iesp(maxorbcas*maxdetc+1),iadrr,io1,io2,io3,
     *         ispi1,ispi2,ispi3
     *         ,kdet,inddet,0,2,2
     *         ,iadrr(iadri*2+1),iadrr(iadri*3+1))
               if(yw)print*,'apres gende3'
               ilond(its(itsym(io3),its(itsym(io1),itsym(io2))))=
     *         kdet-kdet0
            enddo
         enddo
      enddo
      mdet(inddet)=kdet
      if(yw) then
         do k=1,norb
            write(75,*)'idebd',(idebd(k,l),l=1,norb),'$'
            call scril
         enddo
         write(6,*)'ilond',(ilond(k),k=1,nsym)
         do k=1,kdet
            write(6,*)'prede3 k,iadrr(k)',k,iadrr(k)
         enddo
      endif
      call ecri(idebd,norb*norb,77)
      call ecri(idebd3,norb*nsym,77)
      call ecri(ilond,maxsym,77)
      call ecribl(iadrr,kdet,76)
corr      do k=1,kdet
corr         ibidr(k,inddet) =iadrr(k)
corr      enddo
      return
      end
       subroutine prede1(iesp,idebd1,iadrr,nor,
     *num
     *,ispi,inddet)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,maxdetc=12870)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |             iadrr             |
c
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd1(norb)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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 /det/ndet,mdet(50),nbdet_cas
      dimension iesp(maxorbcas*maxdetc*2),iadrr(iadri*4),num(*)
      integer(8) :: ndet8
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      yw=.false.
      yw1=.false.
      if(yw1)print*,'entree prede1',inddet
      ndet8=ndet
      do k=1,min(ndet8*2,iadri*4)
         iadrr(k)=0
      enddo
      kdet=0
c     write(6,*)'num',(num(k),k=1,nor)
      do m=1,nor
         io3=num(m)
         idebd1(io3)=kdet+1
         if(yw)write(6,*)'m,io3',m,io3
         call gende3(iesp,
     *   iesp(maxorbcas*maxdetc+1),iadrr,0,0,io3,
     *   0,0,ispi
     *   ,kdet,inddet,3,1,1
     *   ,iadrr(iadri*2+1),iadrr(iadri*3+1))
c         ilond(itsym(io3))=kdet-idebd1(io3)
      enddo
      mdet(inddet)=kdet
      if(yw) then
         write(75,*)'idebd1',(idebd1(k),k=1,norb),'$'
         call scril
c         write(6,*)'ilond',(ilond(k),k=1,nsym)
         do k=1,kdet
            write(6,*)'prede1 k,iadrr(k)',k,iadrr(k)
         enddo
      endif
      call ecri(idebd1,norb,77)
c      call ecri(ilond,maxsym,77)
      call ecribl(iadrr,kdet,76)
corr      do k=1,kdet
corr         ibidr(k,inddet) =iadrr(k)
corr      enddo
      return
      end
       subroutine gende3(nsa,nsb,iadrr,io1,io2,io3,
     *ispo1,ispo2,ispo3,kdet
     *,inddet,im,maxt,maxp,mh,mt)
      use mod_ndimcs0
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16,maxdetc=12870,idicmr=35000)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      iadrr    |  mh   |  mt   |
c
      common/opt/ihab,calcul
      character*3 calcul
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/dim/iadri ; integer(8) iadri
      common/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      dimension iadrr(iadri*2),mh(iadri),mt(iadri)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      dimension iocc(maxorbcas),ica(maxorbcas),icb(maxorbcas),
     *ita(2),itb(2),ipa(2),ipb(2),it(2),ip(2)
      common /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      integer ces
      common/gd/ melc(5),nmelc
      dimension ic1(maxorbcas)
      common/test/itest(100)
c      data melc /0,1,-1,2,-2/
      yw=.false.
      yw1=.false.
c
c-----on commence a remplir les trous et part
c
      mta=0
      mtb=0
      mpa=0
      mpb=0
      ist0=1
      isp0=1
      if(im.ne.0) goto 20
      if(itype(io1).eq.1) then
         ist0=itsym(io1)
         if(ispo1.eq.1) then
            mta=mta+1
            ita(mta)=io1
         else
            mtb=mtb+1
            itb(mtb)=io1
         endif
      else if(itype(io1).eq.3) then
         isp0=itsym(io1)
         if(ispo1.eq.1) then
            mpa=mpa+1
            ipa(mpa)=io1
         else
            mpb=mpb+1
            ipb(mpb)=io1
         endif
      endif
      if(itype(io2).eq.1) then
         ist0=its(ist0,itsym(io2))
         if(ispo2.eq.1) then
            mta=mta+1
            ita(mta)=io2
         else
            mtb=mtb+1
            itb(mtb)=io2
         endif
      else if(itype(io2).eq.3) then
         isp0=its(isp0,itsym(io2))
         if(ispo2.eq.1) then
            mpa=mpa+1
            ipa(mpa)=io2
         else
            mpb=mpb+1
            ipb(mpb)=io2
         endif
      endif
 20   continue
      if(itype(io3).eq.1) then
         ist0=its(ist0,itsym(io3))
         if(ispo3.eq.1) then
            mta=mta+1
            ita(mta)=io3
         else
            mtb=mtb+1
            itb(mtb)=io3
         endif
      else if(itype(io3).eq.3) then
         isp0=its(isp0,itsym(io3))
         if(ispo3.eq.1) then
            mpa=mpa+1
            ipa(mpa)=io3
         else
            mpb=mpb+1
            ipb(mpb)=io3
         endif
      endif
      nto=mta+mtb
      npo=mpa+mpb
      nin=maxt-nto
      nvi=maxp-npo
      ispt0=mta-mtb
      ispp0=mpa-mpb
c
c
c-----nin et nvi sont les nombres d'inactives et de virtuelles a remplir
c-----nto et npo sont les nombres de trous et part deja occupes
c-----ispt0 et ispp0 sont les spins de depart des T et P
c
c      print*,'nin,nvi',nin,nvi
c      print*,'mta,mtb,mpa,mpb',mta,mtb,mpa,mpb
c      print*,'ita,itb,ipa,ipb',(ita(k),k=1,mta),(ipa(k),k=1,mpa),
c     * (itb(k),k=1,mtb),(ipb(k),k=1,mpb)
      do 1 kelc=1,nmelc
      nelc=melc(kelc)
      nelcas=nelac+nelc
      if(yw)write(6,*)'nelc,nelcas',nelc,nelcas
      ipasc=1
      if(nelc.eq.1.or.nelc.eq.-1) ipasc=2
      do 3 ispc1=-1,1,ipasc
      ispc=jsp(ispc1,nelc)
c
c           -----------------------------------
c             GENERATION DU CAS
c           ----------------------------------
c
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      if(iabs(ispcas).gt.nelcas) goto 3
      nca=(nelcas+ispcas)/2
      if(nca.lt.0) goto 3
      ncb=(nelcas-ispcas)/2
      if(yw)write(6,*)'nelc,nelcas,ispcas,nca,ncb',
     *nelc,nelcas,ispcas,nca,ncb
      if(nca.gt.noac.or.ncb.gt.noac) goto 3
c           signe du au saut d'electron par-dessus le CAS
      isgnc=1
      if(inddet.eq.15) then
c              on a le determinant  +  --> + -
c              la part + va sauter par dessus le CAS dans le trou +
         if(mod(nca,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.17) then
c              on a le determinant  -  --> + -
c              la part - va sauter par dessus le CAS dans le trou -
         if(mod(ncb,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.19) then
c              on a le determinant  +  --> + +
c              la part + va sauter par dessus le CAS dans le trou +
         if(mod(nca,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.20) then
c              on a le determinant  -  --> - -
c              la part - va sauter par dessus le CAS dans le trou -
         if(mod(ncb,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.21) then
c              on a le determinant  + -  --> +
c              la part + va sauter par dessus le CAS dans le trou +
         if(mod(nca,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.23) then
c              on a le determinant  + -  --> -
c              la part - va sauter par dessus le CAS dans le trou -
         if(mod(ncb,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.25) then
c              on a le determinant  + +  --> +
c              la part + va sauter par dessus le CAS dans le trou +
         if(mod(nca,2).ne.0) isgnc=-1
      endif
      if(inddet.eq.26) then
c              on a le determinant  - -  --> -
c              la part - va sauter par dessus le CAS dans le trou -
         if(mod(ncb,2).ne.0) isgnc=-1
      endif
      call combin(nsa,noac,nca,na,maxorbcas,maxdetc)
      call combin(nsb,noac,ncb,nb,maxorbcas,maxdetc)
      if(yw)write(6,*)'na,nb',na,nb
      do 10 ia=1,na
      isca=1
      do k=1,nca
         if(yw)
     *   write(6,*)'ia,nsa(k,ia)',ia,(nsa(kk,ia),kk=1,nca)
         ica(k)=numac(nsa(k,ia))
         isca=its(isca,itsym(ica(k)))
      enddo
      do 11 ib=1,nb
      iscb=1
      do k=1,ncb
         if(yw)
     *   write(6,*)'ib,nsb(k,ib)',ib,(nsb(kk,ib),kk=1,ncb)
         icb(k)=numac(nsb(k,ib))
         iscb=its(iscb,itsym(icb(k)))
      enddo
      isc=its(isca,iscb)
      if(yw)
     *write(6,*)'CAS',(ica(k),k=1,nca),'   ',(-icb(k),k=1,ncb)
      if(yw)
     *write(6,*)'isc,ispcas,ispc,ispc1',isc,ispcas,ispc,ispc1
      if(gener.eq.'MR') then
         call adrc_mr(nca,ica,ncb,icb,iadrcas)
         call callim(mixtpmr(iadrcas),maxt1,maxp1,mint1,minp1)
         if(maxt1.lt.0) goto 11
         if(yw)write(6,'('' maxt1,maxp1,mint1,minp1,nin,nvi,nca,ncb''
     *   ,8i4)')maxt1,maxp1,mint1,minp1,nin,nvi,nca,ncb
         if(maxt.eq.1) then
c           dans ce cas, le programme appelant est prede1
c           maxt1 et maxp1 doivent etre desincrementes de 1, puisque
c           les determinants provenant de prede3 ont un T et une P
c           en plus
            maxt1=maxt1-1
            maxp1=maxp1-1
         else if(maxt.eq.2) then
c           dans ce cas, le programme appelant est prede3
c           mint1 et minp1 doivent etre incrementes de 1, puisque
c           les determinants provenant de prede1 ont un T et une P
c           en moins
            mint1=mint1+1
            minp1=minp1+1
         endif
      endif
      if(gener(1:2).eq.'MR') then
         call tradmrs(iocc,nca,ica,ncb,icb)
         call adrcass(iocc,iadrs,ncf,nc1,ic1)
         mixtpmrs=ichar(tpmrs(iadrs))
         call sptxm(mint1,maxt1,minp1,mixtpmrs)
         if(mint1.gt.maxt1) goto 11
         maxp1=minp1+maxt1-mint1
         if(yw)write(6,'('' maxt1,maxp1,mint1,minp1,nin,nvi''
     *   ,6i4)')maxt1,maxp1,mint1,minp1,nin,nvi
         if(maxt.eq.1) then
c           dans ce cas, le programme appelant est prede1
c           maxt1 et maxp1 doivent etre desincrementes de 1, puisque
c           les determinants provenant de prede3 ont un T et une P
c           en plus
            maxt1=maxt1-1
            maxp1=maxp1-1
         else if(maxt.eq.2) then
c           dans ce cas, le programme appelant est prede3
c           mint1 et minp1 doivent etre incrementes de 1, puisque
c           les determinants provenant de prede1 ont un T et une P
c           en moins
            mint1=mint1+1
            minp1=minp1+1
         endif
      endif
 
c
c              -----------------------------------
c                GENERATION DES TROUS
c              ----------------------------------
c
c----         boucle sur le nombre de trous rajoutes
      do 4 nt=0,nin
      np=nt-nin-nelc+nvi+maxt-maxp
      if(yw)write(6,*)'nt,np',nt,np
c                np est le nombre de part rajoutees
      if(np.gt.nvi) goto 4
      if(np.lt.0) goto 4
      ntto=nt+nto
      nppo=np+npo
      if(yw)print*,'ntto,nppo',ntto,nppo
      if(gener(1:2).eq.'MR') then
         if(ntto.lt.mint1.or.ntto.gt.maxt1) goto 4
         if(nppo.lt.minp1.or.nppo.gt.maxp1) goto 4
      endif
c                ntto et nppo sont les nb de trous et part totaux
      if(yw) then
         write(6,*)'nt,np,ntto,nppo,gener,nin,nvi,isc,is0,ispc'
         write(6,*)nt,np,ntto,nppo,gener,nin,nvi,isc,is0,ispc
      endif
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(ntto.eq.maxt.and.nppo.eq.maxp) then
            if(isc.ne.is0) goto 4
            if(ispc.ne.0) goto 4
         endif
      endif
      if(gener.eq.'DDCI'.or.gener.eq.'DDci') then
         if(ntto.eq.maxt.and.nppo.eq.maxp) goto 4
      endif
      if(gener.eq.'DDC2') then
         if(ntto.ge.maxt-1.and.nppo.ge.maxp) goto 4
         if(ntto.ge.maxt.and.nppo.ge.maxp-1) goto 4
      endif
      if(yw)write(6,*)'ntto,nppo',ntto,nppo
      ipast=1
c---             boucle sur le spin total des trous
      if(ntto.eq.1) ipast=2
      do 6 ispt1=-1,1,ipast
      ispt=jsp(ispt1,ntto)
c                   quelques impossibilites :
      if(iabs(ispt-ispt0).gt.nt) goto 6
      if(yw)write(6,*)
     *'ispt1,ispt,ispo1,ispo2',ispt1,ispt,ispo1,ispo2
c---                ispt est le spin des ntto trous
      if(iabs(ispt).gt.ntto) goto 6
      if(yw)write(6,*)'ispt',ispt
c                   nta et ntb sont les nb de trous alpha et beta
      nta=(ntto+ispt)/2
      ntb=(ntto-ispt)/2
      ispp=ispt-ispc
      if(yw)write(6,*)'ispp',ispp
c---                ispp est le spin des nppo part
c                   quelques impossibilites :
      if(iabs(ispp-ispp0).gt.np) goto 6
      if(iabs(ispp).gt.nppo) goto 6
      npa=(nppo+ispp)/2
      npb=(nppo-ispp)/2
c                   npa et npb sont les nb de part alpha et beta
      if(yw)write(6,*)'nta,ntb,npa,npb',nta,ntb,npa,npb
      ispp1=ksp(ispp)
      ideb2=1
c----               1ere boucle sur les trous rajoutes
      if(nt.eq.0) then
         ifin1=1
         ifin2=1
      else
         ifin1=ninac
         ifin2=1
      endif
      if(yw)write(6,*)'ifin1',ifin1
      ist1=ist0
      mta1=0
      mtb1=0
      mpa1=0
      mpb1=0
      do 21 jt1=1,ifin1
      if(nt.eq.0) goto 27
      if(nta-mta.gt.0) then
         it1=numt(jt1)
         mta1=mta+1
         ita(mta1)=it1
      endif
      if(ntb-mtb.gt.0.and.nta-mta.eq.0) then
         it1=numt(jt1)
         mtb1=mtb+1
         itb(mtb1)=it1
         if(yw)print*,'mtb1,it1',mtb1,it1
      endif
      ist1=its(ist0,itsym(it1))
c----                   2eme boucle sur les trous rajoutes
      if(nt.eq.2) then
         ifin2=ninac
         if(ispt.ne.0) then
            ideb2=jt1+1
         else
            ideb2=1
         endif
      endif
      if(yw)write(6,*)'ideb2,ifin2',ideb2,ifin2
c                        if(nt.ge.1)ist=itsym(it1)
c                       print*,'ist1',ist1
 27   continue
      ist=ist1
      do 22 jt2=ideb2,ifin2
      if(nt.le.1) goto 28
      if(nta-mta1.gt.0) then
         it2=numt(jt2)
c                              if(yoca(it2)) goto 22
         mta2=mta1+1
         ita(mta2)=it2
      endif
      if(yw)print*,'nta,mta1,ntb,mtb1',
     *nta,mta1,ntb,mtb1
      if(nta-mta1.eq.0.and.ntb-mtb1.gt.0) then
         it2=numt(jt2)
         mtb2=mtb1+1
         itb(mtb2)=it2
         if(yw)print*,'mtb2,it2',mtb2,it2
      endif
      ist=its(ist1,itsym(it2))
 28   continue
      kk=0
      do k=1,nta
         kk=kk+1
         it(kk)=ita(k)
      enddo
      do k=1,ntb
         kk=kk+1
         it(kk)=itb(k)
      enddo
      isgnt=1
c                           if(nta.eq.2.or.ntb.eq.2) isgnt=-1
c                           if(inddet.eq.15.or.inddet.eq.20
c     *                     .or.inddet.eq.17.or.inddet.eq.19) then
      if(inddet.ge.19.and.inddet.le.20) then
         isgnt=-1
         if(nta.eq.2) then
            if(yw)print*,'ita',(it(k),k=1,nta)
            call reor(2,it,isgnt1)
            isgnt=isgnt1
         endif
         if(ntb.eq.2) then
            if(yw)print*,'itb',(it(k),k=1,ntb)
            call reor(2,it,isgnt1)
            isgnt=isgnt1
         endif
      endif
      if(inddet.eq.15.or.inddet.eq.17) then
         isgnt=1
         if(nta.eq.2) then
            if(yw)print*,'ita',(it(k),k=1,nta)
            call reor(2,it,isgnt1)
            isgnt=-isgnt1
         endif
         if(ntb.eq.2) then
            if(yw)print*,'itb',(it(k),k=1,ntb)
            call reor(2,it,isgnt1)
            isgnt=-isgnt1
         endif
      endif
c                           if(nta.eq.2)call reor(2,it,isgnt)
c                           if(ntb.eq.2)call reor(2,it,isgnt)
c                           if(nta.eq.2.or.ntb.eq.2)
c     *                     write(6,'('' gendet nta,ntb,it isgnt''
c     *                     2i5,1x,2i3,2x,2i5)')nta,ntb,it,isgnt
c                           if(nt.ge.2)ist=its(itsym(it1),itsym(it2))
c                          print*,'ist2',ist
      if(yw)
     *write(6,*)'it1',it1
      if(yw)
     *write(6,*)'TROU',(ita(k),k=1,nta),'   ',
     *(-itb(k),k=1,ntb)
      if(yw)write(6,*)'ist,ispt',ist,ispt
c
c                          -----------------------------------
c                            GENERATION DES PARTICULES
c                          ----------------------------------
c
      isct=its(isc,ist)
      if(yw)write(6,*)'np,isct,ispp',np,isct,ispp
      if(nppo.eq.0.and.isct.ne.is0) goto 22
      isp=its(is0,isct)
c---                       1ere boucle sur les part rajoutees
      ideb1p=1
      if(np.eq.0) then
         ifin1p=ideb1p
c                             mpa=1
c                             mpb=1
         ideb2p=1
         ifin2p=1
      else
         ifin1p=nvirt
      endif
      if(yw)write(6,*)'ideb1p,ifin1p',ideb1p,ifin1p
      isp1=isp0
      do 23 jp1=ideb1p,ifin1p
      if(yw)print*,'np,jp1',np,jp1
      if(np.eq.0) goto 25
      ip1=nump(jp1)
      if(yw)print*,'ip1,npa,mpa',ip1,npa,mpa
      if(npa-mpa.gt.0) then
         mpa1=mpa+1
         ipa(mpa1)=ip1
      endif
      if(yw)print*,'npa,mpa,npb,mpb',
     *npa,mpa,npb,mpb
      if(npb-mpb.gt.0.and.npa-mpa.eq.0) then
         mpb1=mpb+1
         ipb(mpb1)=ip1
         if(yw)print*,'mpb1,ipb(mpb1)'
     *   ,mpb1,ipb(mpb1)
      endif
      isp1=its(isp0,itsym(ip1))
c---                          2eme boucle sur les part rajoutees
      ideb2p=1
      ifin2p=ideb2p
      if(np.eq.2) then
         ifin2p=nvirt
         if(ispp.ne.0) ideb2p=jp1+1
      endif
 25   continue
      if(yw)
     *write(6,*)'ideb2p,ifin2p',ideb2p,ifin2p
      isp2=isp1
      do 24 jp2=ideb2p,ifin2p
      if(np.le.1) goto 26
      ip2=nump(jp2)
      if(npa-mpa1.gt.0) then
c                                    if(yoca(ip2)) goto 24
         mpa2=mpa1+1
         ipa(mpa2)=ip2
      endif
      if(npa-mpa1.eq.0.and.npb-mpb1.gt.0)then
c                                    if(yocb(ip2)) goto 24
         mpb2=mpb1+1
         ipb(mpb2)=ip2
      endif
      isp2=its(isp1,itsym(ip2))
 26   continue
c                                 isp1=1
      if(yw)print*,'isp2,isp',isp2,isp
      if(isp2.ne.isp) goto 24
c                                if(its(itsym(ip1),itsym(ip2)).ne.isp)
c     *                           goto 24
      kdet=kdet+1
c      if(kdet.gt.iadri*4) then
c         write(6,*)'kdet,iadri*4',kdet,iadri*4
c         stop 28
c      endif
c                                ---EPV ?
      iepv=0
      if(inddet.ge.15.and.inddet.le.26) then
         call tesepv(nta,ita,iepv)
         call tesepv(npa,ipa,iepv)
         call tesepv(ntb,itb,iepv)
         call tesepv(npb,ipb,iepv)
      endif
      ntt=ntto
      npp=nppo
c                                if(im.eq.1) then
c                                   ntt=0
c                                 else if (im.eq.3) then
c                                   npp=0
c                                endif
      if(yw1) then
c                                   if(im.eq.0) then
         call wrdet
     *   (nca,ncb,ica,icb,nta,ntb,ita,
     *   itb,npa,npb,ipa,ipb)
         if(iepv.eq.1)print*,'EPV'
c                                   endif
c                                   if(im.eq.1) then
c                                       call wrdet
c     *                                 (nca,ncb,ica,icb,0,0,ita,
c     *                                 itb,npa,npb,ipa,ipb)
c                                       if(iepv.eq.1)print*,'EPV'
c                                   endif
c                                   if(im.eq.3) then
c                                       call wrdet
c     *                                 (nca,ncb,ica,icb,nta,ntb,ita,
c     *                                 itb,0,0,ipa,ipb)
c                                       if(iepv.eq.1)print*,'EPV'
c                                   endif
      endif
c                                 if(yw) then
c                                    write(75,*)nca,(ica(k),k=1,nca),'$'
c                                    call scril
c                                    write(75,*)ncb,(icb(k),k=1,ncb),'$'
c                                   call scril
c                                    write(75,*)nta,(ita(k),k=1,nta),'$'
c                                    call scril
c                                    write(75,*)ntb,(itb(k),k=1,ntb),'$'
c                                    call scril
c                                    write(75,*)npa,(ipa(k),k=1,npa),'$'
c                                     call scril
c                                    write(75,*)npb,(ipb(k),k=1,npb),'$'
c                                    call scril
c                                    write(6,*)'ispt,ispp',ispt,ispp
c                                 endif
      if(iepv.eq.1) then
         if(kdet.le.iadri)iadrr(kdet)=0
         goto 24
      endif
      kk=0
      do k=1,npa
         kk=kk+1
         ip(kk)=ipa(k)
      enddo
      do k=1,npb
         kk=kk+1
         ip(kk)=ipb(k)
      enddo
      isgnp=1
c     if(ip(1).gt.ip(2))write(6,*)'gende3 ',
c    *'ip(1),ip(2)',ip(1),ip(2)
      if(inddet.eq.21.or.inddet.eq.23
     *.or.inddet.eq.25.or.inddet.eq.26) then
c     if(inddet.ge.25.and.inddet.le.26) then
         if(npa.eq.2) then
            call reor(2,ip,isgnp1)
            isgnp=isgnp1
         endif
         if(npb.eq.2) then
            call reor(2,ip,isgnp1)
            isgnp=isgnp1
         endif
      endif
c      write(6,'('' gendet it ip ''
c     *,2i3,2x,2i3,2x,2i5)')it,ip
c      if(npa.eq.2)call reor(2,ip,isgnp)
c      if(npb.eq.2)call reor(2,ip,isgnp)
c      print*,'gende3 it,ip',it,ip
      call adrdet(nca,ica,ncb,icb,
     *ntt,it,ispt,npp,ip,ispp,iadr,
     *      mhdum,mtdum)
c                                 write(6,'('' gendet it ip isgnt isgnp'
c     *                           ,2i3,2x,2i3,2x,2i5)')it,ip,isgnt,isgnp
c
c-----                           on a calcule l'adresse du determinant
c-----                           iadrr etablit une correspondance entre
c-----                           le numero du determinant dans la
c-----                           grande liste et son numero dans la
c-----                           petite liste
c
         if(kdet.le.iadri)iadrr(kdet)=iadr*isgnt*isgnp*isgnc
         if(itest(44).eq.2.and.im.eq.0) then
            if(kdet.le.iadri) then
               mh(kdet)=mhdum
               mt(kdet)=mtdum
            endif
         endif
 24   continue
 23   continue
 22   continue
 21   continue
 6    continue
 4    continue
 11   continue
 10   continue
 3    continue
 1    continue
c      write(6,*)'**************************************'
c      write(6,*)'*******      fin de casdet    ********'
      if(yw1)write(6,*)' gende3 nombre de determinants generes',kdet
c      write(6,*)'**************************************'
      return
      end
       subroutine cdr3(b,ab,v3,v2,
     *idebd,idebd3,idebd1,nn,ns,ilond,ifil,mdet1,mdet2,
     *lnt1,int1)
      parameter(maxsym=8,ngru3=2048)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common/opt/ihab,calcul
      character*3 calcul
      common /det/ndet,mdet(50),nbdet_cas
      dimension idebd3(norb,nsym)
      dimension idebd1(norb)
      dimension idebd(norb,norb),ilond(maxsym)
      dimension iadrr3(ngru3),iadrr2(ngru3)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
c      common/bid2/ibidin
c      ibidin=inddet
      yw=.false.
      yw1=.false.
corr  write(6,*)'correc entree cdr3 icas',icas
c
c    lbor=0 :
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      |       v3      |      v2       |
c
c
c    lbor=1 :
c
c        |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c        |       b       |      v2       |
c    puis|       v3      |      v2       |
c    puis|       v3      |      ab       |
c
      if(yw)write(6,*)'ifil ',ifil
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd,idebd3 et ilond
c     lecture de iadrr
C      call lirbl(iadrr3,mdet1,76)
C      call lirbl(iadrr3(mdet1+1),mdet2,76)
cdcor
ccor      do k=1,mdet1+mdet2
ccor         ibidr(k,1)=iabs(iadrr3(k))
ccor      enddo
cfcor
c     lecture de idebd,idebd3
      call liri(idebd,nn,77)
      call liri(idebd3,ns,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd1
      call liri(idebd1,norb,77)
      do k=1,norb
         idebd1(k)=idebd1(k)+mdet1
      enddo
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
C      call v1v2(b,iadrr3,v2,mdet1+mdet2)
      call v1v2ter(b,iadrr3,v2,mdet1,mdet2)
      if(yw) then
         do k=1,mdet1+mdet2
            write(6,*)'cdr3 k,iadrr3(k)',k,iadrr3(k)
         enddo
      endif
c     lecture des integrales
      do kk=1,mdet1+mdet2
         v3(kk)=0.d0
      enddo
      if(yw)write(6,*)'int1',int1
      do ln=1,lnt1+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.lnt1+1) lfini=int1
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
c         read(28,*) i,j,k,l,a
            if(yw1) then
               write(75,*)'int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            call cdr4(i,j,k,l,a,v3,v2,idebd,idebd3,idebd1,ilond)
            if(i.ne.k.and.j.ne.l)
     *      call cdr4(k,j,i,l,a,v3,v2,idebd,idebd3,idebd1,ilond)
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on relit iadrr
C      call back(76,mdet1)
C      call back(76,mdet2)
c     backspace 76
c     backspace 76
C      call lirbl(iadrr2,mdet1,76)
C      call lirbl(iadrr2(mdet1+1),mdet2,76)
c      if(yw)write(6,*)'ab avant v3v4'
c      if(yw)write(6,*)(ab(kk),kk=1,107)
C      call v3v4(ab,v3,iadrr2,mdet1+mdet2)
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4ter(ab,v3,iadrr2,mdet1,mdet2)
c      if(yw)write(6,*)'ab apres v3v4'
c      if(yw)write(6,*)(ab(kk),kk=1,107)
      close(28)
      if(yw)write(6,*)'sortie cdr3'
      return
      end
       subroutine cdr3e(b,ab,v3,v2,
     *idebd,idebd3,idebd1,nn,ns,ilond,ifil,mdet1,mdet2,lnt1,
     *int1)
      parameter(maxsym=8,ngru3=2048)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      common/dim/iadri ; integer(8) iadri
      character*8 ifil
      common/opt/ihab,calcul
      character*3 calcul
      common /det/ndet,mdet(50),nbdet_cas
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd1(norb)
      dimension idebd3(norb,nsym)
      dimension idebd(norb,norb),ilond(maxsym)
      dimension iadrr3(ngru3),iadrr2(ngru3)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
corr      common/bid2/ibidin
corr      ibidin=icas
      yw=.false.
      yw1=.false.
corr  write(6,*)'correc entree cdr3e icas',icas
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      | iadrr |               v2      | |
c                           puis     |       v3      | iadrr |
c                                                                 ()
c
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd,idebd3 et ilond
c     lecture de iadrr
C      call lirbl(iadrr3,mdet1,76)
C      call lirbl(iadrr3(mdet1+1),mdet2,76)
cdcor
ccor      do k=1,mdet1+mdet2
ccor         ibidr(k,1)=iabs(iadrr3(k))
ccor      enddo
cfcor
c     lecture de idebd,idebd3
      call liri(idebd,nn,77)
      call liri(idebd3,ns,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd1
      call liri(idebd1,norb,77)
      do k=1,norb
         idebd1(k)=idebd1(k)+mdet1
      enddo
c        do k=1,norb
c          write(75,*)'idebd',(idebd(k,l),l=1,norb),'$'
c          call scril
c        enddo
c        write(6,*)'ilond',(ilond(k),k=1,8)
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
      call v1v2ter(b,iadrr3,v2,mdet1,mdet2)
c      do k=1,mdet1
c         write(6,*)'cdr3e k,iadrr3(k)',k,iadrr3(k)
c      enddo
c     lecture des integrales
      do kk=1,mdet1+mdet2
         v3(kk)=0.d0
      enddo
      do ln=1,lnt1+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.lnt1+1) lfini=int1
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
c         read(28,*) i,j,k,l,a
            if(yw1) then
               write(75,*)'int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            call cdr4(i,j,k,l,a,v3,v2,idebd,idebd3,idebd1,ilond)
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on relit iadrr
C      call back(76,mdet1)
C      call back(76,mdet2)
c     backspace 76
c     backspace 76
C      call lirbl(iadrr2,mdet1,76)
C      call lirbl(iadrr2(mdet1+1),mdet2,76)
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4ter(ab,v3,iadrr2,mdet1,mdet2)
      close(28)
      return
      end
       subroutine cdr3em(idebd,idebd3,idebd1,nn,ns,ilond,ifil,
     *iadrr,ab,mdet1,
     *mdet2,leiiii,ieiiii,icas)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd1(norb)
      dimension idebd3(norb,nsym)
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri),ab(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |       ab      |
c
c
      if(yw)write(6,*)'entree cdr3em  '
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd,idebd3 et ilond
c     lecture de iadrr
      call lirbl(iadrr,mdet1,76)
      call lirbl(iadrr(mdet1+1),mdet2,76)
c     lecture de idebd,idebd3
      call liri(idebd,nn,77)
      call liri(idebd3,ns,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd1
      call liri(idebd1,norb,77)
      do k=1,norb
         idebd1(k)=idebd1(k)+mdet1
      enddo
c     lecture des integrales
      if(yw)write(6,*)'ifil,ieiiii',ifil,ieiiii
      do ln=1,leiiii+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.leiiii+1) lfini=ieiiii
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yga2) then
               a=1.d0
               if(icas.eq.3) then
                  ifilg2=58
                  lg=lg2m
                  ig=ig2m
                  icg2=3
               else if(icas.eq.2) then
                  ifilg2=57
                  lg=lg2p
                  ig=ig2p
                  icg2=2
               endif
            endif
c         read(28,*) i,j,k,l,a
            if(yw1) then
               write(75,*)'cdr3em int spec ech lue',i,j,k,l,a,'$'
               call scril
            endif
            call cdr4m(i,j,k,l,a,
     *      idebd,idebd3,idebd1,ilond,iadrr,ab)
            if(yga2) call disin1(lg,ig,ifilg2,i,j,k,l,a,icg2)
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr3m(idebd,idebd3,idebd1,nn,ns,ilond,ifil,iadrr,
     *ab,lllll,iiiii,mdet1,mdet2)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd3(norb,nsym)
      dimension idebd1(norb)
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri),ab(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |      ab       |
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et idebd,idebd3 et ilond
c     lecture de iadrr
      call lirbl(iadrr,mdet1,76)
      call lirbl(iadrr(mdet1+1),mdet2,76)
      if(yw) then
         write(6,*)'cdr3m mdet1,mdet2',mdet1,mdet2
         do k=1,mdet1+mdet2
            write(6,*)'cdr3m k,iadrr(k)',k,iadrr(k)
         enddo
      endif
c     lecture de idebd,idebd3
      call liri(idebd,nn,77)
      call liri(idebd3,ns,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd1
      call liri(idebd1,norb,77)
      do k=1,norb
         idebd1(k)=idebd1(k)+mdet1
      enddo
      if(yw) then
         do k=1,norb
            write(75,*)'cdr3m idebd ',(idebd(k,l),l=1,norb),'$'
            call scril
         enddo
         do k=1,norb
            write(75,*)'cdr3m idebd3 ',(idebd3(k,l),l=1,nsym),'$'
            call scril
         enddo
         write(75,*)'cdr3m ilond ',(ilond(l),l=1,nsym),'$'
         call scril
         write(75,*)'cdr3m idebd1 ',(idebd1(l),l=1,norb),'$'
         call scril
      endif
c     lecture des integrales speciales
      if(yw)write(6,*)'ifil,iiiii',ifil,iiiii
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
c          read(28,*) i,j,k,l,a
            if(yw1) then
               write(75,*)'int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            if(yga2)a=1.d0
            call cdr4m(i,j,k,l,a,idebd,idebd3,idebd1,
     *      ilond,iadrr,ab)
            if(yga2) call disin1(lg2,ig2,56,i,j,k,l,a,1)
            if(k.ne.i.and.j.ne.l) then
            if(yga2)a=1.d0
               call cdr4m(k,j,i,l,a,idebd,idebd3,idebd1,
     *         ilond,iadrr,ab)
            if(yga2) call disin1(lg2,ig2,56,k,j,i,l,a,1)
            endif
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr4(in,jn,kn,ln,a,v3,v2,idebd,idebd3,idebd1,ilond)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension idebd3(norb,nsym)
      dimension idebd1(norb)
      dimension v3(iadri),v2(iadri),idebd(norb,norb),ilond(maxsym)
      common/test/itest(100)
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
corr      common/bid2/inddet
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |      v3       |      v2       | |
c                                                                 ()
c
      ideb1=idebd(jn,in)+idebd3(ln,its(itsym(in),itsym(jn)))
      l=idebd1(kn)-1
      ifin1=ideb1+ilond(itsym(kn))
c     do kk=1,norb
c        print*,'idebd',(idebd(kk,ll),ll=1,norb)
c     enddo
c     print*,'ilond',ilond
      do k=ideb1,ifin1
         l=l+1
c        write(6,*)'k,l',k,l
CIT17           if(itest(17).eq.l)write(6,'('' cdr4 it17'',i5,2f12.8)')
CIT17        *   k,a,v2(k)
CIT17           if(itest(17).eq.k)write(6,'('' cdr4 it17'',i5,2f12.8)')
CIT17        *   l,a,v2(l)
         v3(l)=v3(l)+a*v2(k)
         v3(k)=v3(k)+a*v2(l)
cdcor
ccor         if(ibidr(k,1).eq.0) goto 20
ccor         if(ibidr(l,1).eq.0) goto 20
corr     minbid=min(ibidv(ibidr(k,1)),ibidv(ibidr(l,1)))
corr     maxbid=max0(ibidv(ibidr(k,1)),ibidv(ibidr(l,1)))
corr         if(ibidv(ibidr(k,1)).eq.icor)write(6,*)'correc cdr4',
corr     *   a*v2(l),v2(l),ibidv(ibidr(l,1))
c         if(ibidv(ibidr(k,1)).eq.icor)write(6,*)'correc cdr4 v3',
c     *   v3(k)
corr         if(ibidv(ibidr(l,1)).eq.icor)write(6,*)'correc cdr4',
corr     *   a*v2(k),v2(k),ibidv(ibidr(k,1))
c         if(ibidv(ibidr(l,1)).eq.icor)write(6,*)'correc cdr4 v3',
c     *   v2(l)
cfcor
c        print*,'stocmd',minbid,maxbid,a
 20      continue
      enddo
      return
      end
       subroutine cdr4m(in,jn,kn,ln,a,idebd,idebd3,idebd1,
     *ilond,iadrr,ab)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(ngru3=2048)
      real*4 d
      common/ver3/ itab(ngru3),jtab(ngru3),d(ngru3)
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension idebd1(norb)
      dimension idebd3(norb,nsym)
      dimension idebd(norb,norb),ilond(maxsym),iadrr(iadri),ab(iadri)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      COMMON/VER2/nelem
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |      ab       |
c
c
      yw1=.false.
      yw=.false.
c      do k=1,norb
c         if(yw)write(6,1)'entree cdr4m idebd',(idebd(k,l),l=1,norb)
c      enddo
      if(yw)write(6,1)'entree cdr4m ilond',(ilond(l),l=1,nsym)
 1    format(a20,10i4)
      ideb1=idebd(jn,in)+idebd3(ln,its(itsym(in),itsym(jn)))
c      write(6,*)jn,in,ideb1
      l=idebd1(kn)-1
      if(yw) then
         write(75,*)'entree cdr4m in,jn,kn,ln',in,jn,kn,ln,'$'
         call scril
      endif
c      if(yw) then
c         do k=1,140
c            write(6,*)'k,iadrr(k)',k,iadrr(k)
c         enddo
c      endif
      ifin1=ideb1+ilond(itsym(kn))
      if(yw)print*,'ideb1,ifin1',ideb1,ifin1
      do k=ideb1,ifin1
         l=l+1
c         if(yw)write(6,*)'entree cdr4m k,l',k,l,iadrr(k),iadrr(l)
         if(iadrr(k).eq.0) goto 2
         if(iadrr(l).eq.0) goto 2
         iadrrk=iabs(iadrr(k))
         iadrrl=iabs(iadrr(l))
         if(iadrr(k).gt.0) then
            if(iadrr(l).gt.0) then
               aa=a
            else
               aa=-a
            endif
         else
            if(iadrr(l).gt.0) then
               aa=-a
            else
               aa=a
            endif
         endif
c         if(iadrr(k)*iadrr(l).gt.0) then
c            aa=a
c         else
c            aa=-a
c         endif
CYSGN         if(.not.yeqy(ysgn(iadrrk),ysgn(iadrrl))) aa=-aa
         call stover(iadrrk,iadrrl,aa)
         if(yga2) call stoga2(iadrrk,iadrrl,aa,ab)
 2       continue
      enddo
      return
      end
       subroutine prede4(iesp,iadrr,inddet,
     *ispi1,ispi2,llll,iiii,ifil)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,maxdetc=12870)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |            iadrr              |
c
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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 /det/ndet,mdet(50),nbdet_cas
      dimension iesp(maxorbcas*maxdetc*2),iadrr(iadri*4)
      character*8 ifil
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/test/itest(100)
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      yw=.false.
      yw1=.false.
      if(yw1)print*,'entree prede4'
      if(itest(44).eq.2) then
         call prede4s(iesp,iadrr,inddet,
     *   ispi1,ispi2,llll,iiii,ifil,
     *   iadrr(iadri*2+1),iadrr(iadri*3+1))
         return
      endif
 
 
      kdet=0
c     write(6,*)'num1',(num1(k),k=1,nor1)
c     write(6,*)'num2',(num2(k),k=1,nor2)
c     write(6,*)'num3',(num3(k),k=1,nor3)
c
c--------------------------------------------------
c     generation des determinants non excites
c--------------------------------------------------
c
      call gende0(iesp,
     *iesp(maxorbcas*maxdetc+1),iadrr,kdet,
     *iadrr(iadri*2+1),iadrr(iadri*3+1))
      mdec=kdet
c
c--------------------------------------------------
c     lecture des integrales <oovv>
c     generation des determinants diexcites
c--------------------------------------------------
      open(42,status='OLD',file=ifil,form='UNFORMATTED')
      do ln=1,llll+1
         call lirin4(inti,intj,intk,intl,aaint,42)
c         read(42)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.llll+1) lfini=iiii
         do in=1,lfini
            io1=inti(in)
            io2=intj(in)
            io3=intk(in)
            io4=intl(in)
            a=aaint(in)
c1       read(42,*) io1,io2,io3,io4
c           write(6,*)'io1,io2,io3,io4'
c     *      ,io1,io2,io3,io4
            if(ifil.eq.'CDI_3311') then
               call gende4(iesp,
     *         iesp(maxorbcas*maxdetc+1),iadrr,io1,io2,io3,io4,
     *         ispi1,ispi2,kdet,
     *         iadrr(iadri*2+1),iadrr(iadri*3+1))
            endif
            if(io1.ne.io2.or.io3.ne.io4) call gende4(iesp,
     *      iesp(maxorbcas*maxdetc+1),iadrr,io2,io1,io4,io3,
     *      ispi1,ispi2,kdet,
     *      iadrr(iadri*2+1),iadrr(iadri*3+1))
         enddo
      enddo
      mdet(inddet)=kdet
      close(42)
      write(77) mdec
      if(yw) then
         do k=1,kdet
            print*,'prede4 iadrr',k,iadrr(k)
         enddo
      endif
      call ecribl(iadrr,kdet,76)
      return
      end
       subroutine gende4(nsa,nsb,iadrr,io1,io2,io3,io4,
     *ispo1,ispo2,kdet,mh,mt)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16,maxdetc=12870)
      common/opt/ihab,calcul
      character*3 calcul
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/dim/iadri ; integer(8) iadri
      dimension iadrr(iadri)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      dimension ica(maxorbcas),icb(maxorbcas),
     *ita(2),itb(2),ipa(2),ipb(2),it(2),ip(2)
      common/gd/ melc(5),nmelc
      dimension mh(iadri),mt(iadri)
      common/test/itest(100)
c      data melc /0,1,-1,2,-2/
      yw=.false.
      yw1=.false.
c      print*,'entree gende4 kdet',kdet
c
c-----on commence a remplir les trous et part
c
      mta=0
      mtb=0
      mpa=0
      mpb=0
      ist0=1
      isp0=1
      ist0=itsym(io1)
      if(ispo1.eq.1) then
         mta=mta+1
         ita(mta)=io1
      else
         mtb=mtb+1
         itb(mtb)=io1
      endif
      ist0=its(ist0,itsym(io2))
      if(ispo2.eq.1) then
         mta=mta+1
         ita(mta)=io2
      else
         mtb=mtb+1
         itb(mtb)=io2
      endif
 20   continue
      isp0=its(isp0,itsym(io3))
      if(ispo1.eq.1) then
         mpa=mpa+1
         ipa(mpa)=io3
      else
         mpb=mpb+1
         ipb(mpb)=io3
      endif
      isp0=its(isp0,itsym(io4))
      if(ispo2.eq.1) then
         mpa=mpa+1
         ipa(mpa)=io4
      else
         mpb=mpb+1
         ipb(mpb)=io4
      endif
      nto=2
      npo=2
      nin=0
      nvi=0
      ispt=mta-mtb
      ispp=mpa-mpb
c
c-----ispt0 et ispp0 sont les spins de depart des T et P
c
c      print*,'mta,mtb,mpa,mpb',mta,mtb,mpa,mpb
c      print*,'ita,itb,ipa,ipb',(ita(k),k=1,mta),(ipa(k),k=1,mpa),
c     * (itb(k),k=1,mtb),(ipb(k),k=1,mpb)
      nelc=0
      nelcas=nelac+nelc
      if(yw)write(6,*)'entree gende4  nelc,nelcas',nelc,nelcas
      ipasc=1
      ispc1=0
      ispc=jsp(ispc1,nelc)
c
c     -----------------------------------
c       GENERATION DU CAS
c     ----------------------------------
c
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      nca=(nelcas+ispcas)/2
      if(nca.lt.0) return
      ncb=(nelcas-ispcas)/2
      if(yw)write(6,*)'nelc,nelcas,ispcas,nca,ncb',
     *nelc,nelcas,ispcas,nca,ncb
      call combin(nsa,noac,nca,na,maxorbcas,maxdetc)
      call combin(nsb,noac,ncb,nb,maxorbcas,maxdetc)
      if(yw)write(6,*)'na,nb',na,nb
c     signe : le determinant est
c       t1 t2 | C... | p1 p2
c     il est destine a etre di-desexcite
c     p1 et p2 vont aller en t1 et t2
c     chaque saut au-dessus d'un electron du CAS de meme
c     spin change le signe
      isgn=1
      if(mod(mpa*nca+mpb*ncb,2).eq.1) isgn=-1
      kkk=0
      do 10 ia=1,na
      isca=1
      do k=1,nca
         if(yw)
     *   write(6,*)'ia,nsa(k,ia)',ia,(nsa(kk,ia),kk=1,nca)
         ica(k)=numac(nsa(k,ia))
         isca=its(isca,itsym(ica(k)))
      enddo
      do 11 ib=1,nb
      iscb=1
      do k=1,ncb
         if(yw)
     *   write(6,*)'ib,nsb(k,ib)',ib,(nsb(kk,ib),kk=1,ncb)
         icb(k)=numac(nsb(k,ib))
         iscb=its(iscb,itsym(icb(k)))
      enddo
      isc=its(isca,iscb)
      if(isc.ne.is0) goto 11
      if(yw)
     *write(6,*)'CAS',(ica(k),k=1,nca),'   ',(-icb(k),k=1,ncb)
      if(yw)
     *write(6,*)'isc,ispcas,ispc,ispc1',isc,ispcas,ispc,ispc1
      kk=0
      if(gener(1:2).eq.'MR') then
         call accept(nca,ica,ncb,icb,2,2,ynon)
         if(ynon) goto 11
      endif
      do k=1,mta
         kk=kk+1
         it(kk)=ita(k)
      enddo
      do k=1,mtb
         kk=kk+1
         it(kk)=itb(k)
      enddo
      kk=0
      do k=1,mpa
         kk=kk+1
         ip(kk)=ipa(k)
      enddo
      do k=1,mpb
         kk=kk+1
         ip(kk)=ipb(k)
      enddo
      kdet=kdet+1
      kkk=kkk+1
c      if(kdet.gt.iadri*4) then
c         write(6,*)'kdet,iadri*4',kdet,iadri*4
c         stop 29
c      endif
      if(yw1)call wrdet(nca,ncb,ica,icb,mta,mtb,ita,
     *itb,mpa,mpb,ipa,ipb)
      call adrdet(nca,ica,ncb,icb,
     *2,it,ispt,2,ip,ispp,iadr,
     *      mhdum,mtdum)
         if(kdet.le.iadri)iadrr(kdet)=iadr*isgn
         if(itest(44).eq.2) then
c         print*,'mhdum',mhdum
            mh(kkk)=mhdum
            mt(kkk)=mtdum
         endif
 11   continue
 10   continue
c      write(6,*)'**************************************'
c      write(6,*)'*******      fin de casdet    ********'
      if(yw1)write(6,*)' gende4 nombre de determinants generes',kdet
c      write(6,*)'**************************************'
      return
      end
       subroutine gende0(nsa,nsb,iadrr,kdet,mh,mt)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16,maxdetc=12870)
      common/opt/ihab,calcul
      character*3 calcul
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/dim/iadri ; integer(8) iadri
      dimension iadrr(iadri)
      dimension mh(iadri),mt(iadri)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      dimension ica(maxorbcas),icb(maxorbcas)
      common/gd/ melc(5),nmelc
      common/test/itest(100)
c      data melc /0,1,-1,2,-2/
      yw=.false.
      yw1=.false.
      nelc=0
      nelcas=nelac+nelc
      if(yw)write(6,*)'entree gende0  nelc,nelcas',nelc,nelcas
      ipasc=1
      ispc1=0
      ispc=jsp(ispc1,nelc)
c
c-----------------------------------
c          GENERATION DU CAS
c-----------------------------------
c
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      nca=(nelcas+ispcas)/2
      if(nca.lt.0) return
      ncb=(nelcas-ispcas)/2
      if(yw)write(6,*)'nelc,nelcas,ispcas,nca,ncb',
     *nelc,nelcas,ispcas,nca,ncb
      call combin(nsa,noac,nca,na,maxorbcas,maxdetc)
      call combin(nsb,noac,ncb,nb,maxorbcas,maxdetc)
      if(yw)write(6,*)'na,nb',na,nb
      do 10 ia=1,na
      isca=1
      do k=1,nca
         if(yw)
     *   write(6,*)'ia,nsa(k,ia)',ia,(nsa(kk,ia),kk=1,nca)
         ica(k)=numac(nsa(k,ia))
         isca=its(isca,itsym(ica(k)))
      enddo
      do 11 ib=1,nb
      iscb=1
      do k=1,ncb
         if(yw)
     *   write(6,*)'ib,nsb(k,ib)',ib,(nsb(kk,ib),kk=1,ncb)
         icb(k)=numac(nsb(k,ib))
         iscb=its(iscb,itsym(icb(k)))
      enddo
      isc=its(isca,iscb)
      if(isc.ne.is0) goto 11
      if(yw)
     *write(6,*)'CAS',(ica(k),k=1,nca),'   ',(-icb(k),k=1,ncb)
      if(yw)
     *write(6,*)'isc,ispcas,ispc,ispc1',isc,ispcas,ispc,ispc1
      if(gener(1:2).eq.'MR') then
         call accept(nca,ica,ncb,icb,2,2,ynon)
         if(ynon) goto 11
      endif
      kdet=kdet+1
c      if(kdet.gt.iadri*4) then
c         write(6,*)'kdet,iadri*4',kdet,iadri*4
c         stop 29
c      endif
      if(yw1)call wrdet(nca,ncb,ica,icb,0,0,ita,
     *itb,0,0,ipa,ipb)
      call adrdet(nca,ica,ncb,icb,
     *0,it,0,0,ip,0,iadr,
     *mhdum,mtdum)
         if(kdet.le.iadri) iadrr(kdet)=iadr
         if(itest(44).eq.2) then
            if(kdet.le.iadri) then
               mh(kdet)=mhdum
               mt(kdet)=mtdum
            endif
         endif
         if(yw)   write(6,*)
     *   'adresse iadr,kdet'
     *   ,iadr,kdet
c         call tradnv
c     *   (nca,ncb,ica,icb,nta,ntb,ita,
c     *                           itb,npa,npb,ipa,ipb,ne,it,ip)
 11   continue
 10   continue
      if(yw1)write(6,*)' gende0 nombre de determinants generes',kdet
      return
      end
       subroutine cdr5m(ifil,iadrr,ab,mdet1,lllll,iiiii,icas)
      parameter(maxsym=8)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension iadrr(iadri),ab(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |       ab      |
c
c
c         write(6,*)'cdr5m mdet1',mdet1
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et mdec
c     lecture de iadrr
      call lirbl(iadrr,mdet1,76)
      if(yw) then
         write(6,*)'cdr5m mdet1',mdet1
         do k=1,mdet1
            write(6,*)'cdr5m k,iadrr(k)',k,iadrr(k)
         enddo
      endif
c     lecture de mdec
      read(77) mdec
      if(yw) then
         write(6,*)'mdec ',mdec
      endif
c     lecture des integrales speciales
      if(yw)write(6,*)'ifil,iiiii',ifil,iiiii
      idet=mdec
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
c         read(28)inti,intj,intk,intl,aaint
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(yga2)then
               if(icas.eq.1) then
                  ifilg2=56
                  lg=lg2
                  ig=ig2
                  icg2=1
               else if(icas.eq.3) then
                  ifilg2=58
                  lg=lg2m
                  ig=ig2m
                  icg2=3
               else if(icas.eq.2) then
                  ifilg2=57
                  lg=lg2p
                  ig=ig2p
                  icg2=2
               endif
            endif
            if(yw1) then
               write(75,*)'int spec lue',i,j,k,l,a,'$'
               call scril
            endif
            if(ifil.eq.'CDI_3311') then
               if(yga2)a=1.d0
               call cdr6m(a,mdec,idet,iadrr,ab)
               if(yga2) call disin1(lg,ig,ifilg2,i,j,k,l,a,icg2)
            endif
            if(i.ne.j.or.k.ne.l) then
               if(yga2)a=1.d0
               call cdr6m(a,mdec,idet,iadrr,ab)
               if(yga2) call disin1(lg,ig,ifilg2,i,j,k,l,a,icg2)
            endif
         enddo
      enddo
      close(28)
      return
      end
       subroutine cdr6m(a,mdec,l,iadrr,ab)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(ngru3=2048)
      real*4 d
      common/ver3/ itab(ngru3),jtab(ngru3),d(ngru3)
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension iadrr(iadri),ab(iadri)
      COMMON/VER2/nelem
      common/pr/nprint,mprint(10)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr |       |       ab      |
c
c
      yw1=.false.
      yw=.false.
      if(yw)write(6,1)'entree cdr6m mdec',mdec
 1    format(a20,10i4)
      if(yw) then
         write(6,*)'entree cdr6m '
      endif
c      if(yw) then
c         do k=1,140
c            write(6,*)'k,iadrr(k)',k,iadrr(k)
c         enddo
c      endif
      do k=1,mdec
         l=l+1
         if(yw)write(6,*)'entree cdr6m k,l',k,l,iadrr(k),iadrr(l)
c         nelem=nelem+1
c         if(nelem.gt.ngru3) then
c            nelem=1
c            write(1)itab,jtab,d
c         endif
         iadrrk=iabs(iadrr(k))
         iadrrl=iabs(iadrr(l))
cdcor
ccor             minbid=(iadrr(k))
ccor             maxbid=(iadrr(l))
ccor             print*,'stocdr6m',minbid,maxbid,a
ccor             print*,'stocdr6m',maxbid,minbid,a
cfcor
         isgn=1
c         itab(nelem)=iadrrk
c         jtab(nelem)=iadrrl
         if(iadrr(k).gt.0) then
            if(iadrr(l).gt.0) then
               aa=a
            else
               aa=-a
            endif
         else
            if(iadrr(l).gt.0) then
               aa=-a
            else
               aa=a
            endif
         endif
c         if(iadrr(k)*iadrr(l).lt.0) then
c            aa=-a
c         else
c            aa=a
c         endif
         call stover(iadrrk,iadrrl,aa)
         if(yga2) call stoga2(iadrrk,iadrrl,aa,ab)
 2       continue
      enddo
      return
      end
       subroutine cdr5(b,ab,v3,v2,
     *ifil,mdet1,inddet,lnt1,int1)
      parameter(maxsym=8,ngru3=2048)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*8 ifil
      common/dim/iadri ; integer(8) iadri
      common /det/ndet,mdet(50),nbdet_cas
      dimension iadrr3(ngru3),iadrr2(ngru3)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      character*1 syspin
      common /sysp1/syspin
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
ccor      common/bidvr2/ire
ccor      call lirbl(ibidr(1,1),mdet1,76)
ccor      backspace 76
cfcor
c      common/bid2/ibidin
c      ibidin=inddet
      yw=.false.
      yw1=.false.
      if(yw1)write(6,*)'entree cdr5 icas',inddet
corr  write(6,*)'correc entree cdr1 icas',inddet
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      | iadrr |       |      v2       | |
c                           puis     |       v3      | iadrr |
c                                                                 ()
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr et mdec
c     lecture de iadrr
C      call lirbl(iadrr3,mdet1,76)
c     lecture de mdec
      read(77) mdec
c      print*,'mdec',mdec
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
      call v1v2bis(b,iadrr3,v2,mdet1)
c      do k=1,mdet1
c         write(6,*)'cdr5 k,iadrr3(k)',k,iadrr3(k)
c      enddo
c     lecture des integrales <oovv>
      do kk=1,mdet1
         v3(kk)=0.d0
      enddo
      idet=mdec
      do ln=1,lnt1+1
         call lirin4(inti,intj,intk,intl,aaint,28)
         lfini=1024
         if(ln.eq.lnt1+1) lfini=int1
         do in=1,lfini
            i=inti(in)
            j=intj(in)
            k=intk(in)
            l=intl(in)
            a=aaint(in)
            if(syspin.eq.'0') then
               if(ifil.eq.'CDI_3311') then
                  call cdr6(a,v3,v2,mdec,idet)
                  if(yw1) then
                     write(75,*)'int spec lue', ifil,i,j,k,l,a,'cdr51$'
                     call scril
                  endif
               endif
               if(i.ne.j.or.k.ne.l) then
                  call cdr6(a,v3,v2,mdec,idet)
                  if(yw1) then
                     write(75,*)'int spec lue', ifil,i,j,k,l,a,'cdr52$'
                     call scril
                  endif
               endif
            else
               if(ifil.eq.'CDI_3311') then
                  if(i.eq.j.and.k.eq.l) a=a/2
                  call cdr6(a,v3,v2,mdec,idet)
                  if(i.ne.j.or.k.ne.l) idet=idet+mdec
               else
                  if(i.ne.j.or.k.ne.l)
     *            call cdr6(a,v3,v2,mdec,idet)
               endif
            endif
         enddo
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on relit iadrr
C      call back(76,mdet1)
c     backspace 76
C      call lirbl(iadrr2,mdet1,76)
      if(yw)write(6,*)'ab avant v3v4'
      if(yw)write(6,*)(ab(kk),kk=1,22)
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4bis(ab,v3,iadrr2,mdet1,.true.)
      if(yw)write(6,*)'ab apres v3v4'
      if(yw)write(6,*)(ab(kk),kk=1,22)
      close(28)
      return
      end
       subroutine cdr6(a,v3,v2,mdec,l)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension v3(iadri),v2(iadri)
      common/test/itest(100)
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      common/bid2/inddet
      yw=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |      v3       |      v2       | |
c                                                                 ()
c
      if(yw)write(6,*)'entree cdr6'
      do k=1,mdec
         l=l+1
         v3(l)=v3(l)+a*v2(k)
         v3(k)=v3(k)+a*v2(l)
c         if(itest(17).eq.l)write(6,'('' cdr6 it17'',i5,3f12.8)')
c     *   k,a,v2(k),v3(l)
c         if(itest(17).eq.k)write(6,'('' cdr6 it17'',i5,3f12.8)')
c     *   l,a,v2(l),v3(k)
c         if(yw)write(6,*)'cdr6 v2,v3,a',v2(k),v3(l),a
c         if(yw)write(6,*)'cdr6 v2,v3,a',v2(l),v3(k),a
      enddo
      return
      end
       subroutine accept(nca,ica,ncb,icb,nt,np,ynon)
c
c---------------------------------------------------------
c     verification de la conformite d'un determinant MR
c---------------------------------------------------------
c
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAMETER (maxsym=8,maxorbcas=16,idicmr=35000)
      include 'maxorb.prm'
      common/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      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 /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      integer ces
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension iocc(maxorbcas)
      dimension ic1(maxorbcas)
      yw=.false.
      if(gener.eq.'MR') then
         call adrc_mr(nca,ica,ncb,icb,iadrcas)
         call callim(mixtpmr(iadrcas),maxt,maxp,mint,minp)
         ynon=nt.gt.maxt.or.np.gt.maxp.or.nt.lt.mint.or.np.lt.minp
         if(yw) then
            print*,'accept iadrcas,mixtpmr(iadrcas)',
     *      iadrcas,mixtpmr(iadrcas)
            print*,'accept nt,np',nt,np
            print*,'accept maxt,maxp,mint,minp',maxt,maxp,mint,minp
         endif
      else
         call tradmrs(iocc,nca,ica,ncb,icb)
         call adrcass(iocc,iadrs,ncf,nc1,ic1)
         mixtpmrs=ichar(tpmrs(iadrs))
         call sptxm(mint,maxt,minp,mixtpmrs)
         maxp=minp+maxt-mint
         ynon=nt.gt.maxt.or.np.gt.maxp.or.nt.lt.mint.or.np.lt.minp
         if(yw) then
            print*,'iocc',iocc
            print*,'accept iadrs,mixtpmrs'
     *      ,iadrs,mixtpmrs
            print*,'accept nt,np',nt,np
            print*,'accept maxt,maxp,mint,minp',maxt,maxp,mint,minp
         endif
      endif
      return
      end
 
