      subroutine cd02r(in,jn,kn,ln,a,esp1)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      parameter (idiracr=160000,idirac2=6000,idicmr=35000)
c
c-------------------------------------------------------------
c     les indices de l'integrale seront interdits sur un determinant,
c     et obligatoires sur l'autre
c     on repere les indices obligatoire sur l'un et l'autre determinant
c
c     les det sont ecrits en OCCUPATION. Les trous sont a changer
c     de cote pour ecrire en T/P
c-------------------------------------------------------------
c
      common/dim/iadri ; integer(8) iadri
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /icd1/ispin(2)
      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/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      common /cr/ mxstra(0:maxorbcas),mxstrb(maxsym,0:maxorbcas)
     *,nxstra(0:maxorbcas),nxstrb(maxsym,0:maxorbcas)
     *,kadra(idirac2),kadrb(idirac2),ksymca(idirac2)
     *,kok1a(idirac2),kok2a(idirac2),kok1b(idirac2),kok2b(idirac2)
     *,kkdeb1a(idirac2),kkdeb2a(idirac2)
     *,kkdeb1b(idirac2),kkdeb2b(idirac2)
     *,kkfin1a(idirac2),kkfin2a(idirac2)
     *,kkfin1b(idirac2),kkfin2b(idirac2)
     *,nnok1a,nnok1b,nnok2a,nnok2b,ndetca,ndetcb
     *,ksgnca(idirac2),ksgncb(idirac2)
     *,yimpca(maxorbcas,idirac2),yimpcb(maxorbcas,idirac2)
     *,ydetca(maxorbcas,idirac2),ydetcb(maxorbcas,idirac2)
c     *,yok1a(idirac2),yok2a(idirac2),yok1b(idirac2),yok2b(idirac2)
      common/obin/noblig1(3),noblig2(3),ioblig1(2,3),ioblig2(2,3)
     *,ioblig1a(2,3),ioblig1b(2,3),ioblig2a(2,3),ioblig2b(2,3)
     *,noblig1a(3),noblig2a(3)
     *,noblig1b(3),noblig2b(3),icoma,icomb
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      dimension ijkl(4),ijkl2(4)
      dimension esp1(iadri*2)
      dimension icoupa(4),icoupb(4)
      common /sgnr/ isgnr(maxorb*2),isgnr0
      character*1 impca(maxorbcas,idirac2)
      equivalence (impca(1,1),yimpca(1,1))
      character*1 impcb(maxorbcas,idirac2)
      equivalence (impcb(1,1),yimpcb(1,1))
      common/opt/ihab,calcul
      dimension isgntp(maxorb*maxorb)
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      character*3 calcul
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      dimension ibon1(maxorb*maxorb),ibon2(maxorb*maxorb)
      integer*2 jbon1(maxorb*maxorb),jbon2(maxorb*maxorb)
      integer*2 jbonc1(idiracr),jbonc2(idiracr)
      dimension ysgntp(maxorb*maxorb),
     *ysgnc(idiracr)
      common/test/itest(100)
      common/yr/ywr
      yw1=.false.
c
      if(gener(1:2).eq.'MR') then
c         print*,'lirint appel cd02s'
          call cd02s0(in,jn,kn,ln,a,esp1)
         return
      endif
c      print*,'cd02r in,jn,kn,ln',in,jn,kn,ln,a
      irest=itest(1)
c
c--   on stocke l'information a la premiere iteration
c--   ou bien on la relit
c
c     print*,'ystc,ystit1,irest,jint',ystc,ystit1,irest,jint
      if(ystc) then
         jint=jint+1
c
c--      signification de ystit1 :
c--      maxstc.ne.0 et 1ere iteration
c--      signification de ystc :
c--      on doit relire, ou ecrire les processus sur file
         if(ystit1.and.irest.ne.3.and.irest.ne.1) then
            if(jint.gt.1024) then
               jint=1
               write(79) jnb
c               print*,'ecriture 79'
c              do k=1,1024
c              print*,'ecr  jnb',k,jnb(k)
c              enddo
            endif
            jnb1=0
         else
            if(jint.gt.1024) then
               jint=1
               read(79) jnb
c              print*,'lecture 79'
c              do k=1,1024
c              print*,'lect  k,jnb(k)',k,jnb(k)
c              enddo
            endif
            jnb1=jnb(jint)
            if(jnb1.eq.-1) then
               ystc=.false.
               goto 555
            endif
c           print*,'appel cd08r',jnb1
            call cd08r(a,esp1,esp1(iadri1),
     *      ibon1,ibon2,ibon1(ninac*ninac+2),ibon2(ninac*ninac+2),
     *      jbon1,jbon2,jbon1(ninac*ninac+2),jbon2(ninac*ninac+2)
     *      ,jbonc1,jbonc2
     *      ,isgntp,isgntp(ninac*ninac+2)
     *      ,ysgntp,ysgntp(ninac*ninac+2),ysgnc)
            return
         endif
      endif
 555  continue
c
      icoma=0
      icomb=0
      if(in.eq.kn.and.itype(in).eq.2) then
         if(ispin(1).eq.1) icoma=1
         if(ispin(1).eq.-1) icomb=1
      endif
      if(jn.eq.ln.and.itype(jn).eq.2) then
         if(ispin(2).eq.1) icoma=1
         if(ispin(2).eq.-1) icomb=1
      endif
      icom=icoma+icomb
 200  continue
      ijkl(1)=in
      ijkl(2)=jn
      ijkl(3)=kn
      ijkl(4)=ln
      ijkl2(1)=in
      ijkl2(2)=jn
      ijkl2(3)=kn
      ijkl2(4)=ln
      ncoupa=0
      ncoupb=0
      ywr=.false.
c      ywr=all((/in,jn,kn,ln/).eq.(/5,9,4,1/))
c      ywr=in.eq.5.and.jn.eq.5.and.kn.eq.4.and.ln.eq.4
      yw=.false..or.ywr
      if(yw1)write(6,'(a20,4i3,f12.8)')'ijkl ab',ijkl,a
      do k=1,4
         if(itype(ijkl(k)).eq.2) then
            ijkl2(k)=icamun(ijkl(k))
         endif
      enddo
      if(yw)write(6,'(a20,4i3)')'ijkl2 ab',ijkl2
      do k=1,2
c         if(ijkl(k).eq.ijkl(k+2)) goto 10
         if(ispin(k).eq.-1) then
            if(itype(ijkl(k)).eq.2) then
               ncoupb=ncoupb+1
               icoupb(ncoupb)=ijkl2(k)
c               ijkl2(k)=ijkl2(k)+noac
c            else
c               ijkl2(k)=ijkl2(k)+norb
            endif
            if(itype(ijkl(k+2)).eq.2) then
               ncoupb=ncoupb+1
               icoupb(ncoupb)=ijkl2(k+2)
c               ijkl2(k+2)=ijkl2(k+2)+noac
c            else
c               ijkl2(k+2)=ijkl2(k+2)+norb
            endif
         else
            if(itype(ijkl(k)).eq.2) then
               ncoupa=ncoupa+1
               icoupa(ncoupa)=ijkl2(k)
            endif
            if(itype(ijkl(k+2)).eq.2) then
               ncoupa=ncoupa+1
               icoupa(ncoupa)=ijkl2(k+2)
            endif
         endif
 10      continue
      enddo
      do k=1,2
         if(ispin(k).eq.-1) then
            if(itype(ijkl(k)).eq.2) then
               ijkl2(k)=ijkl2(k)+noac
            else
               ijkl2(k)=ijkl2(k)+norb
            endif
            if(itype(ijkl(k+2)).eq.2) then
               ijkl2(k+2)=ijkl2(k+2)+noac
            else
               ijkl2(k+2)=ijkl2(k+2)+norb
            endif
         endif
      enddo
      call reor(ncoupa,icoupa,idum)
      call reor(ncoupb,icoupb,idum)
      if(yw) then
         print*,'icoupa',(icoupa(k),k=1,ncoupa)
         print*,'icoupb',(icoupb(k),k=1,ncoupb)
      endif
c
c-----------------------------------
c     signe
c
c     on considere que les electrons sautent de i en k et de j en l
c
c-----------------------------------
c
      isgnr0=1
      iti=isbrot(in)
      itj=isbrot(jn)
      itk=isbrot(kn)
      itl=isbrot(ln)
c
c--   si i-j et k-l sont de signe opposes
c     il faudra reordonner kl, donc il y a un signe moins
c
      if(ispin(1)+ispin(2).ne.0.and.(iti-itj)*(itk-itl).lt.0) then
         isgnr0=-1
c        c'est encore le cas pour les int <ijik>, mais pas si i est inac
         if(iti.eq.itk) then
            if(itype(in).eq.1) isgnr0=1
         endif
         if(itj.eq.itl) then
            if(itype(jn).eq.1) isgnr0=1
         endif
      endif
      if(yw)print*,'1 isgnr0',isgnr0
c
c
c--   les sites sautes par les mouvements i -->k ou j -->l sont mis
c     negatifs
      do k=1,norb+norb
         isgnr(k)=1
      enddo
      nn=0
      if(yw)print*,'iti,itj,itk,itl',iti,itj,itk,itl
      if(ispin(1).eq.-1) nn=norb
      do k=min(iti,itk)+1,max0(iti,itk)-1
         isgnr(k+nn)=-isgnr(k+nn)
      enddo
      nn=0
      if(ispin(2).eq.-1) nn=norb
      do k=min(itj,itl)+1,max0(itj,itl)-1
         isgnr(k+nn)=-isgnr(k+nn)
      enddo
c--   les sites des indices de l'integrale sont gardes positifs
      nn=0
      if(ispin(1).eq.-1) nn=norb
      isgnr(iti+nn)=1
      isgnr(itk+nn)=1
      nn=0
      if(ispin(2).eq.-1) nn=norb
      isgnr(itj+nn)=1
      isgnr(itl+nn)=1
c
c--   on ajoute les electrons dans les inactives
c     le signe est change suivant les signes des orbitales
c     ou on les met
      do k=1,ninac
         isgnr0=isgnr0*isgnr((k))
         if(yw)print*,'3 isgnr0,k',isgnr0,k
         isgnr0=isgnr0*isgnr((k)+norb)
         if(yw)print*,'4 isgnr0',isgnr0
      enddo
      if(yw) then
         if(yw)print*,'isgnr0',isgnr0
         write(6,'('' isgnr'',20i3)')(isgnr(k),k=1,norb)
         write(6,'('' isgnr'',20i3)')(isgnr(k),k=norb+1,norb+norb)
      endif
c
c--   signe dans la premiere tranche
c     le CAS est divise en tranches, separees par les orbitales
c     de l'integrale
c     la 1ere tranche va du debut du CAS a la premiere coupure
c     (la 1ere tranche peut etre de longueur nulle)
c
      jsgnca0=1
      jsgncb0=1
      if(ispin(1).eq.1) then
         if(itype(in).eq.1.and.itype(kn).ne.1.or.
     *   itype(in).ne.1.and.itype(kn).eq.1) jsgnca0=-jsgnca0
      else
         if(itype(in).eq.1.and.itype(kn).ne.1.or.
     *   itype(in).ne.1.and.itype(kn).eq.1) jsgncb0=-jsgncb0
      endif
      if(ispin(2).eq.1) then
         if(itype(jn).eq.1.and.itype(ln).ne.1.or.
     *   itype(jn).ne.1.and.itype(ln).eq.1) jsgnca0=-jsgnca0
      else
         if(itype(jn).eq.1.and.itype(ln).ne.1.or.
     *   itype(jn).ne.1.and.itype(ln).eq.1) jsgncb0=-jsgncb0
      endif
      if(yw)print*,'jsgnca0,jsgncb0',jsgnca0,jsgncb0
