      subroutine dens2(iadr1,kvec)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      yw=.false.
      yw1=.false.
      if(yw)print*,'entree dens2'
      yc=.false.
      do k=1,nca
         yc(num_oav(ica(k)))=.true.
      enddo
      do k=1,ncb
         yc(noac+num_oav(icb(k)))=.true.
      enddo
      if(yw1)print*,'appel dens0'!,kvec
      call dens0(iadr1,kvec)
      if(yw1)print*,'appel densc'
      call densc(iadr1,kvec,work1,work2)
      if(gener=='CAS') return
      if(gener=='SEL') return
      if(yw1)print*,'appel densp'
      call densp(iadr1,kvec,work2)
      if(yw1)print*,'appel denscp',yc
      call denscp(iadr1,kvec,work1,work2,work3)
      if(yw1)print*,'appel denstc',yc
      call denstc(iadr1,kvec,work1,work2)
      if(yw1)print*,'appel denst',yc
      call denst(iadr1,kvec,work1,work2)
      if(yw1)print*,'appel denstp'
      call denstp(iadr1,kvec,work1,work2)
      return
      end
       subroutine dens0(iadr1,kvec)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      yw=.false.
      if(yw)print*,'nta,ntb,npa,npb',nta,ntb,npa,npb
      dd=v1(iadr1,kvec)*v1(iadr1,kvec)
      do i=1,nca
         i1=ica(i)
         densa(i1,i1)=densa(i1,i1)+dd
      enddo
      do i=1,ncb
         i1=icb(i)
         densb(i1,i1)=densb(i1,i1)+dd
      enddo
      do i=1,npa
         i1=iabs(ip(i))
         densa(i1,i1)=densa(i1,i1)+dd
      enddo
      do i=1,npb
         i1=iabs(ip(i+npa))
         densb(i1,i1)=densb(i1,i1)+dd
      enddo
      do i=1,nta
         i1=iabs(it(i))
         densa(i1,i1)=densa(i1,i1)-dd
      enddo
      do i=1,ntb
         i1=iabs(it(i+nta))
         densb(i1,i1)=densb(i1,i1)-dd
      enddo
      return
      end
      subroutine densc(iadr1,kvec,ictemp,icd)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ictemp(norb),icd(norb)
      logical(1) yctmp(32)
      yw=.false.
      if(yw)print*,'entree densc'
      yctmp=yc
      !b0=v1(iadr1,kvec)
      if(yw)print*,'ica',ica(1:nca)
      if(yw)print'(a,3x,16l1,1x,16l1)','YC',yctmp
      call adrc(yctmp,iadrc1,irang)
      if(yw)print*,'iadrc1,irang',iadrc1,irang
      call comple(noac,numac,nca,ica,ncd,icd)
      if(yw)print*,'icd',icd(1:ncd)
c--------boucle sur l'electron supprime
      do i=1,nca
         i1=ica(i)
         if(yw)print*,'i,i1,num_oav(i1)',i,i1,num_oav(i1)
         yctmp(num_oav(i1))=.false.
c        ica(i) est l'electron supprime
         if(yw)write(6,*)'densc electron supprime',ica(i),num_oav(i1)
c-------------boucle sur l'electron cree
         do j=1,ncd
            if(icd(j).lt.ica(i)) cycle
            i2=icd(j)
            if(yw)write(6,*)'densc electron cree',icd(j),num_oav(i2)
c           icd(j) est le electron cree
            yctmp(num_oav(i2))=.true.
            call adrc(yctmp,iadrc,irang)
            if(yw)print*,'iadrc,irang',iadrc,irang
            do k=1,nca
               ictemp(k)=ica(k)
            enddo
            ictemp(i)=icd(j)
            call reor(nca,ictemp,isgn)
            if(sel==2) then
               jdist=icaldist(irang,ibin,ibinc,noac)
               call lim_sel(nt,np,jdist,ibon)
               if(yw)print*,'ibon',ibon,nt,np,jdist
               if(ibon==0) goto 1
            endif
            if(yw)write(6,*)'ictemp',(ictemp(kk),kk=1,nca)
            iadr2=iadr1+iadrc-iadrc1
            if(yw)print*,'iadr1,iadr2',iadr1,iadr2
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
            densa(i1,i2)=densa(i1,i2)+dd
            densa(i2,i1)=densa(i2,i1)+dd
