      subroutine mixture(nmat,cccm)
      include 'dens.prm'
      implicit real*8 (a-h,o-x,z)
      implicit logical*1 (y)
      character*40 AAA
      common/info1/seuil,noc,norb,nao,nsym,itsym(norbz)
      common/info2/ywrn,ywrm,ywrll,ymolcas
      common/info3/const,coef(nmatz)
      common/gell/ngel(nsymz),ndel(nsymz)
      dimension nvecsym(nsymz),isyvid(norbz),itemp(norbz)
      dimension inuac(norbz),ocuac(norbz),isyac(norbz)
      dimension iocgel(norbz),isyocg(norbz),ividel(norbz)
      dimension cccm(norbz,norbz)
      dimension vecgel(norbz,norbz),vecdel(norbz,norbz)
      dimension raosm(norbz,norbz)
      dimension e(norbz),vecsym(norbz,norbz)
      dimension cccs(norbz*norbz),vs(norbz*norbz),es(norbz)
      dimension cmodens(norbz,norbz),vec(norbz)
      dimension cmodenm(norbz)
      dimension ns(norbz),npos(nsymz,norbz),np(norbz)
      dimension natsym(norbz),itso(nsymz),esym(nsymz,norbz)
2000  format(a40)
4000  format(4d18.12)
4001  format(3d18.12)
4002  format(2d18.12)
4003  format(1d18.12)
4010  format(A9,i5,i5)
4011  format(A14)
c
c--      test de convergence
c
      open(55,status='unknown',file='CONV')
      close(55,status='delete')
      tconv=0.d0
c
c     call script(cccm,norb,norb,norbz,norbz)
      do i=1,nsym
         nvecsym(i)=0
      enddo
      do i=1,norb
         isy=itsym(i)
         nvecsym(isy)=nvecsym(isy)+1
      enddo
c
c     Lectura OMS base MOLCAS
c
      if(ymolcas)then
         rewind(9)
         read(9,2000)AAA
         print*,AAA
         ik=0
         igel=0
         idel=0
         do k=1,nsym
            kgel=ngel(k)
            kdel=ndel(k)
            ncoef=nvecsym(k)+kgel+kdel
            nlin=ncoef/4
            irest=ncoef-nlin*4
            if(ncoef.ne.0)then
               do i=1,ncoef
                  read(9,2000)AAA
                  ncc=0
                  if(nlin.ne.0)then
                     do ii=1,nlin
                        read(9,4000)(vec(ncc+io),io=1,4)
                        ncc=ncc+4
                     enddo
                  endif
                  if(irest.eq.1)read(9,4003)(vec(ncc+io),io=1,irest)
                  if(irest.eq.2)read(9,4002)(vec(ncc+io),io=1,irest)
                  if(irest.eq.3)read(9,4001)(vec(ncc+io),io=1,irest)
                  if(irest.eq.4)read(9,4000)(vec(ncc+io),io=1,irest)
                  ncc=ncc+irest
                  if(i.le.kgel)then
                     igel=igel+1
                     do j=1,ncoef
                        vecgel(j,igel)=vec(j)
                     enddo
                  endif
                  if(i.gt.kgel.and.i.le.(ncoef-kdel))then
                     ik=ik+1
                     do j=1,ncoef
                        vecsym(j,ik)=vec(j)
                     enddo
                  endif
                  if(i.gt.(ncoef-kdel))then
                     idel=idel+1
                     do j=1,ncoef
                        vecdel(j,idel)=vec(j)
                     enddo
                  endif
               enddo
            endif
         enddo
         write(6,*)'                '
         write(6,*)'OMs ---- MOLCAS'
         write(6,*)'               '
         ii=0
         iig=0
         iid=0
         do i=1,nsym
            write(6,*)'OMs symmetry',i
            kgel=ngel(i)
            kdel=ndel(i)
            nve=nvecsym(i)+kgel+kdel
            if(kgel.ne.0)then
               do j=1,kgel
                  iig=iig+1
                  do k=1,nve
                     cmodens(k,j)=vecgel(k,iig)
                  enddo
               enddo
            endif
            do j=1,nve-kgel-kdel
               ii=ii+1
               do k=1,nve
                  cmodens(k,j+kgel)=vecsym(k,ii)
               enddo
            enddo
            if(kdel.ne.0)then
               do j=1,kdel
                  iid=iid+1
                  do k=1,nve
                     cmodens(k,j+nve-kdel)=vecdel(k,iid)
                  enddo
               enddo
            endif
            call escriu(cmodens,nve,nve)
            call flush(6)
         enddo
      endif