c
c-----------------------------------
c     obligations et interdits
c-----------------------------------
c
      do k=1,3
         noblig1(k)=0
         noblig2(k)=0
         noblig1a(k)=0
         noblig1b(k)=0
         noblig2a(k)=0
         noblig2b(k)=0
      enddo
      do k=1,2
         ii=ijkl2(k)
         ity=itype(ijkl(k))
         if(ity.eq.2) then
            nnn=noac
         else
            nnn=norb
         endif
         if(ity.eq.1) then
            noblig2(1)=noblig2(1)+1
            ioblig2(noblig2(1),1)=ii
            if(ispin(k).eq.1) then
               noblig2a(1)=noblig2a(1)+1
               ioblig2a(noblig2a(1),1)=ii
            else
               noblig2b(1)=noblig2b(1)+1
               ioblig2b(noblig2b(1),1)=ii-nnn
            endif
         else
            noblig1(ity)=noblig1(ity)+1
            ioblig1(noblig1(ity),ity)=ii
            if(ispin(k).eq.1) then
               noblig1a(ity)=noblig1a(ity)+1
               ioblig1a(noblig1a(ity),ity)=ii
            else
               noblig1b(ity)=noblig1b(ity)+1
               ioblig1b(noblig1b(ity),ity)=ii-nnn
            endif
         endif
      enddo
      do k=3,4
         ii=ijkl2(k)
         ity=itype(ijkl(k))
         if(ity.eq.2) then
            nnn=noac
         else
            nnn=norb
         endif
         if(ity.eq.1) then
            noblig1(1)=noblig1(1)+1
            ioblig1(noblig1(1),1)=ii
            if(ispin(k-2).eq.1) then
               noblig1a(1)=noblig1a(1)+1
               ioblig1a(noblig1a(1),1)=ii
            else
               noblig1b(1)=noblig1b(1)+1
               ioblig1b(noblig1b(1),1)=ii-nnn
            endif
         else
            noblig2(ity)=noblig2(ity)+1
            ioblig2(noblig2(ity),ity)=ii
            if(ispin(k-2).eq.1) then
               noblig2a(ity)=noblig2a(ity)+1
               ioblig2a(noblig2a(ity),ity)=ii
            else
               noblig2b(ity)=noblig2b(ity)+1
               ioblig2b(noblig2b(ity),ity)=ii-nnn
            endif
         endif
      enddo
      do ity=1,3
         if(noblig1(ity).eq.2) call reor(2,ioblig1(1,ity),idum)
         if(noblig2(ity).eq.2) call reor(2,ioblig2(1,ity),idum)
      enddo
c
c--   on met negatifs les ioblig identiques pour les det 1 et 2
      do ity=1,3
         do i=1,noblig1a(ity)
            do j=1,noblig2a(ity)
               if(ioblig1a(i,ity).eq.ioblig2a(j,ity)) then
                  ioblig1a(i,ity)=-ioblig1a(i,ity)
                  ioblig2a(j,ity)=-ioblig2a(j,ity)
               endif
            enddo
         enddo
      enddo
      do ity=1,3
         do i=1,noblig1b(ity)
            do j=1,noblig2b(ity)
               if(ioblig1b(i,ity).eq.ioblig2b(j,ity)) then
                  ioblig1b(i,ity)=-ioblig1b(i,ity)
                  ioblig2b(j,ity)=-ioblig2b(j,ity)
               endif
            enddo
         enddo
      enddo
      if(yw) then
         write(6,'(a20,4i3)')'ijkl2 ab',ijkl2
         write(6,'(a20,3i3,2x,3i3)')'noblig1,noblig2',noblig1,noblig2
         write(6,'(a20,3i3,2x,3i3)')
     *   'noblig1a,noblig2a',noblig1a,noblig2a
         write(6,'(a20,3i3,2x,3i3)')
     *   'noblig1b,noblig2b',noblig1b,noblig2b
         do ity=1,3
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig1',ity,(ioblig1(k,ity)
     *      ,k=1,noblig1(ity))
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig2',ity,(ioblig2(k,ity)
     *      ,k=1,noblig2(ity))
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig1a',
     *      ity,(ioblig1a(k,ity),k=1,noblig1a(ity))
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig2a',
     *      ity,(ioblig2a(k,ity),k=1,noblig2a(ity))
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig1b',
     *      ity,(ioblig1b(k,ity),k=1,noblig1b(ity))
            write(6,'(a20,i3,2x,2i3)')'ity,ioblig2b',
     *      ity,(ioblig2b(k,ity),k=1,noblig2b(ity))
         enddo
      endif
c
c---------------------------------------------------------------
c     elimination des determinants de CAS interdits
c
c     nnok : nombre de strings corrects
c     kok(k) : keme string correct, corresp au string numero kok(k)
c     (k=1,nnok)
c     kkdeb(kstring) : -pour les bons det = inv de kok
c     kkdeb(kstring) : -pour les mauvais = valeur suivante du kkdeb
c     qui est definie
c     kkfin(kstring) : -pour les bons det = inv de kok
c     kkfin(kstring) : -pour les mauvais = valeur precedente du kkdeb
c     qui est definie
c
c     strings  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -
c     bons        B        B                 B  B  B          B
c     kkdeb 1)    1        2                 3  4  5        6
c     kkdeb 1) 1  1  2  2  2  3  3  3  3  3  3  4  5  6  6  6
c     kkfin 1)    1        2                 3  4  5        6
c     kkfin 1) 0  1  1  1  2  2  2  2  2  2  3  4  5  5  5  6
c
c     k         1  2  3  4  5  6
c     kok(k)    2  5 11 12 13 16
c
c     methode : la liste des strings de bonne symetrie commence en
c               3 et finit en 14 par ex
c                    |                                |
c     kkdeb 1) 1  1  2  2  2  3  3  3  3  3  3  4  5  6  6  6
c     kkfin 1) 0  1  1  1  2  2  2  2  2  2  3  4  5  5  5  6
c
c     les bons strings ont les valeurs kkdeb(3) a kkfin(14) soit 2 a 5
c     les kok correspondants sont 5 11 12 13
c---------------------------------------------------------------
c
      do k=1,ndetca
         kkdeb1a(k)=0
         kkdeb2a(k)=0
         kkfin1a(k)=0
         kkfin2a(k)=0
      enddo
      do k=1,ndetcb
         kkdeb1b(k)=0
         kkdeb2b(k)=0
         kkfin1b(k)=0
         kkfin2b(k)=0
      enddo
      nnok1a=0
      nnok1b=0
      nnok2a=0
      nnok2b=0
c     Determinant 1
c
c     boucle sur les strings alpha corrects
      do 1 kk1a=1,ndetca
      if(yw)print*,'kk1a,ydetc1a',kk1a,(ydetca(k,kk1a),k=1,noac)
c      yok1a(kk1a)=.false.
      do ll1=1,noblig1a(2)
         mm1=iabs(ioblig1a(ll1,2))
         if(.not.ydetca(mm1,kk1a)) goto 1
      enddo
      do ll1=1,noblig2a(2)
         mm1=ioblig2a(ll1,2)
         if(mm1.gt.0.and.ydetca(mm1,kk1a)) goto 1
      enddo
      if(yw)print*,'accepte'
c      yok1a(kk1a)=.true.
      nnok1a=nnok1a+1
      kkdeb1a(kk1a)=nnok1a
      kkfin1a(kk1a)=nnok1a
      kok1a(nnok1a)=kk1a
 1    continue
c     boucle sur les strings beta corrects
      do 2 kk1b=1,ndetcb
      if(yw)print*,'kk1b,ydetc1b',kk1b,(ydetcb(k,kk1b),k=1,noac)
c      yok1b(kk1b)=.false.
      do ll1=1,noblig1b(2)
         mm1=iabs(ioblig1b(ll1,2))
         if(.not.ydetcb(mm1,kk1b)) goto 2
      enddo
      do ll1=1,noblig2b(2)
         mm1=ioblig2b(ll1,2)
         if(mm1.gt.0.and.ydetcb(mm1,kk1b)) goto 2
      enddo
      if(yw)print*,'accepte'
c      yok1b(kk1b)=.true.
      nnok1b=nnok1b+1
      kkdeb1b(kk1b)=nnok1b
      kkfin1b(kk1b)=nnok1b
      kok1b(nnok1b)=kk1b
 2    continue
c     Determinant 2
c
c     boucle sur les strings alpha corrects
      kkbon=0
      do 3 kk2a=1,ndetca
      if(yw)print*,'kk2a,ydetc2a',kk2a,(ydetca(k,kk2a),k=1,noac)
c      yok2a(kk2a)=.false.
      do ll1=1,noblig2a(2)
         mm1=iabs(ioblig2a(ll1,2))
         if(.not.ydetca(mm1,kk2a)) goto 3
      enddo
      do ll1=1,noblig1a(2)
         mm1=ioblig1a(ll1,2)
         if(mm1.gt.0.and.ydetca(mm1,kk2a)) goto 3
      enddo
      if(yw)print*,'accepte'
c      yok2a(kk2a)=.true.
      nnok2a=nnok2a+1
      kkdeb2a(kk2a)=nnok2a
      kkfin2a(kk2a)=nnok2a
      kok2a(nnok2a)=kk2a
 3    continue
c     boucle sur les strings beta corrects
      do 4 kk2b=1,ndetcb
      if(yw)print*,'kk2b,ydetc2b',kk2b,(ydetcb(k,kk2b),k=1,noac)
c      yok2b(kk2b)=.false.
      do ll1=1,noblig2b(2)
         mm1=iabs(ioblig2b(ll1,2))
         if(.not.ydetcb(mm1,kk2b)) goto 4
      enddo
      do ll1=1,noblig1b(2)
         mm1=ioblig1b(ll1,2)
         if(mm1.gt.0.and.ydetcb(mm1,kk2b)) goto 4
      enddo
      if(yw)print*,'accepte'
c      yok2b(kk2b)=.true.
      nnok2b=nnok2b+1
      kkdeb2b(kk2b)=nnok2b
      kkfin2b(kk2b)=nnok2b
      kok2b(nnok2b)=kk2b
 4    continue
c
      do k=2,ndetca
         if(kkfin1a(k).eq.0) kkfin1a(k)=kkfin1a(k-1)
         if(kkfin2a(k).eq.0) kkfin2a(k)=kkfin2a(k-1)
      enddo
      do k=2,ndetcb
         if(kkfin1b(k).eq.0) kkfin1b(k)=kkfin1b(k-1)
         if(kkfin2b(k).eq.0) kkfin2b(k)=kkfin2b(k-1)
      enddo
      do k=ndetca-1,1,-1
         if(kkdeb1a(k).eq.0) kkdeb1a(k)=kkdeb1a(k+1)
         if(kkdeb2a(k).eq.0) kkdeb2a(k)=kkdeb2a(k+1)
      enddo
      do k=ndetcb-1,1,-1
         if(kkdeb1b(k).eq.0) kkdeb1b(k)=kkdeb1b(k+1)
         if(kkdeb2b(k).eq.0) kkdeb2b(k)=kkdeb2b(k+1)
      enddo
      do k=ndetca,1,-1
         if(kkdeb1a(k).eq.0) then
            kkdeb1a(k)=nnok1a+1
         else
            goto 21
         endif
      enddo
 21   continue
      do k=ndetca,1,-1
         if(kkdeb2a(k).eq.0) then
            kkdeb2a(k)=nnok2a+1
         else
            goto 20
         endif
      enddo
 20   continue
      do k=ndetcb,1,-1
         if(kkdeb1b(k).eq.0) then
            kkdeb1b(k)=nnok1b+1
         else
            goto 30
         endif
      enddo
 30   continue
      do k=ndetcb,1,-1
         if(kkdeb2b(k).eq.0) then
            kkdeb2b(k)=nnok2b+1
         else
            goto 31
         endif
      enddo
 31   continue
      if(yw) then
         write(75,*)'kkdeb1a',(kkdeb1a(k),k=1,ndetca),'$'
         call scril
         write(75,*)'kkfin1a',(kkfin1a(k),k=1,ndetca),'$'
         call scril
         write(75,*)'kkdeb1b',(kkdeb1b(k),k=1,ndetcb),'$'
         call scril
         write(75,*)'kkfin1b',(kkfin1b(k),k=1,ndetcb),'$'
         call scril
         write(75,*)'kkdeb2a',(kkdeb2a(k),k=1,ndetca),'$'
         call scril
         write(75,*)'kkfin2a',(kkfin2a(k),k=1,ndetca),'$'
         call scril
         write(75,*)'kkdeb2b',(kkdeb2b(k),k=1,ndetcb),'$'
         call scril
         write(75,*)'kkfin2b',(kkfin2b(k),k=1,ndetcb),'$'
         call scril
      endif