c           if(yw)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
            yctmp(num_oav(i2))=.false.
         enddo
         yctmp(num_oav(i1))=.true.
      enddo
      yctmp=yc
      call comple(noac,numac,ncb,icb,ncd,icd)
c--------boucle sur l'electron supprime
      do i=1,ncb
         i1=icb(i)
         yctmp(noac+num_oav(i1))=.false.
c        icb(i) est l'electron supprime
         if(yw)write(6,*)'densc electron supprime',icb(i),
     *   noac+num_oav(i1)
c-------------boucle sur l'electron cree
         do j=1,ncd
            if(icd(j).lt.icb(i)) cycle
            i2=icd(j)
            if(yw)write(6,*)'densc electron cree',icd(j),
     *      noac+num_oav(i2)
c           icd(j) est l'electron cree
            yctmp(noac+num_oav(i2))=.true.
            call adrc(yctmp,iadrc,irang)
            if(yw)print*,'iadrc,irang',iadrc,irang
            do k=1,ncb
               ictemp(k)=icb(k)
            enddo
            ictemp(i)=icd(j)
            call reor(ncb,ictemp,isgn)
            if(sel==2) then
               jdist=icaldist(irang,ibin,ibinc,noac)
               call lim_sel(nt,np,jdist,ibon)
               if(yw)print*,'ibon',ibon,nt,np,jdist
               if(ibon==0) goto 2
            endif
            if(yw)write(6,*)'ica',(ica(kk),kk=1,nca)
            if(yw)write(6,*)'ictemp',(ictemp(kk),kk=1,ncb)
            iadr2=iadr1+iadrc-iadrc1
            if(yw)print*,'iadr1,iadr2',iadr1,iadr2
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*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
            yctmp(noac+num_oav(i2))=.false.
         enddo
         yctmp(noac+num_oav(i1))=.true.
      enddo
      return
      end
     
      subroutine densp (iadr1,kvec,ipd)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c    |-*-*-*-*-*-*-*-|
c    |      b        |
c
      dimension ipd(norb)
      dimension ip_sv(2)
      dimension iptemp(2)
      yw=.false.
      if(yw)write(6,*)'entree densp'
c
c-----------------------------------------------------------
c     matrice densite  deplacement d'une particule
c-----------------------------------------------------------
c
      !b0=v1(iadr1,kvec)
      call comple(nvirt,numvir,npa,ip,npd,ipd)
      if(yw)print*,'ip',ip(1:npa)
      if(yw)print*,'ipd',ipd(1:npd)
      ip_sv=ip
      
c--------boucle sur la part supprime
      do i=1,npa
         i1=ip(i)
c        ip(i) est la part supprimee
         if(yw)write(6,*)'densp part supprimee',ip(i)
c-------------boucle sur la part creee
         do j=1,npd
            if(ipd(j).lt.ip(i)) cycle
            if(yw)write(6,*)'densp part creee',ipd(j)
c           ipd(j) est la part creee
            i2=ipd(j)
!           on transfere ip dans iptemp
            iptemp(1:np)=ip(1:np)
!           on fait la substitution dans iptemp
            iptemp(i)=ipd(j)
!           on reordonne
            isgn=1
            if(npa==2) call reor(2,iptemp,isgn)
            if(yw)write(6,*)'iptemp',(iptemp(kk),kk=1,np)
!           adresse :
            call adrdet(yc,nt,it,np,iptemp,iadr2)
            if(yw)print*,'iadr2',iadr2
            if(iadr2==0) cycle
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
            if(yw)print*,'densp dd iadr1,iadr2',dd,iadr1,iadr2
            densa(i1,i2)=densa(i1,i2)+dd
            densa(i2,i1)=densa(i2,i1)+dd
c------------------
            if(yw)write(6,*)'densp adresses,int',iadr1,iadr2,isgn
         enddo
      enddo
      ip=ip_sv
      if(npa.eq.2) return
      if(yw)print*,'IP',ip(npa+1:np)
      if(yw)print*,'ipd',ipd(1:npd)
! on va travailler avec des ip positifs :
      ip(npa+1:np)=-ip(npa+1:np)
      call comple(nvirt,numvir,npb,ip(npa+1),npd,ipd)
c--------boucle sur la part supprimee
      do i=1,npb
         i1=ip(npa+i)
