      subroutine cdc1(b,ab,v3,v2,idebd1,idebd2,
     *nn,ilond,ifil,
     *lllll,iiiii,mdet1,mdet2,inddet)
      parameter(maxsym=8,maxda3=300,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 b(iadri),ab(iadri),v3(iadri),v2(iadri)
      common/opt/ihab,calcul
      character*3 calcul
      dimension iadrr2(ngru3),iadrr3(ngru3)
      dimension idebd1(norb,norb),idebd2(norb,norb),ilond(maxsym)
      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/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
c
c      common /corr/jadrr2(500),jadrr3(500)
c
      yw=.false.
      yw1=.false.
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |       ab      | iadrr3|       |      v2       | |
c                           puis     |       v3      | iadrr2|
c                                                                 ()
c
c 1) debut           |b       |ab      |        |        |
c 2) lire iadrr3     |b       |ab      |iadrr3  |        |
c 3) transfert b-->v2|b       |ab      |iadrr3  |v2      |
c 4) calcul v3       |b       |ab      |v3      |v2      |
c 5) lire iadrr2     |b       |ab      |v3      |iadrr2  |
c 6) transf v3-->ab  |b       |ab      |v3      |iadrr2  |
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
      ire=1
      mdet1l=mdet1
      mdet2l=mdet2
 1    continue
c ----on lit iadrr correspondant aux det ab+-,
c     (Ia+- au 2eme passage ire=0) idebd1, ilond et idebd2
C      call lirbl(iadrr3,mdet1l,76)
c 2) lu iadrr3     |b       |ab      |iadrr3  |        |
c      if(yw) then
c         write(6,*)'cdc1 mdet1l',mdet1l
c         do k=1,mdet1l
c            write(6,*)'cdc1 k,iadrr3(k)',k,iadrr3(k)
c         enddo
c      endif
      if(ire.eq.0) then
         goto 2
      endif
c     lecture de idebd1
      call liri(idebd1,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd2
      call liri(idebd2,nn,77)
      if(yw) then
         do kk=1,norb
            write(75,*)'idebd1',(idebd1(kk,ll),ll=1,norb),'$'
            call scril
         enddo
         do kk=1,norb
            write(75,*)'idebd2',(idebd2(kk,ll),ll=1,norb),'$'
            call scril
         enddo
         print*,'ilond',ilond
      endif
      read(77)
 2    continue
c     transfert du vecteur d'entree dans v2 ordonne pour le produit
      call v1v2bis(b,iadrr3,v2,mdet1l)
      do k=2,icalc1
         call back(76,mdet1l)
         call v1v2bis(b((k-1)*maxl0+1),iadrr3,v2((k-1)*mdet1l+1),mdet1l)
      enddo
      if(ire.eq.0) then
         call back(76,mdet2l)
         call back(76,mdet1l)
c        backspace 76
c        backspace 76
      endif
c 3) transfert b-->v2|b       |ab      |iadrr3  |v2      |
c     lecture des integrales speciales 2333
      do kk=1,mdet2l
         v3(kk)=0.d0
      enddo
      do kk=mdet2l+1,mdet2l*icalc1
         v3(kk)=0.d0
      enddo
c 4) calcul v3       |b       |ab      |v3      |v2      |
      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 4 in=1,lfini
         ir=inti(in)
         ia=intj(in)
         ib=intk(in)
         ic=intl(in)
c         if(ia.eq.ic) goto 4
         a=aaint(in)
         if(a.eq.0.d0) goto 4
