      program LOCNAT
      use mod_lirorb
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter (maxorbcas=16,maxsym=8,maxet=100)

      allocatable itype(:),itsym(:),ii(:)
      allocatable v(:,:)
      allocatable s(:,:)
      character(8),allocatable :: orbi(:),label(:)
      allocatable occupv(:),occup1(:)
      allocatable iordo(:),iorda(:),iordv(:)
      character(18),allocatable :: tipo(:),tipo1(:)
      allocatable yac(:),yacs(:,:)
      dimension noacs(maxsym)
      dimension numac(maxorbcas)
      
      character*10000 namel,namel1
      character*80 blan,dfil,aa,orbn,orbv,prefix
      character*300 dens1,info1,dens,info,densmat(maxet),mono,mono1
      character*8 cl
!      common/orb/orbi
      common/sym/nsym,isym(maxsym),is,nocc,nact,nocs(maxsym)
      common /data/thr,maxit,nprint,yverif
      dimension ndel(maxsym),ngel(maxsym)
      character*8 progr
      dimension y(maxet)
      dimension iacs(maxsym)
      common/prog/progr
      dimension netat(maxet),metat(maxet),coef(maxet)
      dimension noaco(maxsym),noacv(maxsym)
      integer fermi(maxsym)
      common /nor/norb0
      double precision,dimension(:,:),allocatable :: denst,denss
      namelist /locn/ norb,dfil,orbv,orbn,
     *netat,metat,coef,nmat,noac,numac
      yw=.false.
      print*,'#       #######  #####  #     #    #    #######  #####  '
      print*,'#       #     # #     # ##    #   # #      #    #     # '
      print*,'#       #     # #       # #   #  #   #     #    #       '
      print*,'#       #     # #       #  #  # #     #    #     #####  '
      print*,'#       #     # #       #   # # #######    #          # '
      print*,'#       #     # #     # #    ## #     #    #    #     # '
      print*,'####### #######  #####  #     # #     #    #     #####  '
      blan=' '
      dfil=blan
      thr=1.d-12
      maxit=100
      nprint=0
      yverif=.false.
      seuil=1.d-6
      yhier=.true.
      yreloc=.true.
      alpha=1.d0
c
      print*,'------------------------------------------------------'
      print*,'    ---LOCNATS---                            '
      print*,'diagonalisation de la mat densite -->  orb naturelles ON'
      print*,'diagonalisation de la mat densite diagonalisee par blocs'
      print*,'-->   orb naturelles par blocs  ONB                     '
      print*,'orbitales atomiques     OA                              '
      print*,'orbitales localisees (orthogonalisees)  OAO             '
      print*,'(Elles sont lues de SMUD)                               '
      print*,'             '
      print*,'             '
      print*,'------------------------------------------------------'
      open(12)       
      open(13)       
      densmat(1:maxet)(1:300)=' '
      prefix=' '
      dens='dens'
      dens1=' '
      mono='Mono'
      mono1=' '
      info='Info'
      info1=' '
      ndel=0 ; ngel=0
      nmat=1
      noac=-1
      y_noac_en_donnee=.true.
      cl='O-A-V'
      call LECNAM('&LOCN',namel,5,ierr,1)
      call namela(namel,DENS1,'DENS1')
      call namela(namel,ORBV,'ORBV')
      call namela(namel,ORBN,'ORBN')
      open(2,status='unknown',form='formatted',file=ORBN)
      call namela(namel,CL,'CL')
      call namela(namel,DENSMAT,'DENSMAT')
      call nameli(namel,NMAT,'NMAT',4)
      call nameli(namel,NOAC,'NOAC',4)
      if(noac.eq.-1) then
         y_noac_en_donnee=.false.
         noac=0
      endif
      numac(1:noac)=0
      call nameli(namel,NUMAC,'NUMAC',4)
      netat(1:nmat)=1
      call nameli(namel,NETAT,'NETAT',4)
      netatot=sum(netat(1:nmat))
      metat(1:netatot)=1
      call nameli(namel,METAT,'METAT',4)
      coef(1:netatot)=1.d0
      call nameld(namel,coef,'COEF',8)
      call namell(namel,YHIER,'YHIER',1)
      call namell(namel,YRELOC,'YRELOC',1)
      call nameld(namel,ALPHA,'ALPHA',8)
!     test sur le nombre d'etats
      if(maxet<netatot) then
         print*,'trop d''etats, augmenter maxet. netatot,maxet=',
     *   netatot,maxet
         stop
      endif
      if(noac.ne.0) then
         if(numac(1).eq.0) then 
            print*,'noac /=0   il faut donner numac'
            stop
         endif
      endif
      call namela(namel,PREFIX,'PREFIX')
      call namela(namel,DENS,'DENS')
      call namela(namel,INFO,'INFO')
      call namela(namel,MONO,'MONO')
      ll=len_trim(prefix)
      if(densmat(1).ne.' ') dens1=densmat(1)
      if(dens1.eq.' ') dens1=prefix(1:ll)//dens
      info=prefix(1:ll)//info
      call namela(namel,INFO1,'INFO1')
      call namela(namel,MONO1,'MONO1')
      call nameli(namel,NPRINT,'NPRINT',4)
      call nameli(namel,MAXIT,'MAXIT',4)
      call nameli(namel,NDEL,'NDEL',4)
      call nameli(namel,NGEL,'NGEL',4)
      call nameld(namel,SEUIL,'SEUIL',8)
      if(index(namel,'FERMI=')==0) then
         open(11,file='SCH_FERMI',status='old',err=3)
         goto 4
         call LECNAM('&FERM',namel,11,ierr,1)
         call nameli(namel,FERMI,'FERMI',4)
 3       continue
         print*,
     *   'fichier SCH_FERMI absent, il faut donner FERMI en donnee'
         stop
 4       continue
      endif
      call nameli(namel,FERMI,'FERMI',4)
      close(11)
      print*,'fermi',fermi
      print*,'seuil',seuil
      if(info1.eq.' ')call colle(prefix,'Info',info1,long) 
      !print*,'info1',info1
      open(8,status='old',form='formatted',file=info1)
      if(mono1.eq.' ')call colle(prefix,'Mono',mono1,long) 
      !print*,'mono1',mono1
      open(9,status='old',form='unformatted',file=mono1)