c--   on remet les ioblig positifs
      do ity=1,3
         do i=1,noblig1a(ity)
            ioblig1a(i,ity)=iabs(ioblig1a(i,ity))
         enddo
      enddo
      do ity=1,3
         do i=1,noblig1b(ity)
            ioblig1b(i,ity)=iabs(ioblig1b(i,ity))
         enddo
      enddo
      do ity=1,3
         do i=1,noblig2a(ity)
            ioblig2a(i,ity)=iabs(ioblig2a(i,ity))
         enddo
      enddo
      do ity=1,3
         do i=1,noblig2b(ity)
            ioblig2b(i,ity)=iabs(ioblig2b(i,ity))
         enddo
      enddo
c--   coupures
      call cd07r(ndetca,ndetcb,noac,
     *ksgnca,ksgncb,ncoupa,ncoupb,icoupa,icoupb,jsgnca0,jsgncb0
     *,yimpca,yimpcb,impca,impcb)
      call cd03r(a,esp1,ibon1,ibon2,
     *jbon1,jbon2,jbonc1,jbonc2,isgntp,ysgntp,ysgnc)
      if(ystc.and.ystit1) then
         jnb(jint)=jnb1
c        print*,'calc jnb   jint,jnb',jint,jnb1
      endif
      return
      end
       subroutine cd07r(ndetca,ndetcb,noac,
     *ksgnca,ksgncb,ncoupa,ncoupb,icoupa,icoupb,jsgnca0,jsgncb0
     *,yimpca,yimpcb,impca,impcb)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16)
      parameter (idirac2=6000)
      dimension
     *ksgnca(idirac2),ksgncb(idirac2)
      dimension icoupa(4),icoupb(4)
     *,yimpca(maxorbcas,idirac2),yimpcb(maxorbcas,idirac2)
      character*1 impca(maxorbcas,idirac2),impcb(maxorbcas,idirac2)
      common /compt2/ icompt(20)
      common/yr/ywr
      yw1=.false.
      yw=.false..or.ywr
c
c--   signe
c
c---------------
c     le determinant de CAS est divise en tranches separees par les indi
c     l'integrale
c     il peut y avoir jusqu'a 5 tranches de signes alternes
c     pour chaque det kk1a, yimpc donne la parite du nombre d'electrons
c     a gauche de la coupure
c     1ere tranche : negative si jsgnca0=-1 ; si nb d'el impair   signe
c     tranches du milieu : negatives si jsgnca1=-1 ; parite obtenue par
c     comparaison entre la gauche de la coupure et la gauche de la coupu
c     precedente
c     derniere tranche  idem en considerant la derniere coupure a noac
c---------------
c
      do kk1a=1,ndetca
         jsgnca1=jsgnca0
c        1ere tranche
         jsgnca=1
         if(ncoupa.eq.0) then
            if(jsgnca0.eq.-1
     *      .and.yimpca(noac,kk1a)) jsgnca=-1
            if(yw)print*,'1 tranche1 jsgnca',jsgnca
         else
            if(jsgnca0.eq.-1.and.icoupa(1).ne.1
     *      .and.yimpca(icoupa(1)-1,kk1a)) jsgnca=-1
            if(yw)print*,'2 tranche1 jsgnca',jsgnca
         endif
c        autres tranches
         do l=2,ncoupa
            jsgnca1=-jsgnca1
c            print*,'ncoupa,(icoupa(kk),kk=1,ncoupa)',
c     *      ncoupa,(icoupa(kk),kk=1,ncoupa)
            if(icoupa(l).eq.icoupa(l-1)) then
c              jsgnca1=-jsgnca1
               if(yw)print*,'1 tranche2 jsgnca',jsgnca
               if(yw)print*,'1 tranche2 jsgnca1',jsgnca1
            else
               if(jsgnca1.eq.-1.and.
     *         (impca(icoupa(l)-1,kk1a).ne.
     *         impca(icoupa(l-1),kk1a))) jsgnca=-jsgnca
               if(yw)print*,'2 tranche2 jsgnca',jsgnca
            endif
         enddo
c        derniere tranche
         if(ncoupa.gt.0) then
            if(jsgnca1.eq.1) then
               if(impca(noac,kk1a).ne.
     *         impca(icoupa(ncoupa),kk1a)) jsgnca=-jsgnca
               if(yw)print*,'tranche3 jsgnca',jsgnca
            endif
         endif
         ksgnca(kk1a)=jsgnca
         if(yw)print*,'kk1a,ksgnca',kk1a,ksgnca(kk1a)
      enddo
      do kk1b=1,ndetcb
         jsgncb1=jsgncb0
c        1ere tranche
         jsgncb=1
         if(ncoupb.eq.0) then
            if(jsgncb0.eq.-1
     *      .and.yimpcb(noac,kk1b)) jsgncb=-1
            if(yw)print*,'1 tranche1 jsgnca',jsgnca
         else
            if(jsgncb0.eq.-1.and.icoupb(1).ne.1
     *      .and.yimpcb(icoupb(1)-1,kk1b)) jsgncb=-1
         endif
         if(yw)print*,'2 tranche1 jsgnca',jsgnca
c        autres tranches
         do l=2,ncoupb
            jsgncb1=-jsgncb1
c            print*,'ncoupa,(icoupa(kk),kk=1,ncoupa)',
c     *      ncoupa,(icoupa(kk),kk=1,ncoupa)
            if(icoupb(l).eq.icoupb(l-1)) then
c              jsgncb1=-jsgncb1
            else
               if(jsgncb1.eq.-1.and.
     *         (impcb(icoupb(l)-1,kk1b).ne.
     *         impcb(icoupb(l-1),kk1b))) jsgncb=-jsgncb
            endif
         enddo
c        derniere tranche
         if(ncoupb.gt.0) then
            if(jsgncb1.eq.1) then
               if(impcb(noac,kk1b).ne.
     *         impcb(icoupb(ncoupb),kk1b)) jsgncb=-jsgncb
            endif
         endif
         ksgncb(kk1b)=jsgncb
      enddo
      return
      end
       subroutine cd03r(a,esp1,ibon1,ibon2,
     *jbon1,jbon2,jbonc1,jbonc2,isgntp,
     *ysgntp,ysgnc)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(idiracr=160000,maxorbcas=16,idirap=maxorb*maxorb)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |             esp1              |
c
c
c-------------------------------------------------------------
c     on demarre les boucles
c
c     les det sont ecrits en OCCUPATION. Les trous sont a changer
c     de cote pour ecrire en T/P
c-------------------------------------------------------------
c
      common/dim/iadri ; integer(8) iadri
      dimension esp1(iadri*2)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /icd1/ispin(2)
      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/obin/noblig1(3),noblig2(3),ioblig1(2,3),ioblig2(2,3)
     *,ioblig1a(2,3),ioblig1b(2,3),ioblig2a(2,3),ioblig2b(2,3)
     *,noblig1a(3),noblig2a(3)
     *,noblig1b(3),noblig2b(3),icoma,icomb
      common/cas_spin/isz0
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common/mr4/ niit1,niit2,np123(idirap)
      common/r1/ nt1a,nt1b,np1a,np1b,nt2a,nt2b,np2a,np2b
     *,nelc1a,nelc1b,nelc2a,nelc2b
     *,nt1,nt2,np1,np2,nelc1,ispc1_1,nelc2,ispc1_2
     *,ist1,ist2,isc1,isc2,isp1,isp2,ispt1_1,ispt1_2,ispp1_1,ispp1_2,
     *ispt_1,ispt_2,ispp_1,ispp_2
      dimension ibon1(maxorb*maxorb),ibon2(maxorb*maxorb)
      integer*2 jbon1(maxorb*maxorb),jbon2(maxorb*maxorb)
      integer*2 jbonc1(idiracr),jbonc2(idiracr)
      dimension ysgntp(maxorb*maxorb)
     *,ysgnc(idiracr)
      dimension isgntp(maxorb*maxorb)
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      common/opt/ihab,calcul
      character*3 calcul
      common/yr/ywr
      yw1=.false.
      yw=.false..or.ywr
c
c--   calculs preliminaires
c
c-----------------------------------
c     boucles sur les symetries
c-----------------------------------
c
      do 1 isc=1,nsym
c     isc est la symetrie sans les obligatoires
c     isc1 et isc2 sont les sym des C des det 1 et 2
      isc1=isc
      do k=1,noblig1(2)
         iob=ioblig1(k,2)
         if(iob.gt.noac) iob=iob-noac
         iob=numac(iob)
         isc1=its(isc1,itsym(iob))
      enddo
      isc2=isc
      do k=1,noblig2(2)
         iob=ioblig2(k,2)
         if(iob.gt.noac) iob=iob-noac
         iob=numac(iob)
         if(yw)print*,'isc2,iob',isc2,iob
         if(yw)print*,itsym(iob)
         isc2=its(isc2,itsym(iob))
      enddo
      do 2 ist=1,nsym
c     ist est la symetrie sans les obligatoires
c     ist1 et ist2 sont les sym des t des det 1 et 2
c     isp1 et isp2 sont les sym des p des det 1 et 2
      ist1=ist
      do k=1,noblig1(1)
         ist1=its(ist1,itsym(ioblig1(k,1)))
      enddo
      ist2=ist
      do k=1,noblig2(1)
         ist2=its(ist2,itsym(ioblig2(k,1)))
      enddo
      isp1=its(its(isc1,ist1),is0)
      isp2=its(its(isc2,ist2),is0)
      if(yw)write(6,'(a35,3i3,2x,3i3)')'isc1,ist1,isp1,isc2,ist2,isp2',
     *isc1,ist1,isp1,isc2,ist2,isp2
c
c-------------------------------------------
c     boucles sur les nombres d'electrons
c-------------------------------------------
c
      do 3 nelc1a=-2,2
      nelcas1a=nca0+nelc1a
      if(nelcas1a.gt.noac-noblig2a(2)+icoma) goto 3
      if(nelcas1a.lt.noblig1a(2)) goto 3
c
      nelc2a=nelc1a+noblig2a(2)-noblig1a(2)
      nelcas2a=nca0+nelc2a
      if(nelcas2a.lt.noblig2a(2)) goto 3
      if(nelcas2a.gt.noac-noblig1a(2)+icoma) goto 3
c
      if(nelc2a.gt.2.or.nelc2a.lt.-2) goto 3
c
      ideb4=max0(-2,-2-nelc1a)
      ifin4=min(2,2-nelc1a)
      if(yw)print*,'ideb4,ifin4',ideb4,ifin4
      do 4 nelc1b=ideb4,ifin4
      if(yw)print*,'nelc1b',nelc1b
      nelcas1b=ncb0+nelc1b
      if(nelcas1b.lt.noblig1b(2)) goto 4
      if(yw)print*,'coucou1',nelcas1b,noac,noblig1b(2),ncb0
      if(nelcas1b.gt.noac-noblig2b(2)+icomb) goto 4
      if(yw)print*,'coucou2'
c
      nelc1=nelc1a+nelc1b
c
      nelc2b=nelc1b+noblig2b(2)-noblig1b(2)
      nelcas2b=ncb0+nelc2b
      if(nelcas2b.lt.noblig2b(2)) goto 4
      if(yw)print*,'coucou3 nelc2a,nelc2b',nelc2a,nelc2b
      if(nelcas2b.gt.noac-noblig1b(2)+icomb) goto 4
      if(yw)print*,'coucou4'
c
      if(nelc2b.gt.2.or.nelc2b.lt.-2) goto 4
c
      nelc2=nelc2a+nelc2b
      if(nelc2.gt.2.or.nelc2.lt.-2) goto 4
      if(yw)print*,'coucou5'
c
      if(yw)print*,'isz0',isz0
      ispc_1=nelcas1a-nelcas1b-isz0
      ispc_2=nelcas2a-nelcas2b-isz0
      if(yw) then
         write(6,'(a58,4i3,2x,4i3)')
     *   'nelc1a,nelc1b,nelc2a,nelc2b,ispc_1,ispc_2,ispc1_1,ispc1_2',
     *   nelc1a,nelc1b,nelc2a,nelc2b,ispc_1,ispc_2,ispc1_1,ispc1_2
      endif
      ispc1_1=ksp(ispc_1)
      ispc1_2=ksp(ispc_2)
