      subroutine dens(b)
      parameter(maxsym=8,maxorbcas=16,maxda3=300)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
c    |-*-*-*-*-*-*-*-|
c    |       b       |
c
      common/dim/iadri ; integer(8) iadri
      common/pr/nprint,mprint(10)
      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
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      common/l40/ densa(maxorb,maxorb),densb(maxorb,maxorb)
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,N,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      logical*1 bidia
      common/adr/iadr0(maxsym),nbint
      dimension b(iadri)
      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/test/itest(100)
      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)
c
c-----------------------------------------------------------
c     matrice densite
c-----------------------------------------------------------
c
      yw=.false.
      yw1=.false.
      if(yw)write(6,*)'debut dens',norb
      if(ytana.or.yw)write(6,*)'matrice densite'
c-- mise a zero
      do i=1,norb
         do j=1,norb
            densa(j,i)=0.d0
            densb(j,i)=0.d0
         enddo
      enddo
      do k=1,ninac
         i=numina(k)
         densa(i,i)=1.d0
         densb(i,i)=1.d0
      enddo
c--   lecture des determinants
      iadr1=0
      call rew61
 1    continue
      call venondloc(ne,ntv,npv,ierr)
      if(ierr.eq.1) goto 100
c      read(61,end=100)ne
c      if(ne.ne.0) read(61)(ntv(k),k=1,ne),(npv(k),k=1,ne)
      iadr1=iadr1+1
      call trad(ne,ntv,npv,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,ierr)
      coef=1.d0
      b0=b(iadr1)
      if(yw)write(6,*)' di de depart',(ntv(k),k=1,ne),'  ',
     *(npv(k),k=1,ne)
      if(yw)write(6,*)'dens   adresse du di de depart',iadr1
      call dens0(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      if(yw)write(6,*)'avant densc '
      call densc(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      if(ygcas) goto 1
      if(yw)write(6,*)'avant densp '
c     print*,'appel densp'
      call densp(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      call denscp(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      if(yw)write(6,*)'avant denstp '
      call denstp(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      if(yw)write(6,*)'avant denst '
      call denst(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      if(yw)write(6,*)'avant denstc '
      call denstc(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,b)
      goto 1
 100  continue
c      rewind 63
c      a voir en cas de sc2
      if(ydens) then
         if(ms2.ne.0)open(38,form='unformatted',
     *   status='unknown',file='DENSA')
         if(yw.or.mprint(6)==1) then
            write(6,*)' '
            print*,'matrice densite alpha'
            write(6,*)' '
            call script(densa,norb,norb,maxorb,maxorb)
            aa=0.d0
            do k=1,norb
               aa=aa+densa(k,k)
            enddo
            print*,'aa',aa
            write(6,*)' '
            print*,'matrice densite beta'
            write(6,*)' '
            call script(densb,norb,norb,maxorb,maxorb)
         endif
         if(ms2.ne.0)write(38)((densa(i,j),i=1,norb),j=1,norb)
         do k=1,norb
            do l=1,norb
               densa(l,k)=densa(l,k)+densb(l,k)
            enddo
         enddo
         write(63)((densa(i,j),i=1,norb),j=1,norb)
         if(nprint.ge.2.or.mprint(6)==1) then
            write(6,*)' '
            print*,'matrice densite '
            write(6,*)' '
            call script(densa,norb,norb,maxorb,maxorb)
            do i=1,norb
               do j=1,i
                  print*,'dens',i,j,densa(i,j)
               enddo
            enddo
         endif
      endif
      return
      end