c      open(3,status='old',form='unformatted',file='S')       
!      if(.not.y_noac_en_donnee)
!     *open(4,status='old',form='unformatted',file='S2')       
      call LECNAM('&COST_AO',namel,8,ierr,0)
      call nameli(namel,nsym,'NSYM',4)
      call nameli(namel,isym(1),'ISYM',4)
      norb0=sum(isym(1:nsym))
!     allocations
      allocate(itype(norb0),itsym(norb0),ii(norb0))
      call nameli(namel,ITYPE,'ITYPE',4)
      allocate(v(norb0,norb0))
      allocate(s(norb0,norb0))
      allocate(orbi(norb0),label(norb0))
      allocate(occupv(norb0+1),occup1(norb0))
      allocate(iordo(norb0),iorda(norb0),iordv(norb0))
      allocate(tipo(norb0),tipo1(norb0))
      allocate(yac(norb0),yacs(norb0,maxsym))
      call scarre(s,v)
      rewind 8
      call LECNAM('&COST_MO',namel1,8,ierr,0)
      call nameli(namel,nsym,'NSYM',4)
      call nameli(namel,isym(1),'ISYM',4)
      call nameli(namel1,itsym(1),'ITSYM',4)
      call nameli(namel1,noc,'NOC',4)
      call namela(namel,label,'LABEL')
!!      read(4) nsym,isym(1:nsym)
      !print*,'nsym',nsym
      !print*,'isym',isym
!      if(.not.y_noac_en_donnee.and.yhier) read(4)
      
      !write(75,locn)
c      call scrinam('NAMELIST LOCN  ')
c
c------------------------------------------------
c     matrice densite moyenne : lect des donnees
c------------------------------------------------
c
      print*,('-',i=1,60)
      print*,'Nombre de fichiers de Matrices Densite',nmat
      print*,' '
      jfin=0
      do k=1,nmat
         jdeb=jfin+1
         jfin=jdeb+netat(k)-1
         write(namel,'(a5,i3,a9,i3,a2)')
     *   ' Mat:',k,' | netat=',netat(k),' |'
         ifin=22
         ideb=ifin+1
         ifin=ifin+netat(k)*4+7
         write(namel(ideb:ifin),'(a7,20i4)')
     *   ' metat=',(metat(l),l=jdeb,jfin)
         ideb=ifin+1
         ifin=ideb+netat(k)*6-1+8
         write(namel(ideb:ifin),'(a8,20f6.2)')
     *   ' | coef=',(coef(l),l=jdeb,jfin)
         long=len_trim(densmat(k))
         ideb=ifin+1
         ifin=ideb+long+2
         write(namel(ideb:ifin),'('' | '',a)')
     *   densmat(k)(1:long)
         kfin=0
         do kk=1,ifin,75
            kdeb=kfin+1
            kfin=min(kdeb+74,ifin)
            print*,namel(kdeb:kfin)
         enddo
      enddo
      print*,('-',i=1,60)
c     normalisation
      anor=0.d0
      do k=1,jfin
         anor=anor+dabs(coef(k))
      enddo
      coef(1:jfin)=coef(1:jfin)/anor
      jetat=jfin
      if(jetat.ne.1.and.densmat(1).eq.' ') then
         print*,'s''il y a plus d''un etat, il faut donner',
     *   ' les noms des fichiers de matrices densite'
         stop
      endif

c----------------------------------------------
c     calcul du nombre d'orbitales, allocations
c----------------------------------------------
      norbgd=norb0-sum(ngel(1:nsym))-sum(ndel(1:nsym))
      print*,'dimension de la base',norbgd
c---------------------------------------
c     lecture de la mat densite
c---------------------------------------
      allocate (denst(norbgd,norbgd))
      allocate (denss(norbgd,norbgd))
      print*,'nmat,netat',nmat,netat(1:nmat)
      if(jetat.eq.1) then
         open(63,status='old',form='unformatted',file=dens1)
         read(63) denst
      else
         kkk=0
         denst=0.d0
         do kmat=1,nmat
            open(63,status='old',form='unformatted',
     *      file=densmat(kmat))
