      subroutine densc (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    |-*-*-*-*-*-*-*-|
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 /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      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 /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 ictemp(maxorb),icd(maxorb)
      dimension va(iadri)
      dimension vb(iadri)
      common/test/itest(100)
      yw=.false.
c
c-----------------------------------------------------------
c     matrice densite deplacement d'un electron du CAS
c-----------------------------------------------------------
c
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      ntb=nt-nta
      npb=np-npa
      ynon=.false.
      b0=va(iadr1)
      if(yw)write(6,*)'densc nca',nca
      call comple(noac,numac,nca,ica,ncd,icd)
c--------boucle sur l'electron supprime
      do i=1,nca
         is1=its(itsym(ica(i)),istrans)
         i1=ica(i)
c        ica(i) est l'electron supprime
         if(yw)write(6,*)'densc electron supprime',ica(i)
c-------------boucle sur l'electron cree
         do j=1,ncd
            if(icd(j).lt.ica(i)) goto 1
            if(is1.ne.itsym(icd(j))) goto 1
            if(yw)write(6,*)'densc electron cree',icd(j)
c           icd(j) est le electron cree
            i2=icd(j)
            do k=1,nca
               ictemp(k)=ica(k)
            enddo
            ictemp(i)=icd(j)
            call reor(nca,ictemp,isgn)
            if(yw)write(6,*)'ictemp',(ictemp(kk),kk=1,nca)
            if(gener(1:2).eq.'MR')
     *      call accept(nca,ictemp,ncb,icb,nt,np,ynon)
            if(ynon) goto 1
            call adrdet
     *      (nca,ictemp,ncb,icb,nt,it,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
c           print*,'i1,i2,dd,densa(i1,i2)',i1,i2,dd,densa(i1,i2)
c------------------
            if(yw)write(6,*)'densc adresses,int',iadr1,iadr2
 1          continue
         enddo
      enddo
      call comple(noac,numac,ncb,icb,ncd,icd)
c--------boucle sur l'electron supprime
      do i=1,ncb
         is1=its(itsym(icb(i)),istrans)
         i1=icb(i)
c        icb(i) est l'electron supprime
         if(yw)write(6,*)'densc electron supprime',icb(i)
c-------------boucle sur l'electron cree
         do j=1,ncd
            if(icd(j).lt.icb(i)) goto 2
            if(is1.ne.itsym(icd(j))) goto 2
            if(yw)write(6,*)'densc electron cree',icd(j)
c           icd(j) est l'electron cree
            i2=icd(j)
            do k=1,ncb
               ictemp(k)=icb(k)
            enddo
            ictemp(i)=icd(j)
            call reor(ncb,ictemp,isgn)
            if(yw)write(6,*)'ica',(ica(kk),kk=1,nca)
            if(yw)write(6,*)'ictemp',(ictemp(kk),kk=1,ncb)
            if(gener(1:2).eq.'MR')
     *      call accept(nca,ica,ncb,ictemp,nt,np,ynon)
            if(ynon) goto 2
            call adrdet
     *      (nca,ica,ncb,ictemp,nt,it,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
c------------------
            if(yw)write(6,*)
     *      'densc adresses,int,isgn',iadr1,iadr2,isgn
 2          continue
         enddo
      enddo
      return
      end