c
      if(yw) then
         write(6,'(a58,4i3,2x,4i3)')
     *   'nelc1a,nelc1b,nelc2a,nelc2b,ispc_1,ispc_2,ispc1_1,ispc1_2',
     *   nelc1a,nelc1b,nelc2a,nelc2b,ispc_1,ispc_2,ispc1_1,ispc1_2
         write(6,'(a32,6i3)')'isc1,isc2,ist1,ist2,isp1,isp2',
     *   isc1,isc2,ist1,ist2,isp1,isp2
      endif
c--
c      do 5 nt1a=noblig1a(1),2-noblig2a(1)
      do 5 nt1a=noblig1a(1),2
      np1a=nt1a-nelc1a
      if(yw)print*,'nt1a,np1a',nt1a,np1a
      if(np1a.lt.noblig1a(3)) goto 5
      if(yw)print*,'coucoup0'
c      if(np1a.gt.2-noblig2a(3)) goto 5
      if(np1a.gt.2) goto 5
      if(yw)print*,'coucoup1'
c
      nt2a=nt1a+noblig2a(1)-noblig1a(1)
      if(yw)print*,'nt2a',nt2a
      if(nt2a.lt.noblig2a(1)) goto 5
      if(yw)print*,'coucoup2'
c      if(nt2a.gt.2-noblig1a(1)) goto 5
      if(nt2a.gt.2) goto 5
      if(yw)print*,'coucoup3'
c
      np2a=nt2a-nelc2a
      if(yw)print*,'nt2a,np2a',nt2a,np2a
      if(np2a.lt.noblig2a(3)) goto 5
      if(yw)print*,'coucoup4'
c      if(np2a.gt.2-noblig1a(3)) goto 5
      if(np2a.gt.2) goto 5
      if(yw)print*,'coucoup5'
c
      ideb6=noblig1b(1)
      ifin6=(2-nt1a)
      if(yw)print*,'ideb6,ifin6,nt1a',ideb6,ifin6,nt1a
      do 6 nt1b=ideb6,ifin6
      np1b=nt1b-nelc1b
      if(yw)print*,'nt1b,np1b,nelc1b',nt1b,np1b,nelc1b
      if(np1b.lt.noblig1b(3)) goto 6
      if(yw)print*,'coucoup6'
c      if(np1b.gt.2-noblig2b(3)) goto 6
      if(np1b.gt.2) goto 6
      if(yw)print*,'coucoup7'
c
      nt2b=nt1b+noblig2b(1)-noblig1b(1)
      if(nt2b.lt.noblig2b(1)) goto 6
      if(nt2b.gt.2) goto 6
      if(yw)print*,'coucoup8'
c      if(nt2b.gt.2-noblig1b(1)) goto 6
      if(yw)print*,'coucoup9'
      nt1=nt1a+nt1b
c
      nt2=nt2a+nt2b
      if(nt2.lt.noblig2(1)) goto 6
      if(yw)print*,'coucoup0'
      if(nt2.gt.2) goto 6
      if(yw)print*,'coucoup1'
c
      np2b=nt2b-nelc2b
      if(yw)print*,'nt2b,np2b',nt2b,np2b
      if(np2b.lt.noblig2b(3)) goto 6
      if(yw)print*,'coucoup2'
c      if(np2b.gt.2-noblig1b(3)) goto 6
      if(np2b.gt.2) goto 6
c
      np1=np1a+np1b
      if(yw)print*,'coucoup3',np1,noblig1(3)
      if(np1.lt.noblig1(3)) goto 6
      if(yw)print*,'coucoup1'
      if(np1.gt.2) goto 6
      if(yw)print*,'coucoup4'
      np2=np2a+np2b
      if(np2.lt.noblig2(3)) goto 6
      if(yw)print*,'coucoup5'
      if(np2.gt.2) goto 6
      if(yw)print*,'coucoup6'
      if(gener.eq.'TOUS') then
      else if(gener.eq.'PERT')then
         if(nt1.eq.2.and.np1.eq.2.and.
     *   (nelc1a.ne.0.or.nelc1b.ne.0.or.isc1.ne.is0)) goto 6
         if(nt2.eq.2.and.np2.eq.2.and.
     *   (nelc2a.ne.0.or.nelc2b.ne.0.or.isc2.ne.is0)) goto 6
         if(iabs(ispc_1).gt.2) goto 6
         if(iabs(ispc_2).gt.2) goto 6
      else if(gener.eq.'DDCI')then
         if(nt1.eq.2.and.np1.eq.2) goto 6
         if(nt2.eq.2.and.np2.eq.2) goto 6
      else if(gener.eq.'DDC2')then
         if(nt1+np1.gt.2) goto 6
         if(nt2+np2.gt.2) goto 6
c        if(iabs(ispc_1).gt.2) goto 6
c        if(iabs(ispc_2).gt.2) goto 6
      else if(ygmono)then
         if(nt1.eq.2.or.np1.eq.2) goto 6
         if(nt2.eq.2.or.np2.eq.2) goto 6
c        if(iabs(ispc_1).gt.2) goto 6
c        if(iabs(ispc_2).gt.2) goto 6
      else if(gener.eq.'CAS')then
         if(nt1.gt.0.or.np1.gt.0) goto 6
         if(nt2.gt.0.or.np2.gt.0) goto 6
      endif
      if(yw) then
         write(6,'(a41,4i3,2x,4i3)')
     *   'nt1a,nt1b,nt2a,nt2b,np1a,np1b,np2a,np2b',
     *   nt1a,nt1b,nt2a,nt2b,np1a,np1b,np2a,np2b
      endif
c
c
c---------------------------------------------
c     debut du calcul de l'adresse
c---------------------------------------------
c
      ispt_1=nt1a-nt1b
      ispt_2=nt2a-nt2b
      ispp_1=np1a-np1b
      ispp_2=np2a-np2b
      ispt1_1=(ispt_1)
      if(nt1.eq.2) ispt1_1=ispt1_1/nt1
      ispt1_2=(ispt_2)
      if(nt2.eq.2) ispt1_2=ispt1_2/nt2
      ispp1_1=(ispp_1)
      if(np1.eq.2) ispp1_1=ispp1_1/np1
      ispp1_2=(ispp_2)
      if(np2.eq.2) ispp1_2=ispp1_2/np2
c
      if(yw) then
         print*,'nelc1,isc1,ispc1_1,nt1,ist1,ispt1_1'
         print*,nelc1,isc1,ispc1_1,nt1,ist1,ispt1_1
         print*,'nelc2,isc2,ispc1_2,nt2,ist2,ispt1_2'
         print*,nelc2,isc2,ispc1_2,nt2,ist2,ispt1_2
         print*,'niit',niit(nt1,ist1,ispt1_1),niit(nt2,ist2,ispt1_2)
      endif
      niit1=niit(nt1,ist1,ispt1_1)
      niit2=niit(nt2,ist2,ispt1_2)
      if(niit1.eq.-10.or.niit2.eq.-10) goto 6
      iadr1=icateg(nelc1,isc1,ispc1_1,niit1)
      iadr2=icateg(nelc2,isc2,ispc1_2,niit2)
      ispt1_1=iabs(ispt1_1)
      ispt1_2=iabs(ispt1_2)
      ispp1_1=iabs(ispp1_1)
      ispp1_2=iabs(ispp1_2)
      if(yw) then
         print*,'iadr1,iadr2',iadr1,iadr2
      endif
c
      call cd04r(a,esp1,
     *ibon1,ibon2,ibon1(ninac*ninac+2),ibon2(ninac*ninac+2),
     *jbon1,jbon2,jbon1(ninac*ninac+2),jbon2(ninac*ninac+2),
     *jbonc1,jbonc2,
     *iadr1,iadr2,isgntp,isgntp(ninac*ninac+2),
     *ysgntp,ysgntp(ninac*ninac+2),ysgnc)
 6    continue
 5    continue
 4    continue
 3    continue
 2    continue
 1    continue
      return
      end
       subroutine cd04r(a,esp1,
     *ibont1,ibont2,ibonp1,ibonp2,
     *jbont1,jbont2,jbonp1,jbonp2,
     *jbonc1,jbonc2,
     *iadr1,iadr2,isgnt,isgnp,
     *ysgnt,ysgnp,ysgnc)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |             esp1              |
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,idiracr=160000,idicmr=35000)
      include 'maxorb.prm'
      parameter (idirac2=6000)
      parameter(maxorbcas=16,idirap=maxorb*maxorb,maxdetc=12870)
      common/dim/iadri ; integer(8) iadri
      dimension esp1(iadri*2)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common /icd1/ispin(2)
      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/obin/noblig1(3),noblig2(3),ioblig1(2,3),ioblig2(2,3)
     *,ioblig1a(2,3),ioblig1b(2,3),ioblig2a(2,3),ioblig2b(2,3)
     *,noblig1a(3),noblig2a(3)
     *,noblig1b(3),noblig2b(3),icoma,icomb
      common/cas_spin/isz0
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/mr4/ niit1,niit2,np123(idirap)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common/sy4/ntstot(0:maxsym),ncstot(0:maxsym),npstot(0:maxsym)
      dimension ibont1(ninac*ninac+1),ibont2(ninac*ninac+1)
     *,ibonp1(nvirt*nvirt+1),ibonp2(nvirt*nvirt+1)
      dimension ibonc1(idiracr),ibonc2(idiracr),isgnc(idiracr)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      common /adrsym/irangs(maxdetc,0:maxorbcas)
     *,maxs(maxsym,0:maxorbcas)
      common/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      common/r1/ nt1a,nt1b,np1a,np1b,nt2a,nt2b,np2a,np2b
     *,nelc1a,nelc1b,nelc2a,nelc2b
     *,nt1,nt2,np1,np2,nelc1,ispc1_1,nelc2,ispc1_2
     *,ist1,ist2,isc1,isc2,isp1,isp2,ispt1_1,ispt1_2,ispp1_1,ispp1_2,
     *ispt_1,ispt_2,ispp_1,ispp_2
      common /cr/ mxstra(0:maxorbcas),mxstrb(maxsym,0:maxorbcas)
     *,nxstra(0:maxorbcas),nxstrb(maxsym,0:maxorbcas)
     *,kadra(idirac2),kadrb(idirac2),ksymca(idirac2)
     *,kok1a(idirac2),kok2a(idirac2),kok1b(idirac2),kok2b(idirac2)
     *,kkdeb1a(idirac2),kkdeb2a(idirac2)
     *,kkdeb1b(idirac2),kkdeb2b(idirac2)
     *,kkfin1a(idirac2),kkfin2a(idirac2)
     *,kkfin1b(idirac2),kkfin2b(idirac2)
     *,nnok1a,nnok1b,nnok2a,nnok2b,ndetca,ndetcb
     *,ksgnca(idirac2),ksgncb(idirac2)
     *,yimpca(maxorbcas,idirac2),yimpcb(maxorbcas,idirac2)
     *,ydetca(maxorbcas,idirac2),ydetcb(maxorbcas,idirac2)
c     *,yok1a(idirac2),yok2a(idirac2),yok1b(idirac2),yok2b(idirac2)
      common /co_max/ maxtt(2,maxsym,0:1),maxpp(0:2,maxsym,0:1)
      common /sgnr/ isgnr(maxorb*2),isgnr0
      dimension isgnt(ninac*ninac),isgnp(nvirt*nvirt)
      common /ctg_mr/icateg_mr(idicmr,41)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      integer*2 jbont1(ninac*ninac+1),jbont2(ninac*ninac+1),
     *jbonp1(nvirt*nvirt+1),jbonp2(nvirt*nvirt+1)
      integer*2 jbonc1(idiracr),jbonc2(idiracr)
      dimension ysgnt(ninac*ninac+1),ysgnp(nvirt*nvirt+1)
     *,ysgnc(idiracr)
      common/yr/ywr
      yw1=.false.
      yw=.false..or.ywr