!            print'(a,i3,a,i3,a)',
!     *      'matrice densite lue (dans la base des OL) mat numero',kmat
            do ket=1,netat(kmat)
               read(63) denss
               print'(a,i3,a,i3,a)',
     *         'matrice densite lue (dans la base des OL)'
     *         //'  (matrice numero',kmat,'     etat',metat(ket),')'
               do k1=1,norbgd,10
                  print'(i4,10f8.4)',k-1,
     *            (denss(kk,kk),kk=k1,min(k1+9,norbgd))
               enddo
               denst=denst+denss*coef(ket)
            enddo
         enddo
      endif
               
      deallocate (denss)
      print*,'Matrice densite moyenne (dans la base des OL)'
      if(nprint.eq.0) then
         do k=1,norbgd,10
            print'(i4,10f8.4)',k-1,(denst(kk,kk),kk=k,min(k+9,norbgd))
         enddo
      else
         call script6(denst,norbgd,norbgd,norbgd,norbgd)
      endif
c-----------------------------------------------------
c     occupations et labels des anciennes orbitales
c-----------------------------------------------------
      call lirorb(ORBV,norb,nsym,isym,11,1,noaco=noaco,noacv=noacv,
     *fermi0=fermi)
      print'(a,16i4)','noaco',noaco(1:nsym)
      print'(a,16i4)','noacv',noacv(1:nsym)
      print'(a,16i4)','fermi',fermi(1:nsym)
      do is=1,nsym
         if(isym(is)==0) cycle
         read(11)
      enddo
      kk=0
      do is=1,nsym
         if(isym(is)==0) cycle
         read(11) occupv(kk+1:kk+isym(is))
         kk=kk+isym(is)
      enddo

      ylabel=.false.
      rewind(11)
      do is=1,nsym
         if(isym(is)==0) cycle
         read(11)
      enddo
      do is=1,nsym
         if(isym(is)==0) cycle
         read(11)
      enddo
      kk=0
      tipo=' '
      do is=1,nsym
         if(isym(is)==0) cycle
         read(11,end=2) tipo(kk+1:kk+isym(is))
         kk=kk+isym(is)
         ylabel=.true.
      enddo
 2    continue
 1000 format(a80)
      rewind 11
      aaa=0.d0
      nd2=0
c
c-----------------------------------------------------
c     on retrouve les numeros des orbitales
c-----------------------------------------------------
c
      nocs=0
      noacs=0
      yacs=.false.
      yac(1:norbgd)=.false.
      yac(numac(1:noac))=.true.
      if(y_noac_en_donnee) nact=noac
      iacs=0
      do k=1,norbgd
         iacs(itsym(k))=iacs(itsym(k))+1
         if(yac(k)) yacs(iacs(itsym(k)),itsym(k))=.true.
         if(yac(k)) then
            noacs(itsym(k))=noacs(itsym(k))+1
         endif
      enddo
      do k=1,noc
         if(.not.yac(k)) then
            nocs(itsym(k))=nocs(itsym(k))+1
         endif
      enddo 
C      eee=0.d0
C      do k=1,norbgd
C         do l=1,norbgd
C            if(k==l) cycle
C            eeee=eee
C            eee=max(eee,abs(denst(k,l)))
C            if(eeee/=eee) print'(a,2i4,2f14.8,2i4)',
C     *      'DIFF',k,l,eeee,eee,itsym(k),itsym(l)
C         enddo
C      enddo
       
      do is=1,nsym
         eee=0.d0
         ndims=0
         do k=1,norbgd
            if(itsym(k).eq.is) then
               ndims=ndims+1
               ii(ndims)=k
            endif
         enddo
         norbgds=ndims
         norbs=ndims+ngel(is)+ndel(is)
         if(isym(is).eq.0) cycle
         nd1=nd2+1
         nd2=nd1+isym(is)-1
!        rewind 3
!        do k=1,3*(is-1)
!           read(3)
!        enddo
!        read(3) ndimsng       
!        read(3)
!        read(3) orbi(1:ndimsng)       
         ndimsng=isym(is)
         orbi(1:ndimsng)=label(nd1:nd2)
         
         if(.not.y_noac_en_donnee.and.yhier)then
!            read(4) nocc,nact
             nocc=fermi(is)-noaco(is)
             if(yw)print*,'is,fermi(is),noaco(is),nocc',
     *       is,fermi(is),noaco(is),nocc
             nact=noaco(is)+noacv(is)
         endif
         if(yw)print'(a,l2)','yhier',yhier
         if(yw)print*,'nocc,nact',nocc,nact
         noccg=nocc-ngel(is)
         if(noccg.lt.0) then
c           alors on a gele des actives
            noccg=0
         endif
c        cas noac.ne.0
         if(y_noac_en_donnee) then
            noccg=nocs(is)
            nocc=noccg+ngel(is)
            nact=noacs(is)
            norda=0
            nordo=0
            nordv=0
            call flush(6)
            do k=1,norbgds
               if(yacs(k,is)) then
                  norda=norda+1
                  iorda(norda)=k
       write(6,*)'norda,iorda(norda)',norda,iorda(norda)
               else
                  if(nordo.lt.noccg)then
                     nordo=nordo+1
                     iordo(nordo)=k
       write(6,*)'nordo,iordo(nordo)',nordo,iordo(nordo)
                  else
                     nordv=nordv+1
                     iordv(nordv)=k
                  endif
               endif
            enddo