c        ip(npa+i) est la part supprimee
         if(yw)write(6,*)'densp part b supprimee',ip(npa+i)
c-------------boucle sur la part cree
         do j=1,npd
            if(ipd(j).lt.ip(npa+i)) cycle
            if(yw)write(6,*)'densp part b creee',ipd(j)
            i2=ipd(j)
c           ipd(j) est la part creee
            iptemp(1:np)=ip(1:np)
            iptemp(npa+i)=ipd(j)
            isgn=1
            if(npb==2) call reor(2,iptemp,isgn)
! on remet les signes negatifs sur les particules beta
            iptemp(npa+1:np)=-iptemp(npa+1:np)
            call adrdet(yc,nt,it,np,iptemp,iadr2)
            if(yw)print*,'iadr2',iadr2
            if(iadr2==0) cycle
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
            if(yw)print*,'densp DD iadr1,iadr2',dd,iadr1,iadr2
            densb(i1,i2)=densb(i1,i2)+dd
            densb(i2,i1)=densb(i2,i1)+dd
c------------------
         enddo
      enddo
      ip=ip_sv
C      ip(npa+1:np)=-ip(npa+1:np)
      return
      end
      subroutine denscp (iadr1,kvec,ictemp,iptemp,ipd)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ictemp(norb)
      dimension iptemp(norb),ipd(norb)
      logical(1) yctmp(32)
      yw=.false.
      if(yw)print*,'entree denscp'
      yctmp=yc
c
c-----------------------------------------------------------
c     matrice densite  deplacement 1 electron CAS  --> 1 part
c-----------------------------------------------------------
c
      if(np.ge.2) return
      !b0=v1(iadr1,kvec)
      if(gener(5:8).eq.'DDCI') then
         if(nt.eq.2.and.np.eq.1) return
      else if(gener(5:8).eq.'DDC2') then
         if(nt.eq.2) return
         if(nt.eq.1.and.np.eq.1) return
      else if(gener(5:8)=='S   ') then
         if(nt.gt.1.or.np.gt.0) return
      endif
! On va travailler avec les part beta reperees par '+norb'
      if(np==1) then
         if(ip(1)<0)ip(1)=-ip(1)+norb
      endif
      if(yw)write(6,*)'nt,np,nca,ncb,nocac0,nocbc0',
     *nt,np,nca,ncb,nocac0,nocbc0
!
! Saut sur la partie alpha
!
      call comple(nvirt,numvir,npa,ip,npd,ipd)
      do i=1,nca
c--------ica(i) est l'electron supprime
         i1=ica(i)
         yctmp(num_oav(i1))=.false.
         call adrc(yctmp,iadrc,irang)
         if(yw)write(6,*)'denscp electron a supprime',ica(i)
c--------------boucle sur la particule creee
         do 2 j=1,npd
         i2=ipd(j)
         if(yw)write(6,*)'denscp part a creee',ipd(j)
c-----------------ipd(j) est la particule creee
         isgn=1
         if(np.eq.1) then
            if(ip(1).gt.ipd(j)) then
               iptemp(1)=ipd(j)
               iptemp(2)=ip(1)
            else
               iptemp(1)=ip(1)
               iptemp(2)=ipd(j)
               if(npa.eq.1)isgn=-1
            endif
         else
            iptemp(1)=ipd(j)
         endif
         do k=1,i-1
            ictemp(k)=ica(k)
         enddo
         do k=i+1,nca
            ictemp(k-1)=ica(k)
         enddo
         if(sel==2) then
            jdist=icaldist(irang,ibin,ibinc,noac)
            call lim_sel(nt,np+1,jdist,ibon)
            if(yw)print*,'ibon',ibon,nt,np+1,jdist
            if(ibon==0) goto 1
         endif
         if(yw)write(6,*)'denscp a appel adrdet'
         do k=1,np+1
            if(iptemp(k)>norb) iptemp(k)=-(iptemp(k)-norb)
         enddo
         call adrdet(yctmp,nt,it,np+1,iptemp,iadr2)
         if(yw)print*,'iadr1,iadr2',iadr1,iadr2
         if(yw.and.iadr2==0) print*,'ADR0'
         if(iadr2==0) goto 1