c
c--------------------------------------------------------
c     recherche des indices variables
c     les indices variables sont ceux qui, une fois places
c     les obligatoires, peuvent prendre des valeurs differentes
c     pour former les couples de determinants
c
c     ibont1 et ibont2 contiennent la liste des determinants autorises
c     parmi les trous
c     idem pour les part et les actives
c--------------------------------------------------------
c
c
c     trous variables
c
      if(yw)print*,'***trous variables***'
      call cd05r(1,nbont,ibont1,ibont2,nt1,nt1a,nt1b,nt2,nt2a,nt2b,
     *ninac,numina,ist1,ist2,icatt,
     *nts,ntstot,itorb,iorb,ispt_1,ispt_2,isgnt,norb,0)
      if(yw)print*,'nbont',nbont
      if(nbont.eq.0) return
c
c     actives variables
c
      if(yw)print*,'***actives variables***'
      nbonc=0
      nbonc2=0
      nc1a=nelc1a+nca0
      nc1b=nelc1b+ncb0
      nc2a=nelc2a+nca0
      nc2b=nelc2b+ncb0
      jj1=maxc(nelc1,isc1,ispc1_1)
      jj2=maxc(nelc2,isc2,ispc1_2)
      if(yw)write(6,'(a20,12i4)')'nc1a,nc1b,nc2a,nc2b',
     *nc1a,nc1b,nc2a,nc2b,nelc1a,nelc1b,nelc2a,nelc2b,nca0,ncb0
c     Determinant 1
c
      ii1a=mxstra(nc1a)
      jj1a=nxstra(nc1a)
      if(yw)write(6,'(a20,4i4)')'ii1a,jj1a',
     *ii1a,jj1a
c     boucle sur les strings alpha corrects
      if(jj1a.eq.0) goto 3
      if(yw)print*,'kkdeb1a(ii1a+1),kkfin1a(ii1a+jj1a)',
     *kkdeb1a(ii1a+1),kkfin1a(ii1a+jj1a)
      do kk1a0=kkdeb1a(ii1a+1),kkfin1a(ii1a+jj1a)
         kk1a=kok1a(kk1a0)
         jsc1a=ksymca(kk1a)
         jsc1b=its(jsc1a,isc1)
         iadra=kadra(kk1a)
c        boucle sur les strings beta corrects
         ii1b=mxstrb(jsc1b,nc1b)
         jj1b=nxstrb(jsc1b,nc1b)
c      print*,'jsc1b,nc1b,ii1b',jsc1b,nc1b,ii1b
         iii=iadra+icatc(isc1,jsc1a,nc1a,nc1b)
         max_s=maxs(jsc1a,nc1a)
         if(yw)write(6,'(a20,4i4)')'ii1b,jj1b',
     *   ii1b,jj1b
         if(yw)print*,'kkdeb1b(ii1b+1),kkfin1b(ii1b+jj1b)',
     *   kkdeb1b(ii1b+1),kkfin1b(ii1b+jj1b)
c        boucle sur les strings beta corrects
         if(jj1b.eq.0) goto 2
         do kk1b0=kkdeb1b(ii1b+1),kkfin1b(ii1b+jj1b)
c     print*,'kk1b0',kk1b0
            kk1b=kok1b(kk1b0)
            iadrb=kadrb(kk1b)
            iadrcas=iii+(iadrb-1)*max_s
            nbonc=nbonc+1
            call verdim('depassement augmenter idiracr     ',
     *      nbonc,idiracr)
            ibonc1(nbonc)=iadrcas
            if(yw)write(6,*)'nbonc,iadrcas',nbonc,iadrcas
c            isgnc(nbonc)=jsgnca*jsgncb
 1          continue
         enddo
 2       continue
      enddo
 3    continue
c...  attention cette ligne supprime le test d'erreur nbonc.eq.nbonc2
      if(nbonc.eq.0) return
c
c     Determinant 2
c
      ii2a=mxstra(nc2a)
      jj2a=nxstra(nc2a)
      if(yw)write(6,'(a20,4i4)')'ii2a,jj2a',
     *ii2a,jj2a
c     boucle sur les strings alpha corrects
      if(jj2a.eq.0) goto 6
      if(yw)print*,'kkdeb2a(ii2a+1),kkfin2a(ii2a+jj2a)',
     *kkdeb2a(ii2a+1),kkfin2a(ii2a+jj2a)
      do kk2a0=kkdeb2a(ii2a+1),kkfin2a(ii2a+jj2a)
         kk2a=kok2a(kk2a0)
         jsc2a=ksymca(kk2a)
         jsc2b=its(jsc2a,isc2)
         iadra=kadra(kk2a)
         jsgnca=ksgnca(kk2a)
         if(yw)print*,'kk2a,jsgnca',kk2a,jsgnca
c        boucle sur les strings beta corrects
         ii2b=mxstrb(jsc2b,nc2b)
         jj2b=nxstrb(jsc2b,nc2b)
         if(yw)write(6,'(a20,4i4)')'ii2b,jj2b',
     *   ii2b,jj2b
         iii=iadra+icatc(isc2,jsc2a,nc2a,nc2b)
         max_s=maxs(jsc2a,nc2a)
         if(jj2b.eq.0) goto 5
         if(yw)print*,'kkdeb2b(ii2b+1),kkfin2b(ii2b+jj2b)',
     *   kkdeb2b(ii2b+1),kkfin2b(ii2b+jj2b)
         do kk2b0=kkdeb2b(ii2b+1),kkfin2b(ii2b+jj2b)
            kk2b=kok2b(kk2b0)
            iadrb=kadrb(kk2b)
            iadrcas=iii+(iadrb-1)*max_s
            jsgncb=ksgncb(kk2b)
            nbonc2=nbonc2+1
            call verdim('depassement(2) augmenter idiracr  ',
     *      nbonc2,idiracr)
            if(yw)write(6,*)'nbonc2,iadrcas',nbonc2,iadrcas
            if(yw)write(6,*)'jsgnca,jsgncb',jsgnca,jsgncb
            ibonc2(nbonc2)=iadrcas
            isgnc(nbonc2)=jsgnca*jsgncb
 4          continue
         enddo
 5       continue
      enddo
 6    continue
      if(yw)print*,'ibonc1',(ibonc1(k),k=1,nbonc)
      if(yw)print*,'ibonc2',(ibonc2(k),k=1,nbonc2)
      if(nbonc.ne.nbonc2)stop 'nbonc,nbonc2'
c
c--   on revise les det du CAS pour retirer les couples elimines
c
c     particules variables
c
      if(yw)print*,'***particules variables***',nvirt
      call cd05r(3,nbonp,ibonp1,ibonp2,np1,np1a,np1b,np2,np2a,np2b,
     *nvirt,numvir,isp1,isp2,icatp,
     *nps,npstot,itorb,iorb,ispp_1,ispp_2,isgnp,norb,ninac+noac)
      if(yw)print*,'nbonp',nbonp
      if(nbonp.eq.0) return
c
c     appel a la boucle interne
c
      if(yw)print*,'np1,isp1,ispp1_1', np1,isp1,ispp1_1
      if(yw)print*,'np2,isp2,ispp1_2',np2,isp2,ispp1_2
      if(yw)print*,'iadri1',iadri1
c       if(yw)print*,'av cd06r esp1(nmulr+59)',esp1(nmulr+59)
      call cd06r(nbont,nbonc,nbonp,ibont1,ibont2,ibonc1,ibonc2,
     *ibonp1,ibonp2,jj1,jj2,
     *jj1*maxpp(np1,isp1,ispp1_1),jj2*maxpp(np2,isp2,ispp1_2)
     *,a,iadr1,iadr2,isgnt,isgnp,isgnc,esp1,esp1(iadri1),
     *jbont1,jbont2,jbonc1,jbonc2,jbonp1,jbonp2,
     *ysgnt,ysgnp,ysgnc)
c       if(yw)print*,'ap cd06r esp1(nmulr+59)',esp1(nmulr+59)
      return
      end
       subroutine cd06r(nbont,nbonc,nbonp,ibont1,ibont2,ibonc1,ibonc2,
     *ibonp1,ibonp2,maxc1,maxc2,
     *maxpc1,maxpc2,
     *a,iadr1,iadr2,isgnt,isgnp,isgnc,b,ab
     *,jbont1,jbont2,jbonc1,jbonc2,jbonp1,jbonp2,
     *ysgnt,ysgnp,ysgnc)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |      ab       |
c
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,idiracr=160000,idicmr=35000,maxda3=300)
      include 'maxorb.prm'
      parameter(maxorbcas=16,idirap=maxorb*maxorb)
      common/dim/iadri ; integer(8) iadri
      dimension ibont1(ninac*ninac+1),ibont2(ninac*ninac+1),
     *ibonp1(nvirt*nvirt+1),ibonp2(nvirt*nvirt+1)
      dimension ibonc1(idiracr),ibonc2(idiracr)
      integer*2 jbont1(ninac*ninac+1),jbont2(ninac*ninac+1),
     *jbonp1(nvirt*nvirt+1),jbonp2(nvirt*nvirt+1)
     *,jbont,jbonp,jbonc
      integer*2 jbonc1(idiracr),jbonc2(idiracr)
      dimension b(*),ab(*)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /sgnr/ isgnr(maxorb*2),isgnr0
      dimension isgnt(ninac*ninac+1),isgnp(nvirt*nvirt+1),isgnc(idiracr)
      common/opt/ihab,calcul
      character*3 calcul
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/yr/ywr
      common /compt2/ icompt(20)
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      dimension ysgnt(ninac*ninac+1),ysgnp(nvirt*nvirt+1),
     *ysgnc(idiracr)
c
c-----------------------------------------------------------
c     boucle interne
c
c     formule de la'adressage :
c         iadrcat=iadrc+
c     *   maxc(nelc,iscas,ispc1)*((iadrt-1)*max_p+iadrp-1)
c         iadr=iadrcat+icateg(nelc,iscas,ispc1,niit(nt,ist,ispt1))
c     =iadrc+
c      maxc*(iadrp-1)+
c      maxc*max_p*(iadrt-1)
c-----------------------------------------------------------
c
      yw=.false..or.ywr
      irest=itest(1)
c     if(iter.gt.1) then
c        write(75,*)'&&&& a',a,'$'
c        call scril
c        write(75,*)'&&&& iter,iadr1,iadr2,maxc1,maxc2,maxpc1,maxpc2',
c     *   iter,iadr1,iadr2,maxc1,maxc2,maxpc1,maxpc2,'$'
c        call scril
c        write(75,*)'&&&& nbont,nbonc,nbonp,isgnr0',
c     *   nbont,nbonc,nbonp,isgnr0,'$'
c        call scril
c        write(75,*)'&&&& ibont1',(ibont1(k),k=1,nbont),'$'
c        call scril
c        write(75,*)'&&&& ibont2',(ibont2(k),k=1,nbont),'$'
c        call scril
c        write(75,*)'&&&& ibonc1',(ibonc1(k),k=1,nbonc),'$'
c        call scril
c        write(75,*)'&&&& ibonc2',(ibonc2(k),k=1,nbonc),'$'
c        call scril
c        write(75,*)'&&&& ibonp1',(ibonp1(k),k=1,nbonp),'$'
c        call scril
c        write(75,*)'&&&& ibonp2',(ibonp2(k),k=1,nbonp),'$'
c        call scril
c        write(75,*)'&&&& isgnt',(isgnt(k),k=1,nbont),'$'
c        call scril
c        write(75,*)'&&&& isgnc',(isgnc(k),k=1,nbonc),'$'
c        call scril
c        write(75,*)'&&&& isgnp',(isgnp(k),k=1,nbonp),'$'
c        call scril
c     endif
      if(yw) then
         print*,'iadr1,iadr2',iadr1,iadr2
         print*,'maxc1,maxc2',maxc1,maxc2
         print*,'maxpc1,maxpc2',maxpc1,maxpc2
      endif
      if(ystit1.and.ystc.and.irest.ne.3.and.irest.ne.1) then
         lonstc=lonstc+(nbont+nbonp+nbonc)*5+31
         if(lonstc.gt.maxstc*1000000) then
            print*,'cd02r lonstc,maxstc',lonstc,maxstc
            ystc=.false.
            jnb(jint)=-1
            goto 555
         endif