C            do k=noccg+1,norbgds
C               if(yacs(k,is)) then
C                  norda=norda+1
CC                  iorda(norda)=k
C               else
C                  nordv=nordv+1
C                  iordv(nordv)=k
C               endif
C            enddo
         else
            iordo(1:noccg)=(/(i,i=1,noccg)/)
            iorda(1:nact)=(/(i,i=noccg+1,noccg+nact)/)
            iordv(1:norbgds-nact-noccg)=(/(i,i=nact+noccg+1,norbgds)/)
         endif
            call flush(6)
         nvird=norbgds-nact-noccg
c--------------------------------------
c        matrice densite de symetrie is
c--------------------------------------
         allocate (denss(ndims,ndims))
         denss=denst(ii(1:ndims),ii(1:ndims))
         if(nsym.ne.1.and.nprint.ge.1) then
            print*,'matrice densite lue  sym',is
            call scripto(denss,ndims,ndims,ndims,ndims,orbi)
         endif
         if(yhier) then
            if(cl.eq.'O-A-V') then
c               itype(1:noccg)=1
c               itype(1+noccg:noccg+nact)=2
c               itype(1+noccg+nact:norbgd)=3
               if(yw)write(6,*)'noccg,io',noccg,iordo(1:noccg)
               call flush(6)
               itype(iordo(1:noccg))=1
               itype(iorda(1:nact))=2
               itype(iordv(1:nvird))=3
            else if (cl.eq.'FERMI') then
               itype(1:nocs(is))=1
               itype(nocs(is)+1:norbgd)=2
            else if (cl.eq.'OA-V') then
c               itype(1:noccg+nact)=1
c               itype(noccg+nact+1:norbgd)=2  
               itype(iordo(1:noccg))=1
               itype(iorda(1:nact))=1
               itype(iordv(1:nvird))=2
            else
               print*,'cl=',cl,' valeur non existente'
               stop
            endif
         endif
         print*,'ndims=',ndims
         print*,' '
         print*,'************************************'
         print'(a,i3,a)',' *           SYMETRIE',is,'            *'
         if(yhier) then
         print*,'*            CLASSES               *'
         print'('' *        Cl= '',a8,''              *'')',cl
         print'('' *      Itype'',20(10i2,''   *'',/
     *   ,'' *           '' ))'
     *   ,itype(1:ndims)
         endif
         print*,'************************************'
         print*,' '
c        valeur max extradiagonale
         !print*,'denst(46,55)',denst(46,55)
         do i=1,ndims
            do j=1,i-1
               eeee=eee
               if(itype(i).ne.itype(j)) eee=max(eee,dabs(denss(i,j)))
               !if(eee/=eeee)print*,'changement eee',is,i,j
            enddo
         enddo
         print*,'mat densite  valeur max hors mat block diag',eee
         print*,' '
         if(nprint.ge.4)print*,'is,norbgds ',is,norbgds
         call locnat1(aaa,seuil,denss,ORBV,ORBN,norbs,
     *   ngel,ndel,ITYPE,v,s,norbgds,yhier,noaco,noacv,orbi,yreloc
     *   ,alpha)
         denst(ii(1:ndims),ii(1:ndims))=denss
         write(12,1001) occupv(nd1:nd1+ngel(is)-1)
     *   ,(denss(i,i),i=1,ndims)
     *   ,occupv(nd2-ndel(is)+1:nd2)
         print*,' '
c        print'(a,i3)','occupations symetrie',is
c        write(6,'(20(14x,10f8.4,/))') occupv(nd1:nd1+ngel(is)-1)
c    *   ,(denss(i,i),i=1,ndims)
c    *   ,occupv(nd2-ndel(is)+1:nd2)
c        print*,' '
c        print'(a,i3)','labels symetrie',is
        write(13,'(4a18)') tipo(nd1:nd2)
c        write(6,'(20(14x,10a8,/))') tipo(nd1:nd2)
         if(yw)write(6,1001) occupv(nd1:nd1+ngel(is)-1)
     *   ,(denss(i,i),i=1,ndims)
     *   ,occupv(nd2-ndel(is)+1:nd2)


         ii(1+ngel(is):ndims+ngel(is))=ii(1:ndims)
         ii(1:ngel(is))=0
         ii(ndims+ngel(is)+1:norbs)=0
         tipo1(1+ngel(is):ndims+ngel(is))=tipo(nd1:nd2)
         tipo1(1:ngel(is))='  G   '
         tipo1(ndims+ngel(is):norbgds)='  D   '
         occup1(1:norbs)=(/occupv(nd1:nd1+ngel(is)-1),
     *   (denss(i,i),i=1,ndims),occupv(nd2-ndel(is)+1:nd2)/)
         print*,'orbitales "naturelles" dans la base des orb atomiques'
         print*,'symetrie',is,'   (nouvelles orbitales)'
         print*,'TIPO',TIPO
         call scriptol(v,norbs,norbs,norbs,norbs,orbi,ii,
     *   tipo(nd1:nd2),occup1)
c         write(12,1001)(2.d0,i=1,ngel(is)),(denss(i,i),i=1,ndims)
c     *   ,(0.d0,i=1,ndel(is))
c         if(yw)write(6,1001)(2.d0,i=1,ngel(is)),(denss(i,i),i=1,ndims)
c     *   ,(0.d0,i=1,ndel(is))
 1001    format(4D18.12)
