c ******************************************************************
c ***                                                            ***
c ***                  Universitat Rovira i Virgili              ***
c ***                     Departament de Química                 ***
c ***                     Àrea de Química-Física                 ***
c ***  written by                                                ***
c ***             Oscar Castell Marcos & Victor Manuel García    ***
c ***                                                            ***
c ***    castells at quimica.urv.es                              ***
c ***    garcia at quimica.urv.es                                ***
c ***                                                            ***
c ******************************************************************
      program naturals
      implicit real*8 (a-h,o-x,z),logical*1(y)
      include 'dens.prm'
      character*10000 namel
      common/info0/nsym
      common/info1/seuil,noc,norb,nao,nsyme,itsym(norbz)
      common/info2/ywrn,ywrm,ywrll,ymolcas
      common/info3/const,coef(nmatz)
      common/gell/ngel(nsymz),ndel(nsymz)
      dimension denss(norbz,norbz)
      dimension dens(norbz,norbz)
      dimension its(8,8)
      common/mxdat/nmat,metat(nmatz),
     *               nmdps(nmatz),ywr
      !namelist /cost_ao/nsym,norb,noc,itsym,its,enuc,ycl
      !namelist /cost_mo/nsym,norb,noc,itsym,its,enuc,ycl
      yw=.false.
      ywr=.false.
      ywrm=.true.
      ywrn=.true.
      ywrll=.false.
      ysciel=.false.
      ymolcas=.true.
      ycasdi=.false.
      seuil=1.d-4
      nmat=1
      coef(1)=1.
      metat(1)=1
cpc     call hola
      do i=1,nsymz
         ngel(i)=0
      enddo
      do i=2,nmatz
         coef(i)=0.
         metat(i)=1
      enddo
      do i=1,norbz
         do j=1,norbz
            denss(i,j)=0.d+00
         enddo
      enddo
      const=1.
      call openf
      do i=1,nmat
        if (metat(i).eq.0) then
           write(6,*) 'Quin es el estat per la matriu',i
           stop
        endif
      enddo
cpc      read(40) nsyme,norb,noc,ndum,(itsym(i),i=1,norb),nao
      !namelist /cost_mo/nsym,norb,noc,itsym,its,enuc,ycl
      !nsym2=nsym
      rewind 40
      call LECNAM('&COST_AO ',namel,40,ierr,1)
      call nameli(namel,ITS,'ITS',4)
      call LECNAM('&COST_MO ',namel,40,ierr,1)
      call nameli(namel,nsyme,'NSYM',4)
      call nameli(namel,NORB,'NORB',4)
      call nameli(namel,NOC,'NOC',4)
      call nameli(namel,ITSYM,'ITSYM',4)
      !read(40,cost_mo)
      !nsyme=nsym
      !nsym=nsym2
        if(nao.eq.0) nao=norb
      nmt=0
      ifilo=61
      print*,'nsym',nsym
      do ifil=1,nsym
         ifilo=ifilo+1
         rewind(ifilo)
         do i=1,metat(ifil)
            nmt=nmt+1
            jk=0
            read(ifilo)((dens(io,jo),io=1,norb),jo=1,norb)
            if(yw) then
               print*,'mat densite lue, numero',ifil,i
               call script(dens,norb,norb,norbz,norbz)
            endif
            do j=1,norb
               do k=1,norb
                  denss(j,k)=denss(j,k)+coef(nmt)*dens(j,k)
               enddo
            enddo
         enddo
      enddo
      if(yw) then
         print*,'mat densite moyenne'
         call script(denss,norb,norb,norbz,norbz)
      endif
      call mixture(nmt,denss)
      stop
      end