c        valeurs de jlim et jmax imposees par le fait que ibon* est
c        en integer*2
         jlim=32768
         jmax=65536
         do k=1,nbont
            call verdim('depassement   ibont1     jmax     ',
     *      ibont1(k),jmax)
            jbont1(k)=ibont1(k)-jlim
            ysgnt(k)=isgnt(k).eq.1
            call verdim('depassement   ibont2     jmax     ',
     *      ibont2(k),jmax)
            jbont2(k)=ibont2(k)-jlim
         enddo
         do k=1,nbonp
            call verdim('depassement   ibonp1     jmax     ',
     *      ibonp1(k),jmax)
            jbonp1(k)=ibonp1(k)-jlim
            ysgnp(k)=isgnp(k).eq.1
            call verdim('depassement   ibonp2     jmax     ',
     *      ibonp2(k),jmax)
            jbonp2(k)=ibonp2(k)-jlim
         enddo
         do k=1,nbonc
            call verdim('depassement   ibonc1     jmax     ',
     *      ibonc1(k),jmax)
            jbonc1(k)=ibonc1(k)-jlim
            ysgnc(k)=isgnc(k).eq.1
            call verdim('depassement   ibonc2     jmax     ',
     *      ibonc2(k),jmax)
            jbonc2(k)=ibonc2(k)-jlim
         enddo
         jbont=nbont
         jbonp=nbonp
         jbonc=nbonc
         ysgnr0=isgnr0.eq.1
         jnb1=jnb1+1
         write(78)iadr1,iadr2,jbont,jbonc,jbonp,
     *   (jbont1(k),k=1,nbont),(jbont2(k),k=1,nbont),
     *   (jbonp1(k),k=1,nbonp),(jbonp2(k),k=1,nbonp),
     *   (jbonc1(k),k=1,nbonc),(jbonc2(k),k=1,nbonc),
     *   maxpc1,maxpc2,maxc1,maxc2,
     *   ysgnr0,
     *   (ysgnt(k),k=1,nbont),
     *   (ysgnc(k),k=1,nbonc),
     *   (ysgnp(k),k=1,nbonp)
c        print*,'ecriture 78'
      endif
 555  continue
      do k=1,nbont
         ibont1(k)=(ibont1(k)-1)*maxpc1
         ibont2(k)=(ibont2(k)-1)*maxpc2
      enddo
      do k=1,nbonp
         ibonp1(k)=(ibonp1(k)-1)*maxc1
         ibonp2(k)=(ibonp2(k)-1)*maxc2
      enddo
      if(calcul.eq.'M') then
         do i=1,nbont
            iat1=iadr1+ibont1(i)
            iat2=iadr2+ibont2(i)
            jsgnt=isgnt(i)*isgnr0
            do j=1,nbonp
               iatp1=iat1+ibonp1(j)
               iatp2=iat2+ibonp2(j)
               jsgntp=jsgnt*isgnp(j)
               do k=1,nbonc
                  iatpc1=iatp1+ibonc1(k)
                  iatpc2=iatp2+ibonc2(k)
                  jsgntpc=jsgntp*isgnc(k)
                  if(yw)write(6,'(a30,10i4)')
     *            ' isgnr0,jsgnt,jsgntp,jsgntpc',
     *            isgnr0,jsgnt,jsgntp,jsgntpc
                  if(iabs(jsgntpc).ne.1) stop 'signe non +/-1'
                  call stover(iatpc1,iatpc2,a*jsgntpc)
                  if(yga2) call stoga2(iatpc1*jsgntpc,iatpc2,a,ab)
               enddo
            enddo
         enddo
      else
         if(itest(12).eq.0) then
            do i=1,nbont
               iat1=iadr1+ibont1(i)
               iat2=iadr2+ibont2(i)
               jsgnt=isgnt(i)*isgnr0
               do j=1,nbonp
                  iatp1=iat1+ibonp1(j)
                  iatp2=iat2+ibonp2(j)
                  jsgntp=jsgnt*isgnp(j)
                  do k=1,nbonc
                     iatpc1=iatp1+ibonc1(k)
                     iatpc2=iatp2+ibonc2(k)
                     jsgntpc=jsgntp*isgnc(k)