c         print'(14x,10f8.4)',(denss(k,k),k=1,ndims)
         deallocate (denss)
      enddo
      print*,' '
      print'(2(a,d10.4),a)','E_CONV  ',aaa,'    (seuil=',seuil,')'
      open(22,status='unknown',file='LOCNAT_CONV')
c      write(22,*) aaa
C      aaa=eee*eee
      write(22,*) aaa
      close(22)
      if(aaa.lt.seuil) then
         open(22,status='unknown',file='CONV')
         print*,'CONVERGENCE'
         close(22)
      endif
      rewind 12
      write(2,'(a20)') '* OCCUPATION NUMBERS'
      do
         read(12,1000,end=12) aa
         write(2,1000) aa
         if(yw)write(6,1000) aa
      enddo
 12   continue
      if(ylabel) then
         rewind 13
         write(2,'(a8)') '* LABELS'
         do
            read(13,1000,end=13) aa
            write(2,1000) aa
         enddo
      endif
 13   continue
      end
       subroutine locnat1
     *(aaa,seuil,dens,ORBV,ORBN,NORB,mgel,mdel,ITYPE,v,s,norbgd,yhier
     *,noaco,noacv,orbi,yreloc,alpha)
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter (maxsym=8)
      double precision,dimension(:,:),allocatable :: old_lo,s1,
     *onb,UT_on_onb,on,s12,on12
      double precision,dimension(:),allocatable :: vec1
      integer,dimension(:),allocatable :: iord
      character*8 progr
      common/prog/progr
      dimension itype(norb)
      dimension v(norb,norb),s(norb,norb)
      character*80 blan,dfil,aa,orbn,orbv
      common /data/thr,maxit,nprint,yverif
      common /nor/norb0
      character*8 orbi(norb0)
!      common/orb/orbi
      common/sym/nsym,isym(maxsym),is,nocc,nact,nocs(maxsym)
      dimension mdel(maxsym),mgel(maxsym)
      dimension dens(norbgd,norbgd)
      dimension noaco(nsym),noacv(nsym)

      yw=.false.
      ngel=mgel(is)
      ndel=mdel(is)
      if(nprint.ge.3)print*,'norbgd',norbgd
      idebg=ngel+1
      ifind=norb-ndel
c      itype(1:norbgd)=itype(ngel+1:norb-ndel)
      allocate (old_lo(norb,norb))
      allocate (s1(norbgd,norbgd))
      allocate (onb(norbgd,norbgd))
      allocate (on(norbgd,norbgd))
      allocate (UT_on_onb(norbgd,norbgd))
      allocate (vec1(norbgd))
      allocate (iord(norbgd))

!######################################################
! DIAGONALISE DENSITY MATRIX
! (dens mat: dens, eigenvectors: on)
! (on = Natural orb, are NOT local!)
! all written in basis of LO's
!######################################################
c---------------------------------------
      call jacobi(norbgd,dens,on,norbgd)
      !call reor_on(norbgd,itype,on,vec1,dens,old_lo,s(:,1),yhier)
      if(nprint.ge.2) then
         write (6,*)
         write (6,*) ' valeurs propres de la matrice densite'
         print'(10f8.4)',(dens(k,k),k=1,norbgd)
         write (6,*)
         write (6,*) ' vecteurs propres de la matrice densite'
         write (6,*) ' (ON)',
     *   ' dans la base des OL)'
         call scripto(on,norbgd,norbgd,norbgd,norbgd,orbi)
      endif
!     dens contient les valeurs propres, c.a.d les occupations
!     des nouvelles orbitales

c--------------------------------------------
c     verif PDPt
c--------------------------------------------
      if(yverif) then
         print*,'verif PDPt  ---> mat densite lue'
         s1=matmul(on,matmul(dens,transpose(on)))
         call script(s1,norbgd,norbgd,norbgd,norbgd)
      endif

!########################################################
! NATURAL ORBITALS (matrix on): 
! PUT MATRIX ELEMENTS CORRESPONDING TO DIFFERENT TYPES
! OF ORB TO ZERO (WHERE TYPES = OCC, ACT OR VIRT)
! --> BLOCK MATRIX: onb (PROJECTED NATURAL ORB)
!########################################################
      onb=on
      if(yhier) then
         do i=1,norbgd
            do j=1,norbgd
               if(yreloc.and.itype(i).ne.itype(j)) onb(i,j)=0.d0
            enddo
         enddo
      endif
      if(nprint.ge.2) then
         write (6,*)
         write (6,*) ' mise a zero des blocs exterieurs',
     *   ' de la matrice des orbitales naturelles'
         write (6,*) ' (ONB: matrice de passage en blocs)'
         call scripto(onb,norbgd,norbgd,norbgd,norbgd,orbi)
      endif

