      subroutine denstc (nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *va,vb,istrans)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c    |-*-*-*-*-*-*-*-|
c    |      b        |
c
      common/dim/ iadri
      common/opt/ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common/l40/ densa(maxorb,maxorb),densb(maxorb,maxorb)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *,numt(maxorb),nump(maxorb),nv
     *,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *,ygmono,ygddci,ygddc2,ygcas,ygtous
      character*4 gener
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      dimension ittemp(maxorb)
      dimension ictemp(maxorb)
      dimension va(iadri)
      dimension vb(iadri)
      common/test/itest(100)
      yw=.false.
c
c-----------------------------------------------------------
c     matrice densite  suppression 1 trou 1 electron CAS
c-----------------------------------------------------------
c
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      ntb=nt-nta
      npb=np-npa
      ynon=.false.
      b0=va(iadr1)
c     print*,'denstc nca,ncb',nca,ncb
c     iif(yw)write(6,*)'nca,ncb,nca0,ncb0
      if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.ygmono
     *.or.gener.eq.'MR') then
         if(iabs(nca-1-ncb-nca0+ncb0).gt.2) goto 9
      else if(gener.eq.'DDCI'.or.gener.eq.'DDC2') then
         if(iabs(nca-1-ncb-nca0+ncb0).gt.3) goto 9
      endif
      do 1 i=1,nta
c--------it(i) est le trou supprime
      is1=its(itsym(it(i)),istrans)
      i1=it(i)
      if(yw)write(6,*)'denstc trou a supprime',it(i)
c-----------boucle sur l'electron supprime
      do 2 j=1,nca
      if(is1.ne.itsym(ica(j))) goto 2
      i2=ica(j)
      if(yw)write(6,*)'denstc electron a supprime',ica(j)
c--------------ica(j) est l'electron supprimee
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         ictemp(k)=ica(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,nca
         ictemp(k-1)=ica(k)
      enddo
      if(gener(1:2).eq.'MR')
     *call accept(nca-1,ictemp,ncb,icb,nt-1,np,ynon)
      if(ynon) goto 1
      call adrdet
     *(nca-1,ictemp,ncb,icb,nt-1,ittemp,
     *ispt-1,np,ip,ispp,iadr2,
     *      mhdum,mtdum)
c------------------
c------------------signe
c                  on a supprime le trou i et l'el CAS j
c                  on a donc ramene l'el j a la place i
c                  l'el a donc saute
c                  - par dessus j-1 el du CAS
c                  - par dessus ninac-ica(i)-(nca-i) occupees
c
c                             occ                           CAS
c                              i                               j
c                        x x x   x x   x                 x x x x x x
c                              |_______________________________|
c                        <---ninac----->
c                              <------->
c                              ninac-ita(i)
c                      donc    ninac-ita(i)-(nta-i) electrons
c------------------
      isgn=1-2*mod(ninac+iodro(it(i))+(nta+i)+j+1,2)
      dd=va(iadr1)*vb(iadr2)*isgn
      densa(i1,i2)=densa(i1,i2)+dd
      densa(i2,i1)=densa(i2,i1)+dd
c        write(75,*)
c     *   '%%  iadr1,iadr1,b(iadr1),b(iadr2),dd',
c     *   iadr1,iadr1,b(iadr1),b(iadr2),dd,'$'
c     if(i1.eq.1.and.i2.eq.5.or.i2.eq.1.and.i1.eq.5) then
c        write(6,'('' %%%%%tc'',2i6,4f10.6)')
c     *   iadr1,iadr2,b(iadr1),b(iadr2),dd,densa(i1,i2)
c     endif
      if(yw)write(6,*)'denstc adresses,int',iadr1,iadr2
 2    continue
 1    continue
 9    continue
      if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.ygmono
     *.or.gener.eq.'MR') then
         if(iabs(nca-ncb+1-nca0+ncb0).gt.2) return
      else if(gener.eq.'DDCI'.or.gener.eq.'DDC2') then
         if(iabs(nca-ncb+1-nca0+ncb0).gt.3) return
      endif
      do 3 i=nta+1,nt
c--------it(i) est le trou supprime
      is1=its(itsym(it(i)),istrans)
      i1=iorb(it(i))
      if(yw)write(6,*)'denstc trou b supprime',it(i)
c-----------boucle sur l'electron supprime
      do 4 j=1,ncb
      if(is1.ne.itsym(icb(j))) goto 4
      i2=icb(j)
      if(yw)write(6,*)'denstc electron b supprime',icb(j)
c--------------icb(j) est l'electron supprime
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         ictemp(k)=icb(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,ncb
         ictemp(k-1)=icb(k)
      enddo
      if(gener(1:2).eq.'MR')
     *call accept(nca,ica,ncb-1,ictemp,nt-1,np,ynon)
      if(ynon) goto 4
      call adrdet
     *(nca,ica,ncb-1,ictemp,nt-1,ittemp,
     *ispt+1,np,ip,ispp,iadr2,
     *      mhdum,mtdum)
c------------------
c------------------signe (v. commentaires + haut
      isgn=1-2*mod(ninac+iodro(i1)+(ntb+i+nta)+j+1,2)
      dd=va(iadr1)*vb(iadr2)*isgn
      densb(i1,i2)=densb(i1,i2)+dd
      densb(i2,i1)=densb(i2,i1)+dd
c     if(i1.eq.1.and.i2.eq.5.or.i2.eq.1.and.i1.eq.5) then
c        write(6,'('' %%%%%tc'',2i6,4f10.6)')
c     *   iadr1,iadr2,b(iadr1),b(iadr2),dd,densa(i1,i2)
c     endif
      if(yw)
     *write(6,*)'ninac,iorb(it(i)),iodro(iorb(it(i))),ntb,i,nta,j',
     *ninac,iorb(it(i)),iodro(iorb(it(i))),ntb,i,nta,j
      if(yw)write(6,*)'denstc adresses,int',iadr1,iadr2,isgn
 4    continue
 3    continue
      return
      end