c---------------------
c---------------------signe
c                     on a supprime l'el CAS i et cree la part j
c                     on a donc ramene l'el i a la place j
c                     l'el a donc saute
c                     - par dessus 1 part si il y en avait deja
c                       une et qu'elle etait de rang inferieur
c                       (voir test sur ip(1) et ipd(j) plus haut)
c                     - par dessus nca-i el du CAS
c      
c                                CAS                          part
c                                 i                                j
c                           x x x   x x   x                 x      x
c                                 |________________________________|
c                           <----nca------>
c                                   <nca-i>
c---------------------
         isgn=isgn*(1-2*mod(nca+i,2))
         if(yw)write(6,*)'denscp adresses,int',iadr1,iadr2,isgn
         dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
         densa(i1,i2)=densa(i1,i2)+dd
         densa(i2,i1)=densa(i2,i1)+dd
c        print*,'iadr1,iadr2,b(iadr1),b(iadr2)',
c        * iadr1,iadr2,b(iadr1),b(iadr2)
c         print*,'i1,i2,dd,densa(i1,i2)',i1,i2,dd,densa(i1,i2)
 2       continue
 1       continue
         yctmp(num_oav(i1))=.true.
      enddo
 9    continue
!
! Saut sur la partie beta
!
      yctmp=yc
      call comple(nvirt,numvir+norb,npb,ip(npa+1),npd,ipd)
      do  i=1,ncb
c-----------icb(i) est l'electron supprime
         i1=icb(i)
         yctmp(noac+num_oav(i1))=.false.
         call adrc(yctmp,iadrc,irang)
         if(yw)write(6,*)'denscp electron b supprime',icb(i)
c--------------boucle sur la particule creee
         do 4 j=1,npd
         i2=ipd(j)-norb
         if(yw)write(6,*)'denscp part b creee',ipd(j)
c-----------------ipd(j) est la part creee
         if(yw)write(6,*)'np,ip(1)',np,ip(1)
         iptemp(1:np)=ip(1:np)
         iptemp(np+1)=ipd(j)
         if(npb==1) call reor(2,iptemp(npa+1:np+1),isgn)
         if(yw)write(6,*)'denscp b iptemp',(iptemp(k),k=1,np+1)
         if(sel==2) then
            jdist=icaldist(irang,ibin,ibinc,noac)
            call lim_sel(nt,np+1,jdist,ibon)
            if(yw)print*,'ibon',ibon,nt,np+1,jdist
            if(ibon==0) goto 4
         endif
         if(yw)write(6,*)'denscp b appel adrdet'
         do k=1,np+1
            if(iptemp(k)>norb) iptemp(k)=-(iptemp(k)-norb)
         enddo
         if(yw)print*,it(1:nt),'--',iptemp(1:np+1)
         call adrdet(yctmp,nt,it,np+1,iptemp,iadr2)
         if(yw)print*,'iadr1,iadr2',iadr1,iadr2
         if(yw.and.iadr2==0) print*,'ADR0'
         if(iadr2==0) goto 4
c---------------------
c---------------------signe
c                     on a supprime l'el CAS i et cree la part j
c                     on a donc ramene l'el i a la place j
c                     l'el a donc saute
c                     - par dessus 1 part si il y en avait deja
c                       une et qu'elle etait de rang inferieur
c                       (voir test sur ip(1) et ipd(j) plus haut)
c                     - par dessus ncb-i el du CAS
c      
c                                CAS                          part
c                                 i                                j
c                           x x x   x x   x                 x      x
c                                 |________________________________|
c                           <----ncb------>
c                                   <ncb-i>
c---------------------
         if(yw)write(6,*)'isgn,i,npa',isgn,i,npa
         isgn=isgn*(1-2*mod(ncb+i,2))
         dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
         densb(i1,i2)=densb(i1,i2)+dd
         densb(i2,i1)=densb(i2,i1)+dd
         if(yw)write(6,*)'denscp adresses,int',iadr1,iadr2,isgn
 4       continue
         yctmp(noac+num_oav(i1))=.true.
      enddo
 3    continue
      if(np==1) then
         if(ip(1)>norb)ip(1)=-(ip(1)-norb)
      endif
      return
      end
      subroutine denstc(iadr1,kvec,ittemp,ictemp)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ittemp(norb)
      dimension ictemp(norb)
      logical(1) yctmp(32)
      yw=.false.
      if(yw)print*,'entree denstc',ip
      yctmp=yc