c          read(28,*) ii,ij,ia,ib,a
         if(yw1) then
            write(75,*)'int spec lue',ir,ia,ib,ic,a,'$'
            call scril
         endif
         if(ire.eq.1) then
            if(inddet.eq.32) then
               call cdc2(ic,ib,ia,ir,a,v3,v2,idebd1,idebd2,ilond,
     *         mdet1l,mdet2l)
               if(ia.ne.ic)
     *         call cdc2(ia,ib,ic,ir,a,v3,v2,idebd1,idebd2,ilond,
     *         mdet1l,mdet2l)
            else     if(inddet.eq.33) then
               call cdc2(ib,ic,ia,ir,a,v3,v2,idebd1,idebd2,ilond,
     *         mdet1l,mdet2l)
               if(ia.ne.ic)
     *         call cdc2(ib,ia,ic,ir,a,v3,v2,idebd1,idebd2,ilond,
     *         mdet1l,mdet2l)
            else     if(inddet.eq.34.or.inddet.eq.35) then
               call cdc2(ib,ic,ia,ir,a,v3,v2,idebd1,idebd2,ilond,
     *         mdet1l,mdet2l)
            endif
         else
            if(inddet.eq.32) then
               call cdc2(ia,ir,ic,ib,a,v3,v2,idebd2,idebd1,ilond,
     *         mdet1l,mdet2l)
               if(ia.ne.ic)
     *         call cdc2(ic,ir,ia,ib,a,v3,v2,idebd2,idebd1,ilond,
     *         mdet1l,mdet2l)
            else     if(inddet.eq.33) then
               call cdc2(ia,ir,ib,ic,a,v3,v2,idebd2,idebd1,ilond,
     *         mdet1l,mdet2l)
               if(ia.ne.ic)
     *         call cdc2(ic,ir,ib,ia,a,v3,v2,idebd2,idebd1,ilond,
     *         mdet1l,mdet2l)
            else     if(inddet.eq.34.or.inddet.eq.35) then
               call cdc2(ia,ir,ib,ic,a,v3,v2,idebd2,idebd1,ilond,
     *         mdet1l,mdet2l)
            endif
         endif
 4       continue
      enddo
c     transfert de v3 ordonne pour le produit dans ab
c     on lit iadrr correspondant aux det +- et --
c 5) lu iadrr2       |b       |ab      |v3      |iadrr2  |
c 6) transf v3-->ab  |b       |ab      |v3      |iadrr2  |
      if(lbor.eq.1) then
         rewind 82
         call lir8bl(ab,nmulr,82)
      endif
      call v3v4bis(ab,v3,iadrr2,mdet2l,.false.)
      if(ire.eq.1)call borlir(b)
      do k=2,icalc1
         call back(76,mdet2l)
         call v3v4bis(ab((k-1)*maxl0+1),v3((k-1)*mdet2l+1),iadrr2,
     *   mdet2l,.false.)
      enddo
c      do k=1,mdet2l
c        write(6,*)'cdc1 iadrr2 v3',k,iadrr2(k),v3(k)
c      enddo
c      do k=1,ndet
c         write(6,*)'cdc1 ab',k,ab(k)
c      enddo
      if(ire.eq.1) then
         ire=0
c        backspace 76
         call back(76,mdet2l)
         rewind 28
         mdet1l=mdet2
         mdet2l=mdet1
         goto 1
      endif
      call saut(76,mdet1l)
c     read(76)
      close(28)
      return
      end
       subroutine cdc2(in,jn,kn,ln,a,v3,v2,idebd1,idebd2,ilond,
     *mdet1l,mdet2l)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxda3=300)
      include 'maxorb.prm'
c
c      common/corr/jadrr2(500),jadrr3(500)
c
c      common/ver2/iadrver(500)
c
      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),idebd1(norb,norb),idebd2(norb,norb)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      dimension ilond(maxsym)
cdcor
ccor  common/bidvr/ibidv(10000),ibidr(10000,20),icor
ccor      common/bidvr2/ire
cfcor
c      common/bid2/inddet
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       b       |      ab       |      v3       |      v2       | |
c                                                                 ()
c
      yw=.false.
      yw1=.false.
c         do k=1,98
c            write(6,*)'cdc2 k,jadrr2(k)',k,jadrr2(k)
c         enddo
c         do k=1,98
c            write(6,*)'cdc2 k,jadrr3(k)',k,jadrr3(k)
c         enddo
      if(yw) then
         do kk=1,norb
            write(75,*)'cdc2 idebd1',(idebd1(kk,ll),ll=1,norb),'$'
            call scril
         enddo
         do kk=1,norb
            write(75,*)'cdc2 idebd2',(idebd2(kk,ll),ll=1,norb),'$'
            call scril
         enddo
         print*,'ilond',ilond
      endif
      if(yw)write(6,*)'entree cdc2 in,jn,kn,ln',in,jn,kn,ln
      ideb1=idebd1(jn,in)
      l=idebd2(ln,kn)-1
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
      if(yw)print*,'jn,in,ideb1,ifin1',jn,in,ideb1,ifin1
      if(yw)print*,'ln,kn,l',ln,kn,l
      if(yw)write(6,*)'ideb1,ifin1,l',ideb1,ifin1,l
      do k=ideb1,ifin1
         l=l+1