CIT17           if(itest(17).eq.iatpc1)write(6,'('' cd06r it17'',i5,2f12
CIT17        *   iatpc1,a,b(iatpc2)
CIT17           if(itest(17).eq.iatpc2)write(6,'('' cd06r it17'',i5,2f12
CIT17        *   iatpc1,a,b(iatpc1)
                     ab(iatpc1)=ab(iatpc1)+a*b(iatpc2)*jsgntpc
                     ab(iatpc2)=ab(iatpc2)+a*b(iatpc1)*jsgntpc
c      if(iatpc1.eq.1)write(6,'(a30,i4,2f12.8)')
c     *'iatpc2,b(iatpc2),ab(iatpc1)',
c     *iatpc2,b(iatpc2),ab(iatpc1)
c      if(iatpc2.eq.1)write(6,'(a30,i4,2f12.8)')
c     *'iatpc1,b(iatpc1),ab(iatpc2)',
c     *iatpc1,b(iatpc1),ab(iatpc2)
c      if(iatpc1.eq.1)write(6,*)'isgns,a',jsgntpc,a
c      if(iatpc2.eq.1)write(6,*)'isgns,a',jsgntpc,a
c                     if(iatpc1.eq.1)write(6,'(a15,2i5,3f12.8)')'iatpc1'
c     &               iatpc2,jsgntpc,
c     *               a,a*b(iatpc2)*jsgntpc,ab(iatpc1)
c                     if(iatpc2.eq.1)write(6,'(a15,2i5,3f12.8)')'iatpc2'
c     &               iatpc1,jsgntpc,
c     *               a,a*b(iatpc1)*jsgntpc,ab(iatpc2)
c                     icompt(2)=icompt(2)+1
                  enddo
               enddo
            enddo
         else
            do i=1,nbont
               iat1=iadr1+ibont1(i)
               iat2=iadr2+ibont2(i)
               jsgnt=isgnt(i)*isgnr0
               do j=1,nbonp
                  iatp1=iat1+ibonp1(j)
                  iatp2=iat2+ibonp2(j)
                  jsgntp=jsgnt*isgnp(j)
                  do k=1,nbonc
                     iatpc1=iatp1+ibonc1(k)
                     iatpc2=iatp2+ibonc2(k)
                     jsgntpc=jsgntp*isgnc(k)
                     aa=a*jsgntpc
                     ab(iatpc1)=ab(iatpc1)+aa*b(iatpc2)
                     ab(iatpc2)=ab(iatpc2)+aa*b(iatpc1)
c      if(iatpc1.eq.1)write(6,'(a30,i4,2f12.8)')
c     *'iatpc2,b(iatpc2),ab(iatpc1)',
c     *iatpc2,b(iatpc2),ab(iatpc1)
c      if(iatpc2.eq.1)write(6,'(a30,i4,2f12.8)')
c     *'iatpc1,b(iatpc1),ab(iatpc2)',
c     *iatpc1,b(iatpc1),ab(iatpc2)
c      if(iatpc1.eq.1)write(6,*)'isgns,a',jsgntpc,a
c      if(iatpc2.eq.1)write(6,*)'isgns,a',jsgntpc,a
                     do kk=1,icalc1-1
                        incr=kk*maxl0
                        jadr1=iatpc1+incr
                        jadr2=iatpc2+incr
CIT17           if(itest(17).eq.jadr1)write(6,'('' cd06r it17'',i5,2f12.
CIT17        *   jadr2,a,b(jadr2)
CIT17           if(itest(17).eq.jadr2)write(6,'('' cd06r it17'',i5,2f12.
CIT17        *   jadr1,a,b(jadr1)
                        ab(jadr1)=ab(jadr1)+aa*b(jadr2)
                        ab(jadr2)=ab(jadr2)+aa*b(jadr1)
c     if(jadr1.eq.90)print*,'jadr2,a,b',a*jsgntpc,b(jadr2),
c     * jadr2,a*jsgntpc,b(jadr2),a*b(jadr2)*jsgntpc ,ab(jadr1)
c     if(jadr2.eq.90)print*,'jadr1,a,b',
c     * jadr1,a*jsgntpc,b(jadr1),a*b(jadr1)*jsgntpc , ab(jadr2)
c     if(jadr1.eq.90)print*,'&&&&',jadr2,a*b(jadr2)*jsgntpc!,ab(jadr1)
c     if(jadr2.eq.90)print*,'&&&&',jadr1,a*b(jadr1)*jsgntpc!,ab(jadr2)
c                         if(yw)write(6,'(a15,3i5,3f12.8)')
c     *                  ' jadr',jadr1,jadr2,jsgntpc,
c     *                  a,a*b(jadr2)*jsgntpc,ab(jadr1)
c                        if(yw)print*,'1cdr06 ab(4473)',ab(4473)
c                        if(jadr1.eq.4473)write(6,'(a15,3i5,3f12.8)')
c     *                  ' jadr1',jadr1,jadr2,jsgntpc,
c     *                  a,a*b(jadr2)*jsgntpc,ab(jadr1)
c                        if(jadr2.eq.4473)write(6,'(a15,3i5,3f12.8)')
c     &                  ' jadr2',jadr2,jadr1,jsgntpc,
c     *                  a,a*b(jadr1)*jsgntpc,ab(jadr2)
c                         if(yw)print*,'cdr06 ab(4473)',ab(4473),nmulr
c                        if(jadr1.eq.8)write(6,'(a15,3i5,3f12.8)')
c     &                  ' jadr1',jadr1,jadr2,jsgntpc,
c     *                   a,a*b(jadr2)*jsgntpc,ab(jadr1)
c                        if(jadr2.eq.8)write(6,'(a15,3i5,3f12.8)')
c     &                  ' jadr2',jadr2,jadr1,jsgntpc,
c     *                   a,a*b(jadr1)*jsgntpc,ab(jadr2)
                     enddo
                  enddo
               enddo
            enddo
         endif
      endif
      return
      end
       subroutine cd05r(ity,nbont,ibont1,ibont2,
     *nt1,nt1a,nt1b,nt2,nt2a,nt2b,ninac,numina,ist1,ist2,icatt,
     *nts,ntstot,itorb,iorb,ispt_1,ispt_2,isgnt,norb,nn)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      parameter(maxorbcas=16,idirap=maxorb*maxorb)
      common/obin/noblig1(3),noblig2(3),ioblig1(2,3),ioblig2(2,3)
     *,ioblig1a(2,3),ioblig1b(2,3),ioblig2a(2,3),ioblig2b(2,3)
     *,noblig1a(3),noblig2a(3)
     *,noblig1b(3),noblig2b(3),icoma,icomb
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common/mr4/ niit1,niit2,np123(idirap)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/opt/ihab,calcul
      character*3 calcul
      dimension iorb(2*maxorb)
      dimension numina(maxorb)
      dimension ibont1(*),ibont2(*),icatt(2,maxsym,maxsym,-1:1)
      dimension itorb(maxorb*2),nts(maxsym),ntstot(0:maxsym)
      dimension isgnt(*)
c
c-----------------------------------------------------------
c     subroutine etablissant la liste des determinants de
c     trous utilises dans la formation du determinant final
c     (utilise aussi pour les particules)
c
c-----------------------------------------------------------
c
      common/yr/ywr
      yw1=.false.
      yw=.false..or.ywr
      nbont=0
c
c--   ntvara, ntvarb  nb de trous variables en alpha et beta
c     (necessairement identiques pour les deux determinants
      ntvara=nt1a-noblig1a(ity)
      ntvarb=nt1b-noblig1b(ity)
      if(yw)print*,'ntvara,ntvarb',ntvara,ntvarb
c
c--   si il y a 2 trous variables, les listes sur les det 1 et 2
c     sont identiques. On recopie alors ibont1 dans ibont2
      if(ntvara.eq.2) then
         call gbon2(ninac,noblig1a(ity),noblig2a(ity),
     *   ioblig1a(1,ity),ioblig2a(1,ity),nbont,ibont1,numina,ist1,ntstot
     *   ,icatt,nts,itorb,isgnt,nn)
         if(yw)print*,'apres gbon2a ibont1',(ibont1(k),k=1,nbont)
         do k=1,nbont
            ibont2(k)=ibont1(k)
         enddo
         if(yw)print*,'apres gbon2a ibont2',(ibont2(k),k=1,nbont)
      else if (ntvarb.eq.2) then
         call gbon2(ninac,noblig1b(ity),noblig2b(ity),
     *   ioblig1b(1,ity),ioblig2b(1,ity),nbont,ibont1,numina,ist1,ntstot
     *   ,icatt,nts,itorb,isgnt,nn+norb)
         if(yw)print*,'apres gbon2b ibont1',(ibont1(k),k=1,nbont)
         do k=1,nbont
            ibont2(k)=ibont1(k)
         enddo
      else if(ntvara.eq.1.and.ntvarb.eq.1) then
         call gbon11(ninac,
     *   noblig1a(ity),noblig2a(ity),noblig1b(ity),noblig2b(ity),
     *   ioblig1a(1,ity),ioblig2a(1,ity),
     *   ioblig1b(1,ity),ioblig2b(1,ity),
     *   nbont,ibont1,numina,ist1,nts,ntstot,icatt,itorb,isgnt,nn)
         if(yw)print*,'apres gbon11 ibont1',(ibont1(k),k=1,nbont)
         do k=1,nbont
            ibont2(k)=ibont1(k)
         enddo
c
c--   1 trou variable. Il faut former 2 listes independantes pour les
c     det 1 et 2. Les 2 listes doivent etre de la meme longueur.
c
      else if(ntvara.eq.1.and.ntvarb.eq.0) then
c        valeur et symetrie du trou obligatoire
         if(noblig1(ity).eq.1) then
            jto1=iorb(ioblig1(1,ity))
            iso1=itsym(jto1)
            ito1=itorb(jto1)
         else
            ito1=0
         endif
         if(noblig2(ity).eq.1) then
            jto2=iorb(ioblig2(1,ity))
            iso2=itsym(jto2)
            ito2=itorb(jto2)
         else
            ito2=0
         endif
c
c determinant 1
         call gbon1(noblig1a(ity),noblig2a(ity),
     *   ioblig1a(1,ity),ioblig2a(1,ity),
     *   nbont,ibont1,numina,ist1,ntstot,nt1,nt1a,1,iso1,ito1,nts,icatt
     *   ,isgnt,nn,iso1,jto1,iso2,jto2)
         if(yw)print*,'apres gbon1 a ibont1',(ibont1(k),k=1,nbont)
c determinant 2
         call gbon1(noblig1a(ity),noblig2a(ity),
     *   ioblig1a(1,ity),ioblig2a(1,ity),
     *   nbont2,ibont2,numina,ist2,ntstot,nt2,nt2a,1,iso2,ito2,nts,icatt
     *   ,isgnt,nn,iso1,jto1,iso2,jto2)
         if(yw)print*,'apres gbon1 a ibont2',(ibont2(k),k=1,nbont2)
         if(nbont.ne.nbont2) stop 'gbon1  nbont,nbont2'
      else if(ntvara.eq.0.and.ntvarb.eq.1) then
c        valeur et symetrie du trou obligatoire
         if(noblig1(ity).eq.1) then
            jto1=iorb(ioblig1(1,ity))
            iso1=itsym(jto1)
            ito1=itorb(jto1)
         else
            ito1=0
         endif
         if(noblig2(ity).eq.1) then
            jto2=iorb(ioblig2(1,ity))
            iso2=itsym(jto2)
            ito2=itorb(jto2)
         else
            ito2=0
         endif
c
c         print*,'norb,nn',norb,nn
c determinant 1
         call gbon1(noblig1b(ity),noblig2b(ity),
     *   ioblig1b(1,ity),ioblig2b(1,ity),
     *   nbont,ibont1,numina,ist1,ntstot,nt1,nt1b,0,iso1,ito1,nts,icatt
     *   ,isgnt,nn+norb,iso1,jto1,iso2,jto2)
         if(yw)print*,'apres gbon1 b ibont1',(ibont1(k),k=1,nbont)
c determinant 2
         call gbon1(noblig1b(ity),noblig2b(ity),
     *   ioblig1b(1,ity),ioblig2b(1,ity),
     *   nbont2,ibont2,numina,ist2,ntstot,nt2,nt2b,0,iso2,ito2,nts,icatt
     *   ,isgnt,nn+norb,iso1,jto1,iso2,jto2)
         if(yw)print*,'apres gbon1 b ibont2',(ibont2(k),k=1,nbont2)
         if(nbont.ne.nbont2) stop 'apres gbon1 nbont,nbont2'
      else if(ntvara.eq.0.and.ntvarb.eq.0) then
c
c--   pas de trou variable. Un seul determinant
c     print*,'ispt_1,noblig1(3),ioblig1(1,3),ioblig1(2,3)',
c     *ispt_1,noblig1(3),ioblig1(1,3),ioblig1(2,3)
         iso1=1
         iso2=1
         do k=1,noblig1(ity)
            iso1=its(iso1,itsym(ioblig1(k,ity)))
         enddo
         do k=1,noblig2(ity)
            iso2=its(iso2,itsym(ioblig2(k,ity)))
         enddo
         if(ist1.ne.iso1.or.ist2.ne.iso2) then
            if(yw)write(6,*)'ist1,iso1,ist2,iso2',ist1,iso1,ist2,iso2
            nbont=0
            return
         endif
         nbont=1
         if(ity.eq.1) then
            call adrt(noblig1(1),ioblig1(1,1),ispt_1,ibont1(1))
            call adrt(noblig2(1),ioblig2(1,1),ispt_2,ibont2(1))
            if(yw)print*,'nvar=0 ibont1',ibont1(1)
            if(yw)print*,'nvar=0 ibont2',ibont2(1)
         else
            call adrp(noblig1(3),ioblig1(1,3),ispt_1,ibont1(1))
            call adrp(noblig2(3),ioblig2(1,3),ispt_2,ibont2(1))
            if(yw) then
               print*,'ioblig1',(ioblig1(k,3),k=1,noblig1(3))
               print*,'ioblig2',(ioblig2(k,3),k=1,noblig2(3))
               print*,'ispt',ispt_1,ispt_2
            endif
            if(yw)print*,'nvar=0 ibonp1',ibont1(1)
            if(yw)print*,'nvar=0 ibonp2',ibont2(1)
         endif
         isgnt(1)=1
      endif
      return
      end
       subroutine gbon2(n,nob1,nob2,iob1,iob2,nbon,ibon,num,istp,ntot
     *,icattp,ntps,itorb,isgn,nn)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /sgnr/ isgnr(maxorb*2),isgnr0
      dimension iob1(*),iob2(*),ibon(*),ntot(0:maxsym),num(maxorb)
      dimension icattp(2,maxsym,maxsym,-1:1),ntps(maxsym)
     *,itorb(maxorb*2)
      common/r1/ nt1a,nt1b,np1a,np1b,nt2a,nt2b,np2a,np2b
     *,nelc1a,nelc1b,nelc2a,nelc2b
     *,nt1,nt2,np1,np2,nelc1,ispc1_1,nelc2,ispc1_2
     *,ist1,ist2,isc1,isc2,isp1,isp2,ispt1_1,ispt1_2,ispp1_1,ispp1_2,
     *ispt_1,ispt_2,ispp_1,ispp_2
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common/opt/ihab,calcul
      character*3 calcul
      dimension isgn(*)
      common/yr/ywr
c
c---------------------------------------------------------------
c     generation de 2 trous ou part de meme spin
c---------------------------------------------------------------
c
      yw=.false..or.ywr
      nbon=0
c
c--   cas isi.eq.isj
      if(istp.eq.1) then
         do j0=2,n
            if(yw)print*,'j0',j0,n
            j=num(j0)
            isj=itsym(j)
            isi=isj
            ideb=ntot(isi-1)+1
            ifin=j0-1
            jj=itorb(j)
            ij=icattp(2,istp,isi,1)+(jj-2)*(jj-1)/2
            do i0=ideb,ifin
               i=num(i0)
               ij=ij+1
               do k=1,nob1
                  if(i.eq.iob1(k)) goto 1
                  if(j.eq.iob1(k)) goto 1
               enddo
               do k=1,nob2
                  if(i.eq.iob2(k)) goto 1
                  if(j.eq.iob2(k)) goto 1
               enddo
               nbon=nbon+1
               ibon(nbon)=ij
               isgn(nbon)=isgnr(i0+nn)*isgnr(j0+nn)
               if(isgn(nbon).eq.0)stop'sgn1 gbon2'
               if(yw)print*,'deter2',j,i,ij
 1             continue
            enddo
         enddo
      else
         do i0=1,n
            if(yw)print*,'i0',i0,n
            i=num(i0)
            isi=itsym(i)
            isj=its(isi,istp)
            if(isi.ge.isj) goto 3
            ij=icattp(2,istp,isi,1)+(itorb(i)-1)*ntps(isj)
            do j0=ntot(isj-1)+1,ntot(isj)
               j=num(j0)
               ij=ij+1
               do k=1,nob1
                  if(i.eq.iob1(k)) goto 2
                  if(j.eq.iob1(k)) goto 2
               enddo
               do k=1,nob2
                  if(i.eq.iob2(k)) goto 2
                  if(j.eq.iob2(k)) goto 2
               enddo
               nbon=nbon+1
               ibon(nbon)=ij
               isgn(nbon)=isgnr(i0+nn)*isgnr(j0+nn)
               if(isgn(nbon).eq.0)stop'sgn2 gbon2'
               if(yw)print*,'deter2',j,i,ij
 2             continue
            enddo
 3          continue
         enddo
      endif
      return
      end
       subroutine gbon11(n,nob1a,nob2a,nob1b,nob2b,
     *iob1a,iob2a,iob1b,iob2b
     *,nbon,ibon,num,istp,ntps,ntot,icattp,itorb,isgn,nn)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension iob1a(*),iob1b(*),ibon(*),ntot(0:maxsym),num(maxorb)
      dimension iob2a(*),iob2b(*),ntps(maxsym)
      dimension icattp(2,maxsym,maxsym,-1:1),itorb(maxorb*2)
      common /sgnr/ isgnr(maxorb*2),isgnr0
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      dimension isgn(*)
      common/opt/ihab,calcul
      character*3 calcul
      common/yr/ywr
c
c---------------------------------------------------------------
c     generation de 2 trous ou part de spins differents
c---------------------------------------------------------------
c
      yw=.false..or.ywr
      nbon=0
      if(yw)print*,'gbon11 n',n
      do i0=1,n
         i=num(i0)
         isi=itsym(i)
         isj=its(isi,istp)
         ij=icattp(2,istp,isi,0)+(itorb(i)-1)*ntps(isj)
         if(yw)print*,'gbon11 isi,isj,ij,ntot(isj-1),ntot(isj)',
     *   isi,isj,ij,ntot(isj-1),ntot(isj)
         do j0=ntot(isj-1)+1,ntot(isj)
            if(yw)print*,'gbon11 i0,j0',i0,j0
            j=num(j0)
            ij=ij+1
            do k=1,nob1a
               if(yw)print*,'i,iob1a(k)',i,iob1a(k)
               if(i.eq.iob1a(k)) goto 1
            enddo
            do k=1,nob1b
               if(yw)print*,'j,iob1b(k)',j,iob1b(k)
               if(j.eq.iob1b(k)) goto 1
            enddo
            do k=1,nob2a
               if(yw)print*,'i,iob2a(k)',i,iob2a(k)
               if(i.eq.iob2a(k)) goto 1
            enddo
            do k=1,nob2b
               if(yw)print*,'j,iob2b(k)',j,iob2b(k)
               if(j.eq.iob2b(k)) goto 1
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)*isgnr(j0+norb+nn)
            if(isgn(nbon).eq.0)stop'sgn gbon2'
            if(yw)print*,'deter11',i,j,ij
 1          continue
         enddo
 2       continue
      enddo
      return
      end
       subroutine gbon1(nob1,nob2,iob1,iob2,nbon,ibon,num,istp,
     *ntot,ntp,ntpa,ia,iso,itpo,ntps,icattp,isgn,nn,iso1,ipo1
     *,iso2,ipo2)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
c
c     iob1,iob2 sont les trous interdits
c     ibon sont les determinants corrects (en sortie)
c     num=numina/numvir
c     istp=symetrie du determinant de trous
c     ntot=ntstot/npstot
c     ntp=nombre de trous ou part du determinant
c     ntpa=nombre de TP de meme spin que le TP var du determinant
c     ia=1 : le trou ou part rajoute est alpha
c     iso est la symetrie du trou obligatoire
c     itpo est le trou obligatoire
c     sym de spin : iso1 symetrie de la part obligatoire dans le det 1
c                   ipo1 part obligatoire dans le det 1
c
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/r1/ nt1a,nt1b,np1a,np1b,nt2a,nt2b,np2a,np2b
     *,nelc1a,nelc1b,nelc2a,nelc2b
     *,nt1,nt2,np1,np2,nelc1,ispc1_1,nelc2,ispc1_2
     *,ist1,ist2,isc1,isc2,isp1,isp2,ispt1_1,ispt1_2,ispp1_1,ispp1_2,
     *ispt_1,ispt_2,ispp_1,ispp_2
      dimension icattp(2,maxsym,maxsym,-1:1)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension iob1(*),iob2(*),ibon(*),ntot(0:maxsym),num(maxorb)
      dimension ntps(maxsym),isgn(*)
      common /sgnr/ isgnr(maxorb*2),isgnr0
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      dimension ifac(maxorb)
      common/opt/ihab,calcul
      character*3 calcul
      common/yr/ywr
      yw=.false..or.ywr
      ij=0
      nbon=0
      if(ntp.eq.2) then
         isv=its(istp,iso)
      else
         isv=istp
      endif
      if(yw)print*,'istp,iso,isv',istp,iso,isv
      if(yw)print*,'nn',nn
c      print*,'ntot',(ntot(k),k=0,2)
c      print*,'ntp,istp',ntp,istp
c--   symetrie de spin
      idebsp=1
      ifinsp=norb
      idebsp2=0
      ifinsp2=0
      do k=idebsp,ifinsp
         ifac(k)=2
      enddo
      if(yw)print*,'debut idebsp,ifinsp',idebsp,ifinsp
      if(yw)print*,'ispp_1,ispp_2,ia,isv,iso1,iso2,ipo1,ipo2'
      if(yw)write(6,'(10i4)')ispp_1,ispp_2,ia,isv,iso1,iso2,ipo1,ipo2
      if(ntp.eq.2) goto 2
c
c--   on ajoute un trou (ou part) seul
      if(yw)print*,'idebsp,ifinsp',idebsp,ifinsp
      ideb=ntot(istp-1)+1
      ifin=ntot(istp)
      if(yw)print*,'ideb,ifin',ideb,ifin
      do i0=ideb,ifin
         if(yw)print*,'i0',i0
         if(yw)print*,'isv,iso,itpo',isv,iso,itpo
         i=num(i0)
         ij=ij+1
         do k=1,nob1
            if(yw)print*,'gbon1 i,iob1(k)',i,iob1(k)
            if(i.eq.iob1(k)) goto 1
         enddo
         do k=1,nob2
            if(yw)print*,'gbon1 i,iob2(k)',i,iob2(k)
            if(i.eq.iob2(k)) goto 1
         enddo
         nbon=nbon+1
         ibon(nbon)=ij
         isgn(nbon)=isgnr(i0+nn)
         if(isgn(nbon).eq.0)stop'sgn1 gbon1'
         if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *   ,nbon,nn
 1       continue
      enddo
      return
 2    continue
c
c--   on ajoute un trou (ou part) en deuxieme
c     symetrie du trou variable
c
      ideb=ntot(isv-1)+1
      ifin=ntot(isv)
      if(yw)print*,'ideb,ifin isv,ntot(isv),ifinsp',ideb,ifin,
     *isv,ntot(isv),ifinsp
      if(ntpa.eq.1) then
c        le spin total est 0
         if(ia.eq.1) then
c        le trou variable est de spin alpha
c
            if(yw)print*,'spin 0 trou var de spin a'
     *      ,icattp(2,istp,isv,0),itpo
            if(yw)print*,'isv,iso,itpo',isv,iso,itpo
            ij=icattp(2,istp,isv,0)+itpo-ntps(iso)
 100        continue
            do 3 i0=ideb,ifin
            i=num(i0)
            ij=ij+ntps(iso)
            do k=1,nob1
               if(yw)print*,'k,iob1(k)',k,iob1(k),i
               if(iob1(k).eq.i) goto 3
            enddo
            do k=1,nob2
               if(yw)print*,'k,iob2(k)',k,iob2(k),i
               if(iob2(k).eq.i) goto 3
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn2 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
 3          continue
 8          continue
         else
c           le trou variable est de spin beta
c
            if(yw)print*,'trou var de spin b'
            ij=icattp(2,istp,iso,0)+(itpo-1)*ntps(isv)
            if(yw)write(6,'(a30,20i4)')'ij,itpo,ideb,iso,isv',
     *      ij,itpo,ideb,iso,isv
            if(yw)print*,'isv,ntps(isv)',isv,ntps(isv)
            if(yw)print*,'sptot 0 ideb,ifin',ideb,ifin
 101        continue
            do 4 i0=ideb,ifin
            i=num(i0)
            if(yw)print*,'i',i,nob1,nob2
            ij=ij+1
            do k=1,nob1
               if(yw)print*,'k,iob1(k)',k,iob1(k)
               if(iob1(k).eq.i) goto 4
            enddo
            do k=1,nob2
               if(yw)print*,'k,iob2(k)',k,iob2(k)
               if(iob2(k).eq.i) goto 4
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn3 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
 4          continue
 9          continue
         endif
 10      continue
      else
c        le spin total est 2 ou -2
         if(isv.eq.iso) then
c           le trou variable est de la meme symetrie
c           que le trou obligatoire
            ij=icattp(2,1,isv,1)+(itpo-1)*(itpo-2)/2
            ntt=ntot(isv-1)
c           ideb=max0(idebsp,ntt+1)
c           ifin=min(ifinsp,ntt+itpo-1)
            if(yw)print*,'idebsp,ntt,ifinsp',idebsp,ntt,ifinsp
            if(yw)print*,'itpo,ntps(isv),isv,ij',itpo,ntps(isv),isv,ij
c            if(yw)print*,'ideb,ifin',ideb,ifin
            do 5 i0=ntt+1,ntt+itpo-1
            ij=ij+1
            if(i0.lt.idebsp.or.i0.gt.ifinsp) goto 5
            i=num(i0)
            do k=1,nob1
               if(yw)print*,'i,iob1(k)',i,iob1(k)
               if(iob1(k).eq.i) goto 5
            enddo
            do k=1,nob2
               if(yw)print*,'i,iob2(k)',i,iob2(k)
               if(iob2(k).eq.i) goto 5
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn4 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
 5          continue
            ij=ij+1
            if(yw)print*,'ij milieu',ij
            do 51 i0=ntt+itpo+1,ntot(isv)
            ii0=i0-ntt
            ij=ij+ii0-2
            if(i0.lt.idebsp.or.i0.gt.ifinsp) goto 51
            i=num(i0)
            if(yw)print*,'i,nob1,nob2,ij',i,nob1,nob2,ij
            do k=1,nob1
               if(yw)print*,'i,iob1(k)',i,iob1(k)
               if(iob1(k).eq.i) goto 51
            enddo
            do k=1,nob2
               if(yw)print*,'i,iob2(k)',i,iob2(k)
               if(iob2(k).eq.i) goto 51
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn4 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
 51         continue
         else if (isv.gt.iso) then
            ij=icattp(2,istp,iso,1)+(itpo-1)*ntps(isv)
            ntt=ntot(isv-1)
            if(yw)print*,'itpo',itpo,ntps(isv),isv,iso
            do 6 i0=max0(idebsp,ntt+1),min(ifinsp,ntot(isv))
            i=num(i0)
            ij=ij+1
            if(yw)print*,'nob1,nob2',nob1,nob2
            do k=1,nob1
               if(yw)print*,'i,iob1(k)',i,iob1(k)
               if(iob1(k).eq.i) goto 6
            enddo
            do k=1,nob2
               if(yw)print*,'i,iob2(k)',i,iob2(k)
               if(iob2(k).eq.i) goto 6
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn5 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
 6          continue
         else if (isv.lt.iso) then
            ij=icattp(2,istp,isv,1)+itpo-ntps(iso)
            ntt=ntot(isv-1)
            if(yw)print*,'itpo',itpo,ntps(isv),isv,iso
            do 7 i0=max0(idebsp,ntt+1),min(ifinsp,ntot(isv))
            i=num(i0)
            ij=ij+ntps(iso)
            do k=1,nob1
               if(iob1(k).eq.i) goto 7
            enddo
            do k=1,nob2
               if(iob2(k).eq.i) goto 7
            enddo
            nbon=nbon+1
            ibon(nbon)=ij
            isgn(nbon)=isgnr(i0+nn)
            if(isgn(nbon).eq.0)stop'sgn6 gbon1'
            if(yw)write(6,'(a12,10i4)')'deter1',i,ij,i0,isgnr(i0+nn)
     *      ,nbon,nn
7           continue
         endif
      endif
      return
      end
       subroutine cd08r(a,b,ab,
     *ibont1,ibont2,ibonp1,ibonp2,
     *jbont1,jbont2,jbonp1,jbonp2,
     *jbonc1,jbonc2,
     *isgnt,isgnp,ysgnt,ysgnp,ysgnc)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,idiracr=160000,idicmr=35000,maxda3=300)
      include 'maxorb.prm'
      parameter(maxorbcas=16,idirap=maxorb*maxorb)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension ysgnt(ninac*ninac+1),ysgnp(nvirt*nvirt+1),
     *ysgnc(idiracr)
      integer*2 jbont1(ninac*ninac+1),jbont2(ninac*ninac+1),
     *jbonp1(nvirt*nvirt+1),jbonp2(nvirt*nvirt+1)
     *,jbont,jbonp,jbonc
      integer*2 jbonc1(idiracr),jbonc2(idiracr)
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      dimension ibont1(ninac*ninac+1),ibont2(ninac*ninac+1),
     *ibonp1(nvirt*nvirt+1),ibonp2(nvirt*nvirt+1)
      dimension ibonc1(idiracr),ibonc2(idiracr)
      dimension isgnt(ninac*ninac+1),isgnp(nvirt*nvirt+1),isgnc(idiracr)
      common /sgnr/ isgnr(maxorb*2),isgnr0
      dimension b(*),ab(*)
      jlim=32768
      do jnb2=1,jnb1
         read(78)iadr1,iadr2,jbont,jbonc,jbonp,
     *   (jbont1(k),k=1,jbont),(jbont2(k),k=1,jbont),
     *   (jbonp1(k),k=1,jbonp),(jbonp2(k),k=1,jbonp),
     *   (jbonc1(k),k=1,jbonc),(jbonc2(k),k=1,jbonc),
     *   maxpc1,maxpc2,maxc1,maxc2,
     *   ysgnr0,
     *   (ysgnt(k),k=1,jbont),
     *   (ysgnc(k),k=1,jbonc),
     *   (ysgnp(k),k=1,jbonp)
c        print*,'lecture 78'
         nbont=jbont
         nbonp=jbonp
         nbonc=jbonc
         if(ysgnr0) then
            isgnr0=1
         else
            isgnr0=-1
         endif
         do k=1,nbont
            ibont1(k)=jbont1(k)+jlim
            ibont2(k)=jbont2(k)+jlim
            if(ysgnt(k)) then
               isgnt(k)=1
            else
               isgnt(k)=-1
            endif
         enddo
         do k=1,nbonp
            ibonp1(k)=jbonp1(k)+jlim
            ibonp2(k)=jbonp2(k)+jlim
            if(ysgnp(k)) then
               isgnp(k)=1
            else
               isgnp(k)=-1
            endif
         enddo
         do k=1,nbonc
            ibonc1(k)=jbonc1(k)+jlim
            ibonc2(k)=jbonc2(k)+jlim
            if(ysgnc(k)) then
               isgnc(k)=1
            else
               isgnc(k)=-1
            endif
         enddo
         call cd06r(nbont,nbonc,nbonp,ibont1,ibont2,ibonc1,ibonc2,
     *   ibonp1,ibonp2,maxc1,maxc2,maxpc1,maxpc2,a,iadr1,iadr2,isgnt,isg
     &   np
     *   ,isgnc,b,ab
     *   ,jbont1,jbont2,jbonc1,jbonc2,jbonp1,jbonp2,ysgnt,ysgnp,ysgnc)
      enddo
      return
      end
