      subroutine dens
      use module
C     use mod_dav
      use mod_gen
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(18),allocatable,dimension(:) :: tipo
      dimension ibid(8)
      real(8),allocatable :: densvec(:,:)
      common/ecrv/nnn,kk,kvec
      yfin=.true.
      ydens2=.true.
      allocate(densa(norb,norb),densb(norb,norb))
      allocate(work1(norb),work2(norb),work3(norb))
      yw=.false.
      open(38,form='unformatted',status='unknown',file='DENSB')
!   3-   6-  --> [-] -->    9-  11-    0.00000000
      rewind 11
      read(11)
      read(11)
      do kvec=1,nvec

c-- mise a zero des matrices densite
         densa=0.d0
         densb=0.d0
         do k=1,ninac
            i=numin(k)
            densa(i,i)=1.d0
            densb(i,i)=1.d0
         enddo
         nnn=0
         read(11) v1(:,kvec)
         nn=0

! Calcul des matrices densite         
         do iclc=1,nclasc
            if(.not.exist_clasc(iclc)) cycle
            !
            ! Boucle sur les det du CAS de la classe
            !
            do kc=idebc(iclc),ifinc(iclc)
               !
               ! Lecture du string CAS
               !
C               bb=' '
               i=ibinc(kc)
               nca=0
               ncb=0
               do k=1,noac
                  if(i==ibset(i,k-1)) then
                     nca=nca+1
                     ica(nca)=numac(k)
                  endif
               enddo
               do k=16+1,16+noac
                  if(i==ibset(i,k-1)) then
                     ncb=ncb+1
                     icb(ncb)=numac(k-16)
                  endif
               enddo
               do k=1,noac
               enddo
               !
               ! Calcul selectionne : distance du string CAS
               !
               if(sel==2) jdist=icaldist(kc,ibin,ibinc,noac)
               !
               ! Boucle sur les classes TP correspondant au CAS
               !
               do jcltp=1,nc_tp(iclc)
                  nn=nn+1
                  i=ic_tp(jcltp,iclc)
                  nta=icltp1(1,i)
                  ntb=icltp1(2,i)
                  npa=icltp1(3,i)
                  npb=icltp1(4,i)
                  nt=nta+ntb
                  np=npa+npb
                  ntnp=nt+np
                  if(sel==2) then
                     call lim_sel(nt,np,jdist,ibon)
                     if(ibon==0) cycle
                  endif
                  if(ntnp==0) then
                     call gen_0
                  else if(ntnp==1) then
                     if(nt==1) then
                        call gen_t
                     else
                        call gen_p
                     endif
                  else if(ntnp==2) then
                     if(nt==1) then
                        call gen_tp
                     else if(nt==0) then
                        call gen_pp
                     else if(nt==2) then
                        call gen_tt
                     endif
                  else if(ntnp==3) then
                     if(nt==1) then
                        call gen_tpp
                     else
                        call gen_ttp
                     endif
                  else if(ntnp==4) then
                     call gen_ttpp
                  endif
               enddo
            enddo
         enddo