c
c-----------------------------------------------------------
c     matrice densite  suppression 1 trou 1 electron CAS
c-----------------------------------------------------------
c
      !b0=v1(iadr1,kvec)
c     print*,'denstc nca,ncb',nca,ncb
c     iif(yw)write(6,*)'nca,ncb,nca0,ncb0
      do 1 i=1,nta
c--------it(i) est le trou supprime
      i1=it(i)
      if(yw)write(6,*)'denstc trou a supprime',it(i)
c-----------boucle sur l'electron supprime
      do j=1,nca
         i2=ica(j)
         yctmp(num_oav(i2))=.false.
         call adrc(yctmp,iadrc,irang)
         if(yw)write(6,*)'denstc electron a supprime',ica(j)
c-----------------ica(j) est l'electron actif supprime
         do k=1,i-1
            ittemp(k)=it(k)
         enddo
         do k=i+1,nt
            ittemp(k-1)=it(k)
         enddo
         if(sel==2) then
            jdist=icaldist(irang,ibin,ibinc,noac)
            call lim_sel(nt,np+1,jdist,ibon)
            if(yw)print*,'ibon',ibon,nt-1,np,jdist
            if(ibon==0) goto 2
         endif
         call adrdet(yctmp,nt-1,ittemp,np,ip,iadr2)
         if(yw)print*,'iadr1,iadr2',iadr1,iadr2
         if(iadr2==0) goto 1
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+num_oav(it(i))+(nta+i)+j+1,2)
         dd=v1(iadr1,kvec)*v1(iadr2,kvec)*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
         yctmp(num_oav(i2))=.true.
         if(yw)print*,'yctmp fin',i2,num_oav(i2),yctmp
      enddo
 1    continue
 9    continue
      yctmp=yc
      do 3 i=nta+1,nt
c--------it(i) est le trou supprime
      i1=-it(i)
      if(yw)write(6,*)'denstc trou b supprime',it(i)
c-----------boucle sur l'electron supprime
      do j=1,ncb
         i2=icb(j)
         yctmp(noac+num_oav(i2))=.false.
         call adrc(yctmp,iadrc,irang)
         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(sel==2) then
            jdist=icaldist(irang,ibin,ibinc,noac)
            call lim_sel(nt,np+1,jdist,ibon)
            if(yw)print*,'ibon',ibon,nt-1,np,jdist
            if(ibon==0) goto 4
         endif
         call adrdet(yctmp,nt-1,ittemp,np,ip,iadr2)
         if(yw)print*,'iadr1,iadr2',iadr1,iadr2
         if(iadr2==0) goto 3