!########################################################
! ORTHOGONALISE EACH BLOCK OF PROJECTED NATURAL ORB onb
! onb IS NOW THE MATRIX OF PROJECTED AND ORTHONORMALISED 
! NATURAL ORBITALS
!########################################################
      UT_on_onb=0.d0
      do ityp=1,3
         if(nprint.ge.4)print*,'orthonormalisations ityp=',ityp
         call extraire(norb2,norbgd,onb,norbgd,on,norbgd,itype,ityp)
         if(nprint.ge.4)print*,'mat extraite'
         if(nprint.ge.4)call script(onb,norb2,norb2,norbgd,norbgd)
         call smudo(norb2,norbgd,s1,onb)
         if(nprint.ge.4)print*,'...apres ortho par s-1/2'
         if(nprint.ge.4)call script(s1,norb2,norb2,norbgd,norbgd)
         call inclure
     *   (norb2,norbgd,s1,norbgd,UT_on_onb,norbgd,itype,ityp)
         if(nprint.ge.4)print*,'apres inclure',norb2,norbgd
         if(nprint.ge.4)
     *   call script(UT_on_onb,norbgd,norbgd,norbgd,norbgd)
      enddo
      onb=UT_on_onb

      if(nprint.ge.2) then
         write (6,*)
     *   ' matrice de passage en blocs apres orth (ONB modifie)',
     *   ' (dans la base des OL)'
         call scripto(onb,norbgd,norbgd,norbgd,norbgd,orbi)
      endif
      dens=matmul(onb,matmul(dens,transpose(onb)))
c     la diagonale de dens contient les nouvelles occupations
c     (seulement pour les orbitales non gelees)
      if(yw)print*,'nouvelles occupations'
      if(yw)call script(dens,norbgd,norbgd,norbgd,norbgd)
      if(yverif) then
         write (6,*)
         write (6,*) ' verif : recouvrement entre les ONB'
         write (6,*)
         do i=1,norbgd
            do j=1,norbgd
               s1(i,j)=0.d0
               do k=1,norbgd
                  s1(i,j)=s1(i,j)+onb(k,i)*onb(k,j)
               enddo
            enddo
         enddo
         call script(s1,norbgd,norbgd,norbgd,norbgd)
         s1=matmul(onb,matmul(dens,transpose(onb)))
         print*,'PDPt a partir des vecteurs bloc orth'
         print*,'(mat densite dans la base ONB   '
         call script(s1,norbgd,norbgd,norbgd,norbgd)
      endif