c
c     Crida a la diagonalitzacio
c     Diagonalitzacio per simetria
c
      do i=1,nsym
         ns(i)=0
      enddo
      do j=1,norb
         isy=itsym(j)
         ns(isy)=ns(isy)+1
         npos(isy,ns(isy))=j
      enddo
      nsy=0
      do i=1,nsym
         if(ns(i).ne.0)then
            nsy=nsy+1
            itso(nsy)=i
         endif
      enddo
      jvo=0
      jvv=noc
      ik=0
      jv=0
      ijpos=0
      igelpos=0
      idelpos=0
      rewind 8
      AAA='* OMs OPTIMITZATS IDDCI'
      write(8,2000)AAA
      do ii=1,nsy
         ijs=0
         isym=itso(ii)
         nss=ns(isym)
         do ioo=1,nss
            do joo=1,ioo
               ijoo=ioo*(ioo-1)/2+joo
               cccs(ijoo)=-cccm(npos(isym,ioo),npos(isym,joo))
               raosm(ioo,joo)=cccm(npos(isym,ioo),npos(isym,joo))
               raosm(joo,ioo)=cccm(npos(isym,ioo),npos(isym,joo))
            enddo
         enddo
c     Escritura matriu densitat suma per simetria
         rsing=0.
         do i=1,nss
            rsing=raosm(i,i)+rsing
         enddo
         do i=1,nss
            np(i)=npos(isym,i)
         enddo
         if (ywrm) then
            write(6,*)' Density Matrix of symmetry  ', isym
            call escriu2(raosm,nss,nss,np)
         endif
         if (rsing.eq.0) then
            ij=0
            do i1=1,nss
               es(i1)=0.
               do j1=1,nss
                  ij=ij+1
                  vs(ij)=0.
                  if (i1.eq.j1) vs(ij)=1.
               enddo
            enddo
            goto 77
         endif
c
         call eigen(cccs,vs,nss,0,1)
         do ioo=1,nss
            es(ioo)=cccs(ioo*(ioo+1)/2)
         enddo
c     Escritura opcional orbitals naturals base molecular per simetria
77       continue
         ij=0
         do il=1,nss
            do j=1,nss
               ij=ij+1
               cmodens(j,il)=vs(ij)
            enddo
         enddo
c
c--      test de convergence
c
         do il=1,nss
            cmodenm(il)=0.d0
            do j=1,nss
               cmodenm(il)=max(cmodenm(il),dabs(cmodens(j,il)))
            enddo
         enddo
         do kconv=1,nss
            tconv=max(tconv,dabs(cmodenm(kconv)-1))
         enddo
         print*,'conv',(cmodenm(kkk),kkk=1,nss)
         if (ywrn) then
            write(6,*)'Natural OMs molecular basis symmetry ',isym
            call escriu2(cmodens,nss,nss,np)
         endif
c
c
c Transformacio a base original
c
         if(ymolcas)then
c
c Transformacio a base MOLCAS
c
            kgel=ngel(isym)
            kdel=ndel(isym)
            nss=nvecsym(isym)+kgel+kdel
            if(kgel.ne.0)then
               do j=1,kgel
                  esym(isym,j)=2.0D+00
                  do k=1,nss
                     vec(k)=vecgel(k,igelpos+j)
                  enddo
                  write(8,4010)'* ORBITAL',isym,j
                  write(8,4000)(vec(io),io=1,nss)
               enddo
               igelpos=igelpos+kgel
            endif
            if(rsing.ne.0)then
               nss=nvecsym(isym)
               ncoef=nss+ngel(isym)+ndel(isym)
               do j=1,nss
                  if (npos(isym,j).le.noc) then
                     jvo=jvo+1
                     jv=jvo
                  else
                     jvv=jvv+1
                     jv=jvv
                  endif
                  e(jv)=-es(j)/const
                  natsym(jv)=isym
                  esym(isym,j+kgel)=-es(j)/const
                  do ioo=1,ncoef
                     vec(ioo)=0.D+00
                  enddo
                  do jk=1,ncoef
                     do k=1,nss
                        vec(jk)=vec(jk)+vecsym(jk,ijpos+k)*
     *                  cmodens(k,j)
                     enddo
                  enddo
                  write(8,4010)'* ORBITAL',isym,j+kgel
                  write(8,4000)(vec(io),io=1,ncoef)
               enddo
               ijpos=ijpos+nss
            else
               write(6,*)' rsing',rsing
               nss=nvecsym(isym)
               ncoef=nss+ngel(isym)+ndel(isym)
               do j=1,nss
                  if(npos(isym,j).le.noc) then
                     jvo=jvo+1
                     jv=jvo
                     e(jv)=2.0D+00
                     esym(isym,j+kgel)=2.0D+00
                  else
                     jvv=jvv+1
                     jv=jvv
                     e(jv)=0.0D+00
                     esym(isym,j+kgel)=0.0D+00
                  endif
                  natsym(jv)=isym
                  do k=1,ncoef
                     vec(k)=vecsym(k,ijpos+j)
                  enddo
                  write(8,4010)'* ORBITAL',isym,j+kgel
                  write(8,4000)(vec(io),io=1,ncoef)
               enddo
               ijpos=ijpos+nss
            endif
            kdel=ndel(isym)
            nss=nvecsym(isym)+kgel+kdel
            if(kdel.ne.0)then
               do j=1,kdel
                  esym(isym,j+nvecsym(isym)+ngel(isym))=0.0D+00
                  do k=1,nss
                     vec(k)=vecdel(k,idelpos+j)
                  enddo
                  write(8,4010)'* ORBITAL',isym,j+nvecsym(isym)+ngel(isy
     &            m)
                  write(8,4000)(vec(io),io=1,nss)
               enddo
               idelpos=idelpos+kdel
            endif
         endif
      enddo
