      subroutine denst (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/l40/ densa(maxorb,maxorb),densb(maxorb,maxorb)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      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)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      dimension ittemp(maxorb),itd(maxorb)
      dimension va(iadri)
      dimension vb(iadri)
      common/test/itest(100)
      yw=.false.
c
c-----------------------------------------------------------
c     une difference  deplacement d'un trou
c-----------------------------------------------------------
c
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      ntb=nt-nta
      npb=np-npa
      b0=va(iadr1)
      call comple(ninac,numina,nta,it,ntd,itd)
c--------boucle sur le trou supprime
      do i=1,nta
         is1=its(itsym(it(i)),istrans)
         i1=it(i)
c        it(i) est le trou supprime
         if(yw)write(6,*)'denst trou supprime',it(i)
c-------------boucle sur le trou cree
         do j=1,ntd
            if(itd(j).lt.it(i)) goto 1
            if(is1.ne.itsym(itd(j))) goto 1
            if(yw)write(6,*)'denst trou cree',itd(j)
            i2=itd(j)
            do k=1,nt
               ittemp(k)=it(k)
            enddo
            ittemp(i)=itd(j)
            isgn=2*mod(iabs(iodro(itd(j))-iodro(i1)),2)-1
            if(nta.gt.1) then
               if(ittemp(1).gt.ittemp(2))then
                  ii=ittemp(1)
                  ittemp(1)=ittemp(2)
                  ittemp(2)=ii
                  isgn=-isgn
               endif
            endif
            if(yw)write(6,*)'ittemp',(ittemp(kk),kk=1,nt)
c           write(68,*)'ittemp',(ittemp(kk),kk=1,nt)
c           write(68,*)'isgn',isgn
            call adrdet
     *      (nca,ica,ncb,icb,nt,ittemp,ispt,np,ip,ispp,iadr2,
     *      mhdum,mtdum)
            dd=va(iadr1)*vb(iadr2)*isgn
            densa(i1,i2)=densa(i1,i2)+dd
            densa(i2,i1)=densa(i2,i1)+dd
!           if(i1.eq.2.and.i2.eq.1..or.i1.eq.1.and.i2.eq.2)
!          *write(6,'(a,3i7,4f10.6)')'1denst adresses,int',
!          *iadr1,iadr2,isgn,va(iadr1),vb(iadr2)
!          *,dd,densa(i2,i1)
c------------------
            if(yw)write(6,*)'denst adresses,int',iadr1,iadr2
 1          continue
         enddo
      enddo
      if(nta.eq.2) return
      call comple(ninac,numinb,ntb,it(nta+1),ntd,itd)
c--------boucle sur le trou supprime
      do i=1,ntb
         is1=its(itsym(it(nta+i)),istrans)
         i1=iorb(it(nta+i))
c        it(nta+i) est le trou supprime
         if(yw)write(6,*)'denst trou supprime',it(nta+i)
c-------------boucle sur le trou cree
         do j=1,ntd
            if(itd(j).lt.it(nta+i)) goto 2
            if(is1.ne.itsym(itd(j))) goto 2
            i2=iorb(itd(j))
            if(yw)write(6,*)'denst trou cree',itd(j)
c           write(68,*)'b denst ts,tc',it(nta+i),itd(j)
c           itd(j) est le trou cree
            do k=1,nt
               ittemp(k)=it(k)
            enddo
            ittemp(nta+i)=itd(j)
            isgn=2*mod(iabs(iodro(itd(j))-iodro(it(nta+i))),2)-1
            if(ntb.gt.1) then
               if(ittemp(1).gt.ittemp(2))then
                  ii=ittemp(1)
                  ittemp(1)=ittemp(2)
                  ittemp(2)=ii
                  isgn=-isgn
               endif
            endif
            if(yw)write(6,*)'ittemp',(ittemp(kk),kk=1,nt)
c           write(68,*)'ittemp',(ittemp(kk),kk=1,nt)
c           write(68,*)'isgn',isgn
            call adrdet
     *      (nca,ica,ncb,icb,nt,ittemp,ispt,np,ip,ispp,iadr2,
     *      mhdum,mtdum)
            dd=va(iadr1)*vb(iadr2)*isgn
            densb(i1,i2)=densb(i1,i2)+dd
            densb(i2,i1)=densb(i2,i1)+dd
!           if(i1.eq.2.and.i2.eq.1..or.i1.eq.1.and.i2.eq.2)
!          *write(6,'(a,3i7,4f10.6)')'2denst adresses,int',
!          *iadr1,iadr2,isgn,va(iadr1),vb(iadr2)
!          *,dd,densb(i2,i1)
c------------------
            if(yw)write(6,*)'denst adresses,int',iadr1,iadr2
 2          continue
         enddo
      enddo
      return
      end