! Fin du calcul des matrices densite, on les ecrit sur file

         write(63) densa+densb
         if(yw) then
            print*,'Matrice Densite alpha Vecteur',kvec
            call mscript(densa)
            print*,'Matrice Densite beta Vecteur',kvec
            call mscript(densb)
         endif
         if(nprint>1) then
            print*,'Matrice Densite alpha + beta. Vecteur',kvec
            call mscript(densa+densb)
         endif
         write(38) densa,densb
      enddo
      if(ms2/=0) then
         rewind 38
         do kvec=1,nvec
            read(38) densa
            write(63) densa
            if(nprint>1) then
               print*,'Matrice Densite alpha. Vecteur',kvec
               call mscript(densa)
            endif
         enddo
      endif
      call titre(' Matrice Densite calculee, et stockee sur '
     *//'file'//'#',45)

      !---------------------------------------------------------
      ! Analyse de population
      !---------------------------------------------------------


      ! lire les labels OL
      call lirorb('ORB_IJKLOC',nao,nbid2,ibid,99,98)
      allocate(tipo(nao))
      read(99)
      read(99)
      read(99) tipo
      close(98)
      close(99,status='delete')

      ! sauter les OL gelees
      ngel=0
      do i=1,nao
         if(tipo(i)(1:1)=='G') then
            ngel=ngel+1
         else
            exit
         endif
      enddo

      ! diagonaliser la matrice densite
      rewind 38
      call open_chose_number(ifNO,'NO_TMP','unknown','unformatted')
      allocate(workc(norb,norb))
      if(ms2==0) then
         allocate(densvec(norb,nvec))
         densvec=0.d0
         do kvec=1,nvec
            read(38) densa,densb
            densa=densa+densb
            call hdiag_L(densa,workc,norb,norb)
            do i=1,norb
               densvec(i,kvec)=densa(i,i)
            enddo
            if(yw)print*,'densvec',kvec,densvec(:,kvec)
            write(ifNO) workc,densvec(:,kvec)
         enddo
         ! write occupations
         call titre(' Analyse de Population : '//
     *   '#Occupation des orbitales naturelles#',40)
         do j=1,nvec,5
            l=5
            if(j+l-1>nvec) l=mod(nvec,5)
            if(l==0)l=5
            !print'(16x,5i10)',(/(i,i=j,j+l-1)/)
            print'(/,a,8x,5i10)','   VECT',(/(ll,ll=j,j+l-1)/)
            do i=1,ninac
               if(any(2.d0-densvec(i,j:j+l-1)>twdens))
     *         print'(i5,13x,5f10.6)',ngel+i,densvec(i,j:j+l-1)
            enddo
            do i=1+ninac,noac+ninac
               print'(i5,13x,5f10.6)',ngel+i,densvec(i,j:j+l-1)
            enddo
            do i=1+ninac+noac,norb
               if(any(densvec(i,j:j+l-1)>twdens))
     *         print'(i5,13x,5f10.6)',ngel+i,densvec(i,j:j+l-1)
            enddo
         enddo
         ! write Natural Orbital File
         call titre(' Analyse de Population : '//
     *   '#Orbitales Naturelles#',40)
         rewind ifNO
         call printNO_BaseOL
         rewind ifNO
         call printNO_BaseAt

      elseif (ms2/=0) then
         allocate(densvec(norb,nvec*2))
         densvec=0.d0
         do kvec=1,nvec
            read(38) densa,densb
            call hdiag_L(densa,workc,norb,norb)
            do i=1,norb
               densvec(i,kvec)=densa(i,i)
            enddo
            ! ecriture des ON et des occupations alpha
            write(ifNO) workc,densvec(:,kvec)
            call hdiag_L(densb,workc,norb,norb)
            do i=1,norb
               densvec(i,nvec+kvec)=densb(i,i)
            enddo
            ! ecriture des ON et des occupations beta
            write(ifNO) workc,densvec(:,nvec+kvec)
            rewind 38
            read(38) densa,densb
            densa=densa+densb
            call hdiag_L(densa,workc,norb,norb)
            ! ecriture des ON et des occupations alpha + beta
            write(ifNO) workc,(densa(i,i),i=1,norb)

         enddo
         call titre(' Analyse de Population : '//
     *   '#Occupation des orbitales naturelles#',40)
         do j=1,nvec,2
            l=2
            if(j+l-1>nvec) l=1
            print'(/,a,12x,i10,13x,i10)','   VECT',(/(ll,ll=j,j+l-1)/)
            if(l==2) then
               print*,'  OL                 alpha     beta',
     *         '         alpha     beta'
            else
               print*,'  OL                 alpha     beta'
            endif
            do i=1,ninac
               if(any(1.d0-densvec(i,j:j+l-1)>twdens)
     *         .or.(any(1.d0-densvec(i,j:j+l-1)>twdens)))
     *         print'(i5,13x,2(2f10.6,3x))',ngel+i,
     *         (densvec(i,kk)
     *         ,densvec(i,kk+nvec),kk=j,j+l-1)
            enddo
            do i=1+ninac,noac+ninac
               print'(i5,13x,2(2f10.6,3x))',ngel+i,
     *         (densvec(i,kk)
     *         ,densvec(i,kk+nvec),kk=j,j+l-1)
            enddo
            do i=1+ninac+noac,norb
               if(any(densvec(i,j:j+l-1)>twdens)
     *         .or.(any(densvec(i,j:j+l-1)>twdens)))
     *         print'(i5,13x,2(2f10.6,3x))',ngel+i,
     *         (densvec(i,kk)
     *         ,densvec(i,kk+nvec),kk=j,j+l-1)
            enddo
         enddo
         ! write Natural Orbital File
         call titre(' Analyse de Population : '//
     *   '#Orbitales Naturelles#',40)
         rewind ifNO
         call printNO_BaseOL
         rewind ifNO
         call printNO_BaseAt
      endif
      close (ifNO,status='delete')
      deallocate(tipo,densa,densb,workc,densvec,work1,work2,work3)
      close(38,status='delete')
      return
      contains
!************************************************************              
      subroutine printNO_BaseOL
      use mod_lirorb
      character(80) :: name_NO
      real(8),allocatable :: NO(:,:),wor1(:),wor2(:)
      real(8),allocatable :: occup(:)
      character(18),allocatable :: tipo2(:)
      character(8),allocatable :: label0(:)
      integer :: isym(8)
      character(100000) namel
      logical :: yw=.false.

      allocate(occup(norb),tipo2(norb))
      tipo2(1:norb)='  NatOrb'

      do i=1,nvec
         ! read NOs in LO basis and occupations of NOs
         if(ms2==0) then
            read(ifNO) workc,occup(1:norb)
         else
            allocate(wor1(norb),wor2(norb))
            read(ifNO)
            read(ifNO)
            read(ifNO) densa,wor1
            workc=densa
            occup(1:norb)=wor1
            deallocate(wor1,wor2)
         endif

         ! compute jdeb,jfin, 1st and last NOs with occupations far from
         ! 0 and 2
         jdeb=0
         if(yw)print*,'tipo',tipo
         if(yw)print*,'occup_OL',occup
         do j=1,norb
            if(abs(1.d0-occup(j))>0.99) cycle
            jdeb=j
            if(yw)print*,'jdeb,',jdeb,occup(j)
            exit
         enddo
         if(jdeb==0) jdeb=ninac
         jfin=0
         do j=jdeb+1,norb
            if(abs(1.d0-occup(j))>0.99) then
               jfin=j-1
               if(yw)print*,'jfin,',jfin,occup(j)
               exit
            endif
         enddo
         if(jfin==0) jfin=ninac+noac+1

         jdeb=max(jdeb-2,1)
         jfin=min(jfin+2,norb)
         n=jfin-jdeb+1

         ! print NOs if occupation is far from 0 and 2
         if(ms2==0) then
            print'(3a,i3)','Natural Orbitals in LO basis ',
     *      'for occupations far from 0 and 2:'
     *      ,'       vector',i
         else
            print'(3a,i3)','Natural Orbital (alpha + beta) in LO basis',
     *      ' for occupations',
     *      ' far from 0 and 2:     vector',i 
         endif
         print*,' '
         call scriptol (workc(:,jdeb:jfin),norb,n,norb,n,
     *   tipo(ngel+1:ngel+norb)(1:8),(/(i,i=ngel+jdeb,ngel+jfin)/),
     *   tipo2(jdeb:jfin),occup(jdeb:jfin))
         if(yw)call scriptol (workc,norb,norb,norb,norb,
     *   tipo(ngel+1:ngel+norb)(1:8),(/(i,i=1,norb)/),
     *   tipo2(1:norb),occup(1:norb))
      enddo
      deallocate(occup,tipo2)
      end subroutine
!************************************************************              
      subroutine printNO_BaseAt
      use mod_lirorb
      character(80) :: name_NO
      real(8),allocatable :: orb_ijkloc(:,:),NO(:,:),wor1(:),wor2(:)
      real(8),allocatable :: occup(:)
      character(18),allocatable :: tipo2(:)
      character(8),allocatable :: label0(:)
      integer :: isym(8)
      character(100000) namel
      logical :: yw=.false.

      ! build file name
      name_NO=trim(prefix)
      call append(name_NO,'NO_')
      l=len_trim(name_NO)

      ! read lewis local orbitals

      call lirorb('ORB_IJKLOC',noa,nsym,isym,98,99)
      allocate(orb_ijkloc(noa,noa))
      read(98) orb_ijkloc
      close(98,status='delete')
      close(99)
      
      ! Natural orbitals in AO basis set

      allocate(NO(noa,noa),occup(noa),tipo2(noa))

      ! copy frozen orbitals
      NO(:,1:ngel)=orb_ijkloc(:,1:ngel)
      occup(1:ngel)=2.d0
      tipo2(1:ngel)=tipo(1:ngel)
      ! copy deleted orbitals
      NO(:,ngel+norb+1:noa)=orb_ijkloc(:,ngel+norb+1:noa)
      occup(ngel+norb+1:noa)=0.d0
      tipo2(ngel+norb+1:noa)=tipo(ngel+norb+1:noa)
      !
      tipo2(ngel+1:ngel+norb)='  NatOrb'
      
      ! read atomic labels
      open(98,form='formatted',status='old',
     *file=trim(prefix)//'Infoloc')
      call LECNAM('&COST_AO',namel,98,ierr,0)
      allocate(label0(noa))
      call namela(namel,label0,'LABEL')
      close(98)

      do i=1,nvec
         ! read NOs in LO basis and occupations of NOs
         if(ms2==0) then
            read(ifNO) workc,occup(ngel+1:ngel+norb)
         else
            allocate(wor1(norb),wor2(norb))
            read(ifNO)
            read(ifNO)
            read(ifNO) densa,wor1
            workc=densa
            occup(ngel+1:ngel+norb)=wor1
            deallocate(wor1,wor2)
         endif

         ! compute NOs in atomic basis
         if(yw)print*,'orb_ijkloc'
         if(yw)call scriptol (orb_ijkloc(:,ngel+1:ngel+norb),
     *   noa,norb,noa,norb,
     *   label0,(/(i,i=1,norb)/),tipo(ngel+1:ngel+norb),
     *   occup(ngel+1:ngel+norb))
         if(yw)print*,'workc'
         if(yw)tipo2(ngel+1:ngel+norb)='workc'
         if(yw)call scriptol (workc,norb,norb,norb,norb,
     *   tipo(ngel+1:ngel+norb)(1:8),(/(i,i=1,norb)/),
     *   tipo2(1:norb),occup(1:norb))
         if(yw)tipo2(ngel+1:ngel+norb)='  NatOrb'
         NO(:,ngel+1:ngel+norb)=
     *   matmul(orb_ijkloc(:,ngel+1:ngel+norb),workc)

         ! end build file name
         write(name_NO(l+1:l+2),'(i2.2)') i
         
         ! compute jdeb,jfin, 1st and last NOs with occupations far from
         ! 0 and 2
         jdeb=0
         if(yw)print*,'occup',occup
         do j=1,noa
            if(abs(1.d0-occup(j))>0.99) cycle
            jdeb=j
            if(yw)print*,'jdeb,',jdeb,occup(j)
            exit
         enddo
         if(jdeb==0) jdeb=ninac
         jfin=0
         do j=jdeb+1,noa
            if(abs(1.d0-occup(j))>0.99) then
               jfin=j-1
               if(yw)print*,'jfin,',jfin,occup(j)
               exit
            endif
         enddo
         if(jfin==0) jfin=ninac+noac+1
         jdeb=max(jdeb-2,1)
         jfin=min(jfin+2,norb)
         n=jfin-jdeb+1

         ! write NOs, occ and labels on 98 to create ON file (created 
         !by ecriorb)
         open(98,form='unformatted',status='unknown',file='BIDECR')
         write(98) NO
         write(98) occup
         write(98) tipo2
         print*,' '

         ! print NOs if occupation is far from 0 and 2
         if(ms2==0) then
            print'(2a,i3)'
     *   ,'Natural Orbitals in AO basis '//
     *   'for occupations far from 0 and 2:'
     *      ,'       vector',i
         else
            print'(2a,i3)'
     *   ,'Natural Orbital (alpha + beta) in AO basis for occupations',
     *      ' far from 0 and 2:     vector',i 
         endif
         print*,' '
         call scriptol (NO(:,jdeb:jfin),noa,n,noa,n,
     *   label0,(/(i,i=jdeb,jfin)/),tipo2(jdeb:jfin),occup(jdeb:jfin))
         if(yw)call scriptol (NO,noa,noa,noa,noa,
     *   label0,(/(i,i=1,noa)/),tipo2(1:noa),occup(1:noa))
         isym(1)=noa
         call ecriorb('Casdiloc: Natural orbitals, vector '//
     *   name_NO(l+1:l+2),trim(name_NO),1,isym,98,99,newformat='YES')
         close(98)
      enddo
      deallocate(label0,NO,occup,tipo2,orb_ijkloc)
      end subroutine
!************************************************************              
      end subroutine