!########################################################
! COMPUTE UT_on_onb (UNITARY TRANSFORMATION MATRIX BETWEEN
! NO'S AND PROJECTED NO'S
!########################################################
      UT_on_onb=matmul(on,transpose(onb))

      if(nprint.ge.1) then
         print*,
     *   'UT_on_onb (matrice unitaire conduisant de on a onb)'
         call script(UT_on_onb,norbgd,norbgd,norbgd,norbgd)
      endif
      if(yverif) then
         print*,
     *   'Matrice densite par blocs'
         s1=matmul(onb,matmul(dens,transpose(onb)))
         call script(s1,norbgd,norbgd,norbgd,norbgd)
         print*,
     *   'verif PDPt --> densd --> dens'
         UT_on_onb=matmul(on,matmul(dens,transpose(on)))
         call script(UT_on_onb,norbgd,norbgd,norbgd,norbgd)
         print*,
     *   'verif PDPt --> densb --> dens'
         UT_on_onb=matmul(on,transpose(onb))
         s1=matmul(UT_on_onb,matmul(s1,transpose(UT_on_onb)))
         call script(s1,norbgd,norbgd,norbgd,norbgd)
      endif

!--------------------------------------------------------
! READ OVERLAP MATRIX BETWEEN AO'S 
!--------------------------------------------------------
      read(10) s

      if(nprint.ge.3)print*,'matrice de recouvrement entre OA'
      if(nprint.ge.3)call script(s,norb,norb,norb,norb)

!--------------------------------------------------------
! READ LO'S IN BASIS OF AO'S
!--------------------------------------------------------
      read(11) old_lo

 1000 format(a80)
 1001 format(4D18.12)
      if(nprint.ge.1) then
         print*,'orbitales localisees dans la base des OA ',
     *   '(Anciennes orbitales)'
         call scripto(old_lo,norb,norb,norb,norb,orbi)
      endif
c
c     orbitales "naturelles" dans la base des orb atomiques
c

!#############################################################
! NEW LOCAL ORBITALS (v) IN THE BASIS OF AO's
!#############################################################
      v(:,idebg:ifind)=matmul(old_lo(:,idebg:ifind),UT_on_onb)
      v(:,1:ngel)=old_lo(:,1:ngel)
      v(:,norb-ndel+1:norb)=old_lo(:,norb-ndel+1:norb)
      if(nprint.ge.1) then
         print*,'Nouvelles orbitales locales dans la base des OA'
         call scripto(v,norb,norb,norb,norb,orbi)
      endif
      
!
!     on reorthogonalise old_lo et v par projection 
!     pour eviter une perte de precision
!     on renormalise old_lo et v pour eviter une perte de precision
!
      do k=idebg,ifind
         do l=idebg,k-1
            v(:,k)=v(:,k)
     *      -dot_product(v(:,k),matmul(s,v(:,l)))*
     *      v(:,l)
            old_lo(:,k)=old_lo(:,k)
     *      -dot_product(old_lo(:,k),matmul(s,old_lo(:,l)))*
     *      old_lo(:,l)
         enddo
         anor=dsqrt(dot_product(v(:,k),matmul(s,v(:,k))))
         v(:,k)=v(:,k)/anor
         anor=dsqrt(dot_product(old_lo(:,k),matmul(s,old_lo(:,k))))
         old_lo(:,k)=old_lo(:,k)/anor
      enddo
      if(nprint.ge.3) then
         print*,'correction perte de precision'
         call scripto(v,norb,norb,norb,norb,orbi)
      endif
c      print*,'orbitales "naturelles" dans la base des orb atomiques'
c      print*,'symetrie',is,'   (nouvelles orbitales)'
c      call scripto(v,norb,norb,norb,norb,orbi)
      if(yverif) then
              print*,'orthogonalite des anciennes orbitales'
              s1=matmul(transpose(old_lo(:,idebg:ifind)),
     *        matmul(s,old_lo(:,idebg:ifind)))
              call script(s1,norbgd,norbgd,norbgd,norbgd)
              do k=1,norbgd
              print*,'diag',k,s1(k,k)
              enddo
              print*,'orthogonalite des nouvelles orbitales'
              s1=matmul(transpose(v(:,idebg:ifind)),
     *        matmul(s,v(:,idebg:ifind)))
              call script(s1,norbgd,norbgd,norbgd,norbgd)
              do k=1,norbgd
              print*,'diag',k,s1(k,k)
              enddo
      endif

c
c     recouvrement entre nouvelles et anciennes orbitales
c
      s1=matmul(transpose(old_lo(:,idebg:ifind)),
     *matmul(s,v(:,idebg:ifind)))
      if(yverif) then
              print*,
     *        'recouvrement entre les nouvelles et anciennes orbitales'
              call script(s1,norbgd,norbgd,norbgd,norbgd)
              do k=1,norbgd
              print*,'diag',k,s1(k,k)
              enddo
      endif
      print*,
     *'1.-(recouvrement entre les nouvelles et anciennes orbitales)'
      do k=1,norbgd,10
         print'(i4,10d8.1)',k-1,(-s1(kk,kk)+1.d0,kk=k,min(k+9,norbgd))
      enddo
c
c     on diagonalise la mat de recouvrement entre toutes les orbitales
c     (anciennes et nouvelles)
      allocate (s12(norbgd*2,norbgd*2))
      allocate (on12(norbgd*2,norbgd*2))
      s12=0.d0
      do k=1,norbgd*2
         s12(k,k)=1.d0
      enddo
      s12(1:norbgd,norbgd+1:norbgd+norbgd)=s1
      s12(norbgd+1:norbgd+norbgd,1:norbgd)=transpose(s1)
      !stop
      call hdiag(s12,on12,norbgd*2,norbgd*2)
      print*,
     *'valeurs propres du recouvrement)'
      do k=1,norbgd,10
         print'(10d8.1)',(dabs(s12(kk,kk)-2.d0),kk=k,min(k+9,norbgd))
      enddo
      do k=norbgd+1,norbgd+norbgd,10
         print'(10d8.1)',(dabs(s12(kk,kk)),kk=k,min(k+9,norbgd+norbgd))
      enddo
      deallocate (s12)
      deallocate (on12)
      
c      call script(s1,norbgd,norbgd,norbgd,norbgd)
c      print*,'determinant',determ(s1)
c      do i=1,norbgd
c         aaa=max(aaa,dabs(s1(i,i)-1.d0))
c      enddo
c      print*,'old_lo(i,i)',(old_lo(i,i),i=1,norb)
c      print*,'v(i,i)',(v(i,i),i=1,norb)
c      print*,'diff(i,i)',(v(i,i)-old_lo(i,i),i=1,norb)
c      print*,'s1(i,i)',(s1(i,i),i=1,norbgd)
c      print*,'CONV,seuil',aaa,seuil
c      aaaa=0.d0
c      do i=1,norb
c         do j=1,norb
c            aaaa=max(aaaa,dabs(v(i,j)-old_lo(i,j)))
c         enddo
c      enddo
c      print*,'aaaa',aaaa
      aaa1=maxval(dabs(v(1:norb,1:norb)-old_lo(1:norb,1:norb)))
      aaa=max(aaa1,aaa)
c      rewind 1
c      read(1,1000)
      if(is.eq.1)write(2,'(a21)') '*ORBITALES NATURELLES  (locnats)'
      do i=1,norb
c         read(1,1000) aa
         write(2,'(''* ORBITAL'',2i5)') is,i
c         read(1,1001) (vbid,j=1,norb)
         write(2,1001) (v(j,i),j=1,norb)
      enddo
c
c     verif produit scalaire
c
      if(yverif) then
c         v=matmul(s,dens)
c         old_lo=transpose(dens)
c         dens=matmul(old_lo,v)
         v=matmul(transpose(v),matmul(s,v))
         print*,'verif produit scalaire'
         call script(v,norb,norb,norb,norb)
      endif
      deallocate (old_lo)
      deallocate (s1)
      deallocate (onb)
      deallocate (on)
      deallocate (UT_on_onb)
      deallocate (vec1)
      deallocate (iord)
      return
      end
      
      
      
      
      subroutine jacobi(ndim,s,v,ndimt)
      implicit real*8(a-h,o-x,z),logical*1(y)
      dimension s(ndimt,ndimt), v(ndimt,ndimt)
      common /data/thr,maxit,nprint,yverif
      do i=1,ndim
         do j=1,ndim
            v(i,j)=0.d0
         enddo
         v(i,i)=1.d0
      enddo
      iter=0
      do
         iter=iter+1
         irot=0
         do i=1,ndim
            do j=i+1,ndim
               if (dabs(s(i,j))<=thr) cycle
               irot=irot+1
               phi=datan(2.d0*s(i,j)/(s(j,j)-s(i,i)))/2.d0
               ct=dcos(phi)
               st=dsin(phi)
!     
!              rotation
!     
               do k=1,ndim
                  if (k==i .or. k==j) cycle
                  ski=ct*s(k,i)-st*s(k,j)
                  skj=ct*s(k,j)+st*s(k,i)
                  s(k,i)=ski
                  s(i,k)=ski
                  s(k,j)=skj
                  s(j,k)=skj
                  vki=ct*v(k,i)-st*v(k,j)
                  vkj=st*v(k,i)+ct*v(k,j)
                  v(k,i)=vki
                  v(k,j)=vkj
               enddo
               sii=ct**2*s(i,i)+st**2*s(j,j)-2.d0*st*ct*s(i,j)
               sjj=st**2*s(i,i)+ct**2*s(j,j)+2.d0*st*ct*s(i,j)
               sij=(ct**2-st**2)*s(i,j)+st*ct*(s(i,i)-s(j,j))
!              mettre sij=0
               s(i,i)=sii
               s(j,j)=sjj
               s(i,j)=sij
               s(j,i)=sij
               vii=ct*v(i,i)-st*v(i,j)
               vjj=st*v(j,i)+ct*v(j,j)
               vji=ct*v(j,i)-st*v(j,j)
               vij=st*v(i,i)+ct*v(i,j)
               v(i,i)=vii
               v(i,j)=vij
               v(j,i)=vji
               v(j,j)=vjj
            enddo
         enddo
         if(iter==maxit) print*,'ITER=MAXIT'
         !if(irot==0) print*,'ITER',iter
         if (irot==0 .or. iter==maxit) exit
      enddo
      return
      end
      
      
       subroutine extraire(n1,n,onb,ndim1,v,ndim,itype,ityp)
      implicit real*8(a-h,o-z)
      dimension onb(ndim1,ndim1),v(ndim,ndim),itype(n)
      ii=0
c       print*,'entree extraire n,n1,ityp,itype',
c     *  n,n1,ityp,itype
c      print*,'entree extr'
c      call script(v,n,n,ndim,ndim)
      do i=1,n
         if(itype(i).eq.ityp) then
            ii=ii+1
            jj=0
            do j=1,n
               if(itype(j).eq.ityp) then
                  jj=jj+1
                  onb(ii,jj)=v(i,j)
c       print*,'ii,jj,i,j',ii,jj,i,j
               endif
            enddo
         endif
      enddo
      n1=ii
c      print*,'sortie extr'
c      call script(onb,n1,n1,ndim1,ndim1)
      return
      end
       subroutine inclure(n1,n,onb,ndim1,v,ndim,itype,ityp)
      implicit real*8(a-h,o-z)
      dimension onb(n,n),v(n,n),itype(n)
      ii=0
c       print*,'entree inclure n,n1,ityp,itype',
c     *  n,n1,ityp,itype
c      print*,'onb',onb(1:n1,1:n1)
      do i=1,n
         if(itype(i).eq.ityp) then
            ii=ii+1
            jj=0
            do j=1,n
               if(itype(j).eq.ityp) then
                  jj=jj+1
                  v(i,j)=onb(ii,jj)
               endif
            enddo
         endif
      enddo
      n1=ii
      return
      end
       subroutine scarre(s,v)
! lit la mat de recouvrement et l'ecrit sur 10
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter (maxsym=8,maxet=100)
      dimension s(norb0*norb0),v(norb0,norb0)
      dimension isym(maxsym)
      character*80 aa
      common /nor/norb0
      print*,'entree scarre'
      open(10,file='BIDS',form='unformatted',status='unknown')
      read(9)
      do
         read(9)aa
         if(index(aa,'==OVERLAP MATRIX (SYM)').ne.0) exit
         read(9)
         read(9)
      enddo
      read(9) norbtt,nsym,isym(1:nsym)
      print*,'norb0,norb0*norb0,norbtt',norb0,norb0*norb0,norbtt
      read(9) s(1:norbtt)
      nd2=0
      ij=0
      do is=1,nsym
         if(isym(is)==0) cycle
         nd1=nd2+1
         nd2=nd1+isym(is)*(isym(is)+1)/2
         do i=1,isym(is)
            do j=1,i
               ij=ij+1
               v(i,j)=s(ij)
               v(j,i)=s(ij)
            enddo
         enddo
         write(10) v(1:isym(is),1:isym(is))
      enddo
      rewind 10
      print*,'sortie scarre'
      return
      end
c------------------------------------------------------------------
      SUBROUTINE MATOUT(N,N2,A,NN)
      DOUBLE PRECISION A
      DIMENSION A(NN,*)
 
   20 FORMAT(//,8X,11(5X,I3,3X))
   30 FORMAT(1X,I4,4X,11(F11.6))
   35 FORMAT(8X,11(5X,I3,3X))
   37 FORMAT(8X,11(4X,A4,3X))
   36 FORMAT(/)
      DO 40 M=1,N2,6
      K=M+5
      IF(K.LE.N2) GOTO 10
      K=N2
   10 WRITE(6,20) (J,J=M,K)
      WRITE(6,36)
      WRITE(6,36)
      DO 40 I=1,N
      WRITE(6,30) I,(A(I,J),J=M,K)
 40   CONTINUE
      call flush(6)
      RETURN
      END
         

      