c---------------------
c---------------------signe (v. commentaires + haut
         isgn=1-2*mod(ninac+num_oav(i1)+(ntb+i+nta)+j+1,2)
         dd=v1(iadr1,kvec)*v1(iadr2,kvec)*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,iabs(it(i)),num_oav(iabs(it(i))),ntb,i,nta,j',
     *   ninac,iabs(it(i)),num_oav(iabs(it(i))),ntb,i,nta,j
         if(yw)write(6,*)'denstc adresses,int',iadr1,iadr2,isgn
 4       continue
         yctmp(noac+num_oav(i2))=.true.
      enddo
 3    continue
      return
      end
      subroutine denst(iadr1,kvec,ittemp,itd)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ittemp(norb),itd(norb)
      yw=.false.
      if(yw)print*,'entree denst'
c
c-----------------------------------------------------------
c     une difference  deplacement d'un trou
c-----------------------------------------------------------
c
      !b0=v1(iadr1,kvec)
      call comple(ninac,numin,nta,it,ntd,itd)
c--------boucle sur le trou supprime
      do i=1,nta
         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)) cycle
            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(num_oav(itd(j))-num_oav(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)
            call adrdet(yc,nt,ittemp,np,ip,iadr2)
            if(yw)write(6,*)'denst adresses,int',iadr1,iadr2
            if(iadr2==0) cycle
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
            densa(i1,i2)=densa(i1,i2)+dd
            densa(i2,i1)=densa(i2,i1)+dd
c------------------
         enddo
      enddo
      if(nta.eq.2) return
      if(yw)print*,'ntb,-it(nta+1)',ntb,-it(nta+1)
      do k=nta+1,nt
         it(k)=-it(k)
      enddo
      call comple(ninac,numin,ntb,it(nta+1),ntd,itd)
      do k=nta+1,nt
         it(k)=-it(k)
      enddo
      if(yw) print*,'itd',itd(1:ntd)
c--------boucle sur le trou supprime
      do i=1,ntb
         i1=iabs(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)) cycle
            if(itd(j).lt.i1) cycle
            i2=iabs(itd(j))
            if(yw)write(6,*)'denst trou cree',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(num_oav(itd(j))-num_oav(-it(nta+i))),2)-1
            if(ntb.gt.1) then
               if(abs(ittemp(1)).gt.abs(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)
            if(yw)write(6,*)'ip',(ip(kk),kk=1,np)
            if(yw)write(6,*)'yc',(yc(kk),kk=1,noac*2)
            call adrdet(yc,nt,ittemp,np,ip,iadr2)
            if(yw)write(6,*)'denst adresses,int',iadr1,iadr2
            if(iadr2==0) cycle
            dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
            densb(i1,i2)=densb(i1,i2)+dd
            densb(i2,i1)=densb(i2,i1)+dd
c------------------
         enddo
      enddo
      return
      end
      subroutine denstp(iadr1,kvec,ittemp,iptemp)
      use module
      use mod_gen
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      dimension ittemp(norb)
      dimension iptemp(norb)
      yw=.false.
      if(nt==0) return
      if(np==0) return
      if(yw)print*,'entree denstp'
c
c-----------------------------------------------------------
c     matrice densite  suppression 1 trou 1 part
c-----------------------------------------------------------
c
      !b0=v1(iadr1,kvec)
      do 1 i=1,nta
c--------it(i) est le trou supprime
      i1=it(i)
      if(yw)write(6,*)'denstp trou a supprime',it(i)
c-----------boucle sur la particule supprimee
      do 2 j=1,npa
      i2=ip(j)
      if(yw)write(6,*)'denstp part a supprimee',ip(j)
c--------------ip(j) est la part supprimee
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         iptemp(k)=ip(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,np
         iptemp(k-1)=ip(k)
      enddo
      call adrdet(yc,nt-1,ittemp,np-1,iptemp,iadr2)
      if(yw)print*,'iadr1,iadr2',iadr1,iadr2
      if(iadr2==0) goto 2
c------------------
c------------------signe
c                  on a supprime le trou i et la part j
c                  on a donc ramene l'el j a la place i
c
c                  l'el a donc saute
c                  - par dessus j-1 part
c                  - par dessus nca el du CAS
c                  - par dessus ninac-ita(i)-(nta-i) occupees
c
c                             occ              CAS         part
c                              i                                j
c                        x x x   x x   x      x x x      x      x
c                              |________________________________|
c                        <---ninac----->      <nca>
c                              <------->
c                              ninac-ita(i)
c                      donc    ninac-ita(i)-(nta-i) electrons
c------------------
c           isgn=1-2*mod(ninac-iordo(it(i))-(nta-i)+nca+j-1,2)
      isgn=1-2*mod(ninac+num_oav(it(i))+(nta+i)+nca+j+1,2)
      dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
      densa(i1,i2)=densa(i1,i2)+dd
      densa(i2,i1)=densa(i2,i1)+dd
      if(yw)write(6,*)'denstp adresses,int',iadr1,iadr2,isgn
 2    continue
 1    continue
      do 3 i=nta+1,nt
c--------it(i) est le trou supprime
      i1=iabs(it(i))
      if(yw)write(6,*)'denstp trou b supprime',it(i)
c-----------boucle sur la particule supprimee
      do 4 j=npa+1,np
      i2=iabs(ip(j))
      if(yw)write(6,*)'denstp part b supprimee',ip(j)
c--------------ip(j) est la part supprimee
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         iptemp(k)=ip(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,np
         iptemp(k-1)=ip(k)
      enddo
      call adrdet(yc,nt-1,ittemp,np-1,iptemp,iadr2)
      if(yw)write(6,*)'denstp adresses,int',iadr1,iadr2,isgn
      if(iadr2==0) goto 4
      isgn=1-2*mod(ninac+num_oav(i1)+(ntb+i+nta)+ncb+j+npa+1,2)
      dd=v1(iadr1,kvec)*v1(iadr2,kvec)*isgn
      densb(i1,i2)=densb(i1,i2)+dd
      densb(i2,i1)=densb(i2,i1)+dd
 4    continue
 3    continue
      return
      end