c
c--      test de convergence
c
      write(6,'('' CONVERGENCE DES ORBITALES NATURELLES '',
     *''  seuil, conv'',2d13.4)') seuil,tconv
      if(tconv.lt.seuil)then
         print*,'CONVERGENCE'
         open(55,status='new',file='CONV')
      endif
c
      AAA='* OCCUPATION NUMBERS   '
      write(8,2000)AAA
      do ioo=1,nsym
         nss=nvecsym(ioo)+ngel(ioo)+ndel(ioo)
         if(nss.ne.0)then
            write(8,4000)(esym(ioo,koo),koo=1,nss)
         endif
      enddo
      write(6,*)' '
      write(6,*)' Occupation Numbers  '
      write(6,*)' '
      write(6,8800) (e(i)/const,i,natsym(i),i=1,norb)
8800  format ((2x,4(f9.6,1x,i4,1x,i3,2x)))
c
c analisi de les ocupacions
c
      actiu1=.2
      actiu2=1.8
      ocugel=1.9999
      virdel=.00001
      nact=0
      nocugel=0
      nvirdel=0
      do i=1,norb
         ocu=e(i)/const
c
c        mirem les ocupacions dels actius
c
         if(ocu.ge.actiu1.and.ocu.le.actiu2)then
            nact=nact+1
            inuac(nact)=i
            ocuac(nact)=ocu
            isyac(nact)=natsym(i)
         endif
c
c        mirem els ocupats que es poden gelar
c
         if(ocu.ge.ocugel)then
            nocugel=nocugel+1
            iocgel(nocugel)=i
            isyocg(nocugel)=natsym(i)
         endif
c
c        mirem els virtuals que es poden eliminar
c
         if(ocu.le.virdel)then
            nvirdel=nvirdel+1
            ividel(nvirdel)=i
            isyvid(nvirdel)=natsym(i)
         endif
      enddo
      write(6,*)
      write(6,*) "--------------------------------------------------"
      write(6,*) "             Orbital Occupation Analisis"
      write(6,*) "--------------------------------------------------"
      write(6,*) " ============== "
      write(6,*) " Active Orbitals "
      write(6,*) " ============== "
      write(6,8801)
8801  format (2x,' Orbital Number        Occupation        Symmetry ')
8802  format (6x,i4,16x,1f8.5,10x,i3)
8803  format (6(1x,i5))
      do i=1,nact
         write(6,8802) inuac(i),ocuac(i),isyac(i)
      enddo
      if(nocugel.gt.0)then
         write(6,*) " ============== "
         write(6,*) " Frozen Orbitals "
         write(6,*) " ============== "
         do i=1,nsym
            nsso=0
            do j=1,nocugel
               if(isyocg(j).eq.i)then
                  nsso=nsso+1
                  itemp(nsso)=iocgel(j)
               endif
            enddo
            if(nsso.gt.0)then
               write(6,*)"  Simmetry ",i," total ",nsso
               write(6,8803)(itemp(ik),ik=1,nsso)
            endif
         enddo
      endif
      if(nvirdel.gt.0)then
         write(6,*) " ============== "
         write(6,*) " Delete Orbitals "
         write(6,*) " ============== "
         do i=1,nsym
            nsso=0
            do j=1,nvirdel
               if(isyvid(j).eq.i)then
                  nsso=nsso+1
                  itemp(nsso)=ividel(j)
               endif
            enddo
            if(nsso.gt.0)then
               write(6,*)"  Simmetry ",i," total ",nsso
               write(6,8803)(itemp(ik),ik=1,nsso)
            endif
         enddo
      endif
      return
      end