c          write(6,*)'k,l',k,l
c         write(75,*)'adr',jadrr3(k),jadrr2(l),'$'
c          call scril
c          if((jadrr2(l)).ne.0.and.(jadrr3(k)).ne.0)then
c         write(75,*)'adr num',jadrr2(l),jadrr3(k),
c       *   iadrver(iabs(jadrr2(l))),iadrver(iabs(jadrr3(k))),'$'
c          call scril
c          endif
         v3(l)=v3(l)+a*v2(k)
CIT17           if(itest(17).eq.l)write(6,'('' cdc2 it17'',i5,2f12.8)')
CIT17        *   k,a,v2(k)
c      write(6,'(a5,2i4,2f12.8)')'cdc1',l,k,v3(l),v2(k)
c        if(jadrr2(l).eq.35)write(6,'(a15,3f12.8,i8)')
c     *          'v2,a,v2a,iad',v2(l),a,a*v2(l),jadrr3(k)
         if(yw)write(6,*)'v2,v3,a',v2(l),v3(k),a
c         print*,'stocmd',k,l,a
      enddo
c--   multiracine
c     write(6,*)'cdc2 icalc1',icalc1
      do kk=2,icalc1
         incr1=(kk-1)*mdet1l
         incr2=(kk-1)*mdet2l
         ideb2=ideb1+incr1
         ifin2=ifin1+incr1
         l2=idebd2(ln,kn)-1+incr2
         do k=ideb2,ifin2
            l2=l2+1
c         vvv=v3(l2)
            v3(l2)=v3(l2)+a*v2(k)
CIT17           if(itest(17).eq.l2)write(6,'('' cdc2 it17'',i5,2f12.8)')
CIT17        *   k,a,v2(k)
c         write(6,'(a5,4i4,3f12.8)')'cdc1',l2,k,l2-incr2,k-incr1
c     *      ,v3(l2),v2(k),vvv
         enddo
      enddo
      return
      end
       subroutine cdc1m(idebd1,idebd2,nn,ilond,ifil,ab,iadrr3,iadrr2,
     *lllll,iiiii,mdet1,mdet2,inddet)
      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
      dimension iadrr2(iadri),iadrr3(iadri),ab(iadri)
      dimension idebd1(norb,norb),ilond(maxsym)
      dimension idebd2(norb,norb)
      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    | iadrr2| iadrr3|      ab       |
c
c
      open(28,status='OLD',file=ifil,form='UNFORMATTED')
c ----on lit iadrr3,iadrr2 et idebd et ilond
c     lecture de iadrr3 (determinants |a b + - >
      call lirbl(iadrr3,mdet1,76)
      if(yw) then
         write(6,*)'cdc1m mdet1',mdet1
         do k=1,mdet1
            write(6,*)'cdc1m k,iadrr3(k)',k,iadrr3(k)
         enddo
      endif
c     lecture de iadrr2 (determinants |I  a  +  ->
      call lirbl(iadrr2,mdet2,76)
      if(yw) then
         write(6,*)'cdc1m mdet2',mdet2
         do k=1,mdet2
            write(6,*)'cdc1m k,iadrr2(k)',k,iadrr2(k)
         enddo
      endif
c     lecture de idebd1
      call liri(idebd1,nn,77)
c     lecture de ilond
      call liri(ilond,maxsym,77)
c     lecture de idebd2
      call liri(idebd2,nn,77)
      read(77)
c     lecture des integrales speciales 2333
      do ln=1,lllll+1
         call lirin4(inti,intj,intk,intl,aaint,28)
         lfini=1024
         if(ln.eq.lllll+1) lfini=iiiii
         do 4 in=1,lfini
         ir=inti(in)
         ia=intj(in)
         ib=intk(in)
         ic=intl(in)
         a=aaint(in)
            if(yga2) then
               if(inddet.eq.32.or.inddet.eq.33) then
                  ifilg2=56
                  lg=lg2
                  ig=ig2
                  icg2=1
c                  if(inddet.eq.33) then
c                     ia=inti(in)
c                     ir=intj(in)
c                     ic=intk(in)
c                     ib=intl(in)
c                  endif
               else if(inddet.eq.35) then
                  ifilg2=58
                  lg=lg2m
                  ig=ig2m
                  icg2=3
               else if(inddet.eq.34) then
                  ifilg2=57
                  lg=lg2p
                  ig=ig2p
                  icg2=2
               endif
            endif
         if(yw1) then
            write(75,*)'cdc1m int spec lue',ir,ia,ib,ic,a,'$'
            call scril
         endif
         if(inddet.eq.32) then
            if(yga2)a=1.d0
c            if(yga2)print*,'CDC1M32',ic,ib,ia,ir,ig2,ig2m,ig2p
            call cdc2m(ic,ib,ia,ir,a,idebd1,idebd2,ilond,
     *      iadrr3,iadrr2,ab)
            if(yga2) call disin1(lg,ig,ifilg2,ic,ib,ia,ir,a,icg2)
            if(ia.ne.ic) then
               if(yga2)a=1.d0
               call cdc2m(ia,ib,ic,ir,a,idebd1,idebd2,ilond,
     *         iadrr3,iadrr2,ab)
               if(yga2) call disin1(lg,ig,ifilg2,ia,ib,ic,ir,a,icg2)
            endif
         else if (inddet.eq.33) then
            if(yga2)a=1.d0
            call cdc2m(ib,ic,ia,ir,a,idebd1,idebd2,ilond,
     *      iadrr3,iadrr2,ab)
            if(yga2) call disin1(lg,ig,ifilg2,ic,ib,ir,ia,a,icg2)
            if(ia.ne.ic) then
               if(yga2)a=1.d0
               call cdc2m(ib,ia,ic,ir,a,idebd1,idebd2,ilond,
     *         iadrr3,iadrr2,ab)
               if(yga2) call disin1(lg,ig,ifilg2,ia,ib,ir,ic,a,icg2)
            endif
         else if (inddet.eq.34.or.inddet.eq.35) then
            if(yga2)a=1.d0
            call cdc2m(ib,ic,ia,ir,a,idebd1,idebd2,ilond,
     *      iadrr3,iadrr2,ab)
            if(yga2) call disin1(lg,ig,ifilg2,ib,ic,ia,ir,a,icg2)
         endif
            if(yga2) then
               if(inddet.eq.32.or.inddet.eq.33) then
                  lg2=lg
                  ig2=ig
               else if(inddet.eq.35) then
                  lg2m=lg
                  ig2m=ig
               else if(inddet.eq.34) then
                  lg2p=lg
                  ig2p=ig
               endif
            endif
c            if(yga2)print*,'CDC1M32f',ic,ib,ia,ir,ig2,ig2m,ig2p
 4       continue
      enddo
      close(28)
      return
      end
       subroutine cdc2m(in,jn,kn,ln,a,idebd1,idebd2,ilond,
     *iadrr3,iadrr2,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,norb),ilond(maxsym)
      dimension idebd2(norb,norb)
      dimension iadrr2(iadri),iadrr3(iadri),ab(iadri)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      COMMON/VER2/nelem
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrr2| iadrr3|      ab       |
c
      yw1=.false.
      yw=.false.
      do k=1,norb
         if(yw)write(6,1)'entree cdc2m idebd1',(idebd1(k,l),l=1,norb)
      enddo
      do k=1,norb
         if(yw)write(6,1)'entree cdc2m idebd2',(idebd2(k,l),l=1,norb)
      enddo
      if(yw)write(6,1)'entree cdc2m ilond',(ilond(l),l=1,nsym)
 1    format(a20,10i4)
      ideb1=idebd1(jn,in)
      l=idebd2(ln,kn)-1
      if(yw)write(6,*)'entree cdc2m in,jn,kn,ln',in,jn,kn,ln
      ifin1=ideb1+ilond(its(itsym(in),itsym(jn)))
      if(yw)print*,'jn,in,ideb1,ifin1',jn,in,ideb1,ifin1
      if(yw)print*,'ln,kn,l',ln,kn,l
      do k=ideb1,ifin1
         l=l+1
         if(yw)write(6,*)'entree cdc2m k,l',k,l,iadrr3(k),iadrr2(l)
         if(iadrr2(l).eq.0) goto 2
         iadrrl=iabs(iadrr2(l))
         if(yga2) then
            aa=0.d0
            call stoga2(iadrr3(k),iadrrl,aa,ab)
            if(iadrr2(l).gt.0) then
               a=a+aa
            else
               a=a-aa
            endif
         else
            if(iadrr2(l).gt.0) then
               aa=a
            else
               aa=-a
            endif
            call stover(iadrr3(k),iadrrl,aa)
         endif
 2       continue
      enddo
      return
      end
