      subroutine scf(orb,norb)
      use don
      use bas
      use densch
      use mod_lirorb
      use mod_dolo
      use mod_script
      use mod_transf_orb_molcas60
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      parameter (maxsym=8)
      parameter (maxl=3000)
      character(10000) namel
      double precision,dimension(:,:),allocatable :: ul,ur,u,s,v
      double precision,dimension(:,:),allocatable :: u1,u2
      double precision,dimension(:,:),allocatable :: oocc,ovir
      double precision,dimension(:),allocatable :: w,w1,occup
     *,occup3o,occup3v,occup4o,occup4v
      integer,dimension(:),allocatable :: ii,iord,iprio,ii2
      integer,dimension(:),allocatable :: isocc,isvir
      integer,dimension(:),allocatable :: iordocc,iordvir
      integer frozen(maxsym),delete(maxsym)
      character(1) o
      character(8) orbi1,orbi2
      common/pr/nprint
      common /filc/jrc_oneint
c      common/bas/ orbi,nbas(nfix),nbast(0:nfix),natom,atom,base
c      character*8 base(nfix)
c      character*4 atom(100)
c      character*8 orbi(nfix)
      character(4) atom1
      character(3000) orb,orb1,orbitales
      allocatable yvirt(:),ivirt(:)
      allocatable numac0(:),yac0(:)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      common/version/molcas,i_rec,i_at,i_orb,i_coo
      dimension nbii(maxsym),nbiit(0:maxsym)!,ios(nfix),y(nfix)
      dimension nbocs(maxsym,maxl),nbals(maxsym,maxl)
      dimension nboctots(maxsym),nbaltots(maxsym)
      dimension kks(maxsym)
      dimension jproj(maxl),nbocj(maxl),nbalj(maxl),ioref(maxl)
      integer,allocatable,dimension(:,:) :: ioproj
      integer,allocatable,dimension(:) :: noproj
      character(8) progr
      common/prog/progr
      dimension iocd(maxsym),ngelo(maxsym),ngelv(maxsym)
      integer fermi0(maxsym)
      dimension iocref(maxl),ialref(maxl)
      dimension nsoc(0:maxsym),nsal(0:maxsym)
      dimension nsoc2(0:maxsym),nsal2(0:maxsym)
      dimension nsoc3(0:maxsym),nsal3(0:maxsym)
      dimension iocp(maxsym),ialp(maxsym)
      dimension nvirt(maxsym)
      dimension icore(maxsym),igel(maxsym)
      dimension nret(0:maxsym*2),mret(maxl),yret(maxl)!,iret(nfix)
      character(1) ret(maxsym)
c      logical yo,yv
      allocatable ios(:),yo(:),yv(:),ios2(:),iret(:),
     *jlocc(:),jlvir(:),tipoo3(:),tipov3(:),tipoo(:),tipov(:),tipo(:)
      character(12) tipoo3,tipov3,tipoo,tipov,tipo
 
 
 
      yw=.false.
      yverif=.false.
      nvirt=0
      icore=0
      igel=0
      if(yw)print*,'entree scf norb',norb
      allocate(ul(norb,norb))
      allocate(u1(norb,norb))
      allocate(u2(norb,norb))
      allocate(u(norb,norb))
      allocate(ur(norb,norb))
      allocate(s(norb,norb))
      allocate(v(norb,norb))
      allocate(w(norb))
      allocate(tipo(norb))
      allocate(w1(norb))
      allocate(occup(norb))
      allocate(occup3o(norb))
      allocate(occup3v(norb))
      allocate(ii(norb))
      allocate(ii2(norb))
      allocate(iprio(norb))
      allocate(ivirt(norb),yvirt(norb))
      allocate(numac0(norb),yac0(norb))
      allocate(ios(norb),yo(norb),ios2(norb),iret(norb))
      allocate(yv(norb))
      if(yw)print*,'orbi',orbi(1:norb)
c------------------------------------------------------------------
c     lecture des orbitales SCF
c------------------------------------------------------------------
      call flush(6)
      orbitales=orb
      call titre('ETAPE 2#FABRICATION DES ORBITALES DE LIAISON '//
     *'ORTHOGONALES#On utilise des orbitales de depart : lues sur#'//
     *orb(1:49)//'#',60)
      if(orbitales.eq.'SCHMUD') then
         print*,'* orbitales schmud generees en interne          *'
      else
         call transf_orb_molcas60(11,99,orb,'SCH_ORBN')
            open(11,status='old',file=orb)
            read(11,'(a)') orb
      endif
!
! Lecture &ORB
!
      rewind 93
      namel=' '
      numac=0
      call LECNAM('&ORB ',namel,93,ierr,1)
      call nameli(namel,NUMAC,'NUMAC',4)
      fermi0=0
      call nameli(namel,FERMI0,'FERMI0',4)
c---------------------------------------------
      call scf1(orb,norb,fermi0,nprint,orbitales,ur,v,s,ul,u,occ,
     *yvirt)
c---------------------------------------------
c     lecture des liaisons
c
c     Donnees :
c     Une ligne par liaison ou groupe de liaisons
c     Un ou plusieurs labels d'atomes apparaissent,
c     separes par :
c     Entre chaque label d'atome, on met :
c     1) les numeros des orbitales qui interviennent dans la liaison
c     (ce sont les numeros DANS LA BASE DES ATOMES)
c     2) entre parentheses, 2 nombres : occupees, antiliantes
c---------------------------------------------
      ywo=.false.
      nbocatot=0
      nbcor=0
      iprio=4
c     on reordonne les donnees dans l'ordre act, cor, occ
      open(94,status='unknown',file='SCH_FERMI')
      write(94,'(a,8(i4,'',''))') ' &ferm fermi=',fermi0(1:nsym)
      write(94,'(a)') ' /'
      close(94)
      numac0=numac
      noac0=0
      do k=1,norb
         if(numac0(k).eq.0) then
            noac0=k-1
            exit
         endif
      enddo
      yac0=.false.
      yac0(numac0(1:noac0))=.true.
      rewind 95
      open(94,status='unknown',file='BID94')
      open(96,status='unknown',file='BID96')
      if(yw)print*,'ouv 94'
      nl=0
c------------------------------------------------------------------
c     on lit les liaisons et on les recopies sur la file 94
c     ou on a genere les lignes multiples (traitement des "*")
c     ou on a supprime les blancs multiples, mis en majuscules...
c------------------------------------------------------------------
      nncore=0
      maxproj=1
      do
         read(93,'(a)',end=3) orb
         orb=adjustl(orb)
         long=len_trim(orb)
         call suppdb(orb,long)
         orb=adjustl(orb)
         long=len_trim(orb)
         call ligne_suite(orb,orb1,long,long1)
         call maj(orb,long)
         call versionm(molcas,orb)
         long=len_trim(orb)
         if(yw)print*,'orb lue ',orb(1:long)
c        suppression des doubles blancs
         call suppdb(orb,long)
         orb=adjustl(orb)
         long=len_trim(orb)
         call calmaxproj(trim(orb),maxproj)
         if(orb(1:3).eq.'FIN') exit
         llabel=index(orb,' ')
         llabel0=index(orb(1:llabel),'_')
         if(llabel0.eq.0) llabel0=llabel
         if(index(orb(1:llabel0),'C').ne.0) then
            ifil=94
         else
            nncore=nncore+1
c            print*,'nncore',nncore
            ifil=96
         endif
         ib1=index(orb,' ')
         ib=index(orb(ib1+1:long),' ')
c         atom1=' '
c         atom1(1:ib-1)=orb(1+ib1:ib-1+ib1)
c         call repl(orb,orb(1+ib1:ib-1+ib1),atom1,ib-1,4,yrepl)
c         long=len_trim(orb)
c         if(yw)print*,'APRES REPL ORB ',orb(1:long)
         istel=index(orb,'*')
         if(yw)
     *   print*,'istel,orb(1+ib1:ib-1+ib1),ib',istel,orb(1:ib-1),ib
         llabel=index(orb,' ')+1
         if(istel.ne.0.and.orb(2:2)=='_') then
            nl0=0
            call multi(natom,atom,orb(llabel:long),long,
     *      ifil,orb(1:2),nl0)
            print*,'nl0',nl0
         else
            nl0=1
            write(ifil,'(a)') orb(1:long)
         endif
         llabel=index(orb,' ')
         llabel0=index(orb(1:llabel),'_')
         if(llabel0.eq.0) llabel0=llabel
c         if(orb(1:1).ne.'C') nncore=nncore+nl0-1
         if(index(orb(1:llabel0),'C').eq.0) nncore=nncore+nl0-1
         nl=nl+nl0
      enddo
 3    continue
      allocate(ioproj(maxproj,nl),noproj(nl))
      rewind 96
      do k=1,nncore
         orb=' '
         read(96,'(a)') orb
         long=len_trim(orb)
         write(94,'(a)') orb(1:long)
         if(yw)write(6,'(a,i7,a)') 'ORBA  ',long,orb(1:long)
      enddo
c      close(96,status='delete')
      close(96)
      if(yw)print*,'nl',nl
      if(nl.gt.maxl) then
         print*,'trop de liaisons, augmenter maxl (',maxl,')'
         stop
      endif
      rewind 94
      open(98,status='unknown',file='OLIN')
c
c------------------------------------------------------------
c     p,d,f multiples, les liaisons sont reecrites sur 98
c------------------------------------------------------------
c
      do il=1,nl
         read(94,'(a)') orb
         orb=adjustl(orb)
         long=len_trim(orb)
         if(yw)print*,'Orb',orb(1:long)
         call multi5(orb(1:long),long,98,molcas)
         if(yw)print*,'Orb.',orb(1:long)
      enddo
      close(94)
      rewind 98
c
c-----------------------------------------------------------
c     calcul du nombre d'orbitales occupees et virtuelles
c-----------------------------------------------------------
c
      ioc=0
      ial=0
      iocref=0
      ialref=0
      ioref=0
      do il=1,nl
         ideblec=1
         ifinlec=3000
         read(98,'(a)') orb(ideblec:ifinlec)
         long=len_trim(orb)
         if(yw)print*,orb(1:long)
!        on supprime la donnee PARA ou ORTH
         jj=max(index(orb,'PARA'),index(orb,'ORTH'))
         if(jj.ne.0) then
            kk=index(orb(jj:long),')')+jj-1
            orb(jj:kk)=' '
         endif
c        on note si la liaison est une reference
         jj=index(orb(1:long),'REF ')
         jref=0
         if(jj.ne.0) then
            if(yw)print*,'l''orbitale est une ref'
            orb(jj:jj+3)=' '
         if(yw)print*,orb(1:long)
            jj1=index(orb(jj+4:long),' ')+jj+2
            if(yw)print*,'jj+4,jj1',jj+4,jj1
            if(jj1.eq.jj+2) jj1=long
            if(yw)print*,'jj+4,jj1',jj+4,jj1
            if(yw) call flush(6)
            read(orb(jj+4:jj1),*) jref
            if(yw)print*,'jref',jref
            if(yw)print*,orb(jj-1:jj1+1)
            orb(jj-1:jj1+1)=' '
         if(yw)print*,orb(1:long)
            long=len_trim(orb)
            ioref(il)=jref
         endif
c        on supprime l'indication de projection
         jj=index(orb(1:long),'PROJ')
         if(jj.ne.0)orb(jj-1:long)=' '
c        on repere les orbitales multiples
         lon2=min(long,index(orb(1:long),'RET('))
         if(lon2.eq.0) lon2=long
         do k=lon2-1,1,-1
            if(orb(k:k).eq.'(') then
               ipar1=k
               exit
            endif
         enddo
         long=len_trim(orb)
         ipar2=index(orb(ipar1:long),')')+ipar1-1
         if(ywo)print*,'ipar1,ipar2',ipar1,ipar2
         if(ywo)print*,'orb(ipar1:ipar2)',orb(ipar1:ipar2)
         read(orb(ipar1+1:ipar2-1),*) nboc,nbal
         orb(ipar1:long)=' '
         if(ywo)print*,'nboc,nbal',nboc,nbal
         if(jref.ne.0) then
            iocref(jref)=nboc
            ialref(jref)=nbal
         endif
         ioc=ioc+nboc
         ial=ial+nbal
      enddo
c
c-----------------------------------------------------------
c     lecture des liaisons sur BID98
c     on note si la liaison est a prejeter
c-----------------------------------------------------------
c
      rewind 98
      allocate(tipoo3(ioc))
      !!!!!!!!!!!!!!VERIFIER LA DIMENSION DE TIPOV3!!!!!!!!!!!!
      allocate(tipov3(norb*2))
      tipoo3=' ' ; tipov3=' '
      iocproj=ioc
      ialproj=ial
      ioproj=0
      noproj=0
      do il=1,nl
         ideblec=1
         ifinlec=3000
 224     continue
         read(98,'(a)') orb(ideblec:ifinlec)
         long=len_trim(orb)
         if(orb(long:long).eq.'&') then
            ideblec=ideblec+3000
            ifinlec=ifinlec+3000
            if(yw)print*,'dans if orb(long:long)',orb(long:long)
            orb(long:long)=' '
            goto 224
         endif
         orb=adjustl(orb)
         long=len_trim(orb)
         jj=index(orb(1:long),'PROJ')
         nbp=0
         if(jj.ne.0) then
            if(nprint>0)print*,'l''orbitale',il,' est a projeter'
            if(yw)print*,'proj ',orb(jj:jj+4)
            orb(jj:jj+4)=' '
            if(yw)print*,'proj ',orb(1:long)
            jj1=index(orb(1:long),';')-1
            if(jj1.lt.0) jj1=long
            nbp=1
            if(yw)print*,'jj+5,jj1',jj+5,jj1
            do k=jj+5,jj1
               if(orb(k:k).eq.' ') exit
               if(orb(k:k).eq.',') then
                  orb(k:k)=' '
                  nbp=nbp+1
               endif
            enddo
            if(yw)print*,'proj3 ',orb(jj+4:jj1)
            if(yw)print*,'nbp',nbp
            read(orb(jj+4:jj1),*) jproj(1:nbp)
            if(yw)print*,'jproj ',jproj(1:nbp)
            do k=1,nbp
               iocproj=iocproj-iocref(jproj(k))
               ialproj=ialproj-ialref(jproj(k))
            enddo
            noproj(il)=nbp
            ioproj(1:nbp,il)=jproj(1:nbp)
          !  do i=1,nbp
          !     ioproj(il)=ioproj(il)+nl**(i-1)*jproj(i)
          !  enddo
            orb(jj-1:long)=' '
         endif
      enddo
      if(nprint.ge.1)print*,'nb d''occ/virt avant proj',ioc,ial
      if(nprint.ge.1)print*,'nb d''occ/virt apres proj',iocproj,ialproj
      allocate(oocc(norb,ioc))
      allocate(ovir(norb,ial))
      allocate(isocc(ioc))
      allocate(isvir(ial))
      allocate(iordocc(ioc))
      allocate(iordvir(ial))
      allocate(jlocc(ioc))
      allocate(jlvir(ial))
      jlocc(1:ioc)=0
      jlvir(1:ial)=0
 
c      call scripto(ur(1:norb,1:norb),norb,norb,norb,
c     *norb,orbi)
      if(nprint.ge.1) then
         do is=1,nsym
            ndims=isym(is)
            if(ndims.eq.0) cycle
            print*,'Matrice densite dans la base des OAO sym',is
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            call scripto(ur(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
         enddo
      endif
      u=0.d0
      oocc=0.d0
      ovir=0.d0
      kkocc=0
      kkvir=0
      nboctots(1:nsym)=0
      nbaltots(1:nsym)=0
      kks(1:nsym)=0
c
c-----------------------------------------------------------
c     lecture des liaisons sur BID98
c     extraction de matrices densites locales
c     formation des orbitales locales
c-----------------------------------------------------------
c
c     boucle sur les liaisons
      rewind 98
      open(76)
      do il=1,nl
         print*,' '
         print*,' '
         print*,
     *   '*===========================================================*'
         print'(a25,i3)','            Liaison  ',il
         iodeb=1
         ideblec=1
         ifinlec=3000
         ii=0
 222     continue
         read(98,'(a)') orb(ideblec:ifinlec)
c         print*,'orb1',orb(ideblec:ifinlec)
         long=len_trim(orb)
c         print*,'long',long,orb(long:long)
         if(orb(long:long).eq.'&') then
            ideblec=ideblec+3000
            ifinlec=ifinlec+3000
            if(yw)print*,'dans if orb(long:long)',orb(long:long)
            orb(long:long)=' '
            goto 222
         endif
         orb=adjustl(orb)
c        suppression des doubles blancs
         print*,'donnee    ',orb(1:long)
         call suppdb(orb,long)
         orb=adjustl(orb)
         if(ywo)print*,'long',long
c
c------------------------------------------------------
c        on note les orbitales retenues a la main
c        ne marche pas ?
c------------------------------------------------------
c
c         yret=.false.
         nret=0
         if(yw)print*,'jj,long',jj,long
        if(yw)print*,orb(1:long)
         nrets=0
         jj=index(orb(1:long),'RET(')
         if(yw)print*,'jj',jj
         if(jj.ne.0) then
c            do k=jj,long-4
c               if(orb(k:k+3)=='RET(') nrets=nrets+1
c            enddo
            nrets=count( (/(orb(k:k+3)=='RET(',k=jj,long-4)/) )
            if(yw)print*,'nrets',nrets
c           symetries
            nret(0)=0
            do iis=1,nrets
               ifin=index(orb(jj:long),')')+jj-1
               if(yw)print*,'jj,ifin',jj,ifin
               is=index(orb(jj:ifin),'S=')+jj-1
               read(orb(2+is:2+is),'(i1)') js
               yret(js)=.true.
c              occ/virt ?
               kov=index(orb(jj:ifin),'OCC')
               if(kov/=0) then
                  ret(iis)='O'
               else
                  ret(iis)='V'
               endif
               if(yw)print*,'js,iis,ret(iis)',js,iis,ret(iis)
               kov=0
c              numeros
               ns=index(orb(jj:long),'N=')+jj+1
               nso=index(orb(ns:ifin),',O')
               nss=index(orb(ns:ifin),',S')
               nsf=index(orb(ns:ifin),')')
               if(nso.ne.0) nsf=min(nso,nsf)
               if(nss.ne.0) nsf=min(nss,nsf)
               nsf=nsf+ns-2
               orb(ifin:ifin)=' '
               orb(jj:jj+3)=' '
               if(yw)print*,'ns,nsf',ns,nsf
               nret(iis)=nret(iis-1)
     *         +count( (/(orb(k:k)==',',k=ns,nsf)/) )+1
               if(yw)print*,'nret',nret(iis)
               yrepl=.true.
               do k=nret(iis-1)+1,nret(iis)-1
                  call repl(orb(ns:nsf),',',' ',yrepl)
               enddo 
               if(yw)print'(a)',orb(ns:nsf)
               read(orb(ns:nsf),*) iret(nret(iis-1)+1:nret(iis))
               orb(jj:ifin)=' '
               if(yw)print*,orb(1:long)
               jj=index(orb(1:long),'RET(')
            enddo
            if(yw)print*,'iret',iret(0:nret(nrets))
         endif
!
!----------------------------------------------------------------
!        on lit les indications ORTH et PARA, puis on les efface
!        on traite les donnees de PARA et ORTH
         call orientation(orb(1:long),norb)
!----------------------------------------------------------------)
!
c 
c------------------------------------------------------------
c        on lit nboc et nbal, nb d'occupees et d'anti-liantes
c------------------------------------------------------------
c
         do k=long-1,1,-1
            if(orb(k:k).eq.'(') then
               ipar1=k
               exit
            endif
         enddo
         do k=long,1,-1
            if(orb(k:k).eq.')') then
               ipar2=k
               exit
            endif
         enddo
         long=len_trim(orb)
         if(ywo)print*,'ipar1,ipar2',ipar1,ipar2
         if(ywo)print*,'orb(ipar1:ipar2)',orb(ipar1:ipar2)
         call flush(6)
         read(orb(ipar1+1:ipar2-1),*) nboc,nbal
         orb(ipar1:long)=' '
         if(ywo)print*,'nboc,nbal',nboc,nbal
         long=len_trim(orb)
         if(ywo)print*,'Orb',orb
         if(ywo)print*,'longueur',long
         idebat=index(orb,' ')+1
         llabel=idebat-2
         if(llabel.gt.12) then
            print*,'label trop long',orb(1:llabel)
            stop
         endif
         if(ywo)print*,'orb',orb
         if(ywo)print*,'ind',index(orb(3:long),' ')
c
c---------------------------------------------------------
c        DEBUT DE LA BOUCLE SUR LES ATOMES DE LA LIAISON
c---------------------------------------------------------
c
c        lecture du nom de l'atome
         nbii(1:nsym)=0
         nbiit(0)=0
         v=0.d0
         iii=0
 4       continue
         longat=index(orb(idebat:long),' ')-1
         ifinat=idebat+longat-1
         ideb=idebat+longat+1
         if(ywo)print*,'longat,ideb,idebat',longat,ideb,ideb
     &   at
         atom1='    '
         atom1(1:longat)=orb(idebat:ifinat)
         print*,'atome  ','====',atom1,'===='
c        lecture des orbitales de l'atome
c        stockage de toutes les orbitales de la liaison dans ii
         ideb2=index(orb(ideb:long),':')
         if(ideb2.eq.0) then
            ifin=long
         else
            ifin=ideb2-3+ideb
         endif
         if(ywo)print*,'ifin',ifin
         nbo=1
         do k=ideb,ifin
            if(orb(k:k).eq.' ') nbo=nbo+1
         enddo
         if(ywo)print*,'nbo',nbo
         iofin=iodeb+nbo-1
c        fabrication de ii : numeros dans la base totale
c        des orbitales atomiques en donnee
         iodeb1=iodeb
         iodeb2=iodeb
c----------------------------------------------------------
c        pour la liaison il et l'atome atom1 :
c        boucle sur les symetries
c        puis boucle sur les orbitales concernees
c----------------------------------------------------------
         do is=1,nsym
            ndims=isym(is)
            ndims0=isymt(is-1)
            ideb1=ideb
            do ibo=1,nbo
               orbi1(1:4)=atom1
               orbi1(5:8)=' '
               l=index(orb(ideb1:ifin),'(')-1
               orbi1(5:5+l-1)=orb(ideb1:ideb1+l-1)
               if(ywo)print*,'orbi1',orbi1
               i=index(orb(ideb1+l+2:ifin),')')
               read(orb(ideb1+l+1:ideb1+l+i),*) nu
               nu1=0
c              on a forme l'orbitale type orbi1.
c              il faudra prendre la nu-ieme
               do k=1,ndims
c               print*,'orbi(k)',orbi(k)
                  orbi2=orbi(k+ndims0)
                  call maj(orbi2,8)
                  if(ywo)print*,'orbi2',orbi2
                  if(orbi2.eq.orbi1) then
                     nu1=nu1+1
                     if(nu1.lt.nu) cycle
                     if(nu1.gt.nu) exit
                     nbii(is)=nbii(is)+1
                     iii=iii+1
                     ii(iii)=k+ndims0
c                     ii(iodeb2)=k+ndims0
                     if(yw)print*,'II',iii,iodeb2,ii(iii),ii(iodeb2)
                     if(yvirt(k+ndims0)) nvirt(is)=nvirt(is)+1
                     yvirt(k+ndims0)=.false.
                     iodeb2=iodeb2+1
                     if(ywo)print*,'egalite',k+ndims0
                  endif
               enddo
               i=index(orb(ideb1:ifin),' ')
               ideb1=i+ideb1
               if(ywo)print*,'nouvel ideb1',ideb1,i
            enddo
         enddo
c---------------------------------------------------------------------
c        fin de la double boucle sur les sym et les orbitales locales
c        nor2 est le nb d'OA apparaissant dans les donnees
c        nbii(1:nsym) est le nb d'OA retenues par symetrie
c        ii(1:nor2) donne les numeros de ces OA dans la base totale
c---------------------------------------------------------------------
         nor2=iii
         if(yw)print*,'NBII',nbii(1:nsym)
         if(yw)print*,'II',ii(1:norb)
         if(iodeb2.eq.iodeb1) then
            print*,'indice d''orbitale non trouve'
            print*,orbi1
            stop
         endif
c 7       continue
c        on note les OA virtuelles dans yvirt, puis a la fin de ii
         yvirt(ii(iodeb:iofin))=.false.
         yvirt(ii(1:nor2))=.false.
         if(ywo)print*,'ii',ii(iodeb:iofin)
         if(ywo)write(6,'(a24,10i4,10(/,22x,10i4))')
     *   'orbitale(s) numero : ',ii(iodeb:iofin)
         if(ifin.ne.long) then
            idebat=ifin+4
            iodeb=iofin+1
            goto 4
c           atome suivant de la liaison
         endif
c---------------------------------------------------------
c           FIN DE LA BOUCLE SUR LES ATOMES DE LA LIAISON
c---------------------------------------------------------
c
c-----------------------------------------------------------
c        on traite toutes les matrices extraites sym par sym
c-----------------------------------------------------------
         do is=1,nsym
            print*,'.......................................'
            nbiit(is)=nbiit(is-1)+nbii(is)
            if(yw)print*,'nbii',nbii(1:nsym)
            if(yw)print*,'nbiit',nbiit(1:nsym)
            if(yw)print*,'nor2',nor2
            if(nbii(is).eq.0) cycle
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            ndims=isym(is)
            ndims0=isymt(is-1)
            jd1=nbiit(is-1)+1 ; jd2=nbiit(is)
c            kd1=iodeb  ;  kd2=iodeb+nbii(is)-1
            kd1=1  ;  kd2=nbii(is)
            if(yw)print*,'jd1,jd2,kd1,kd2,',jd1,jd2,kd1,kd2
            if(yw)print*,'ii',ii(kd1:kd2)
            if(yw)print*,'ii',ii(jd1:jd2)
            if(yw)print*,'nbii(is),ndims0',nbii(is),ndims0
c           on se sert de ii2 = (ii reordonne) pour que les
c           orbitales locales arrivent sym par sym
            ii2=ii
            call reor(nor2,ii2)
            if(yw)print*,'ii2',ii2(1:norb)
c           on extrait la matrice densite locale
            ul(1:nbii(is),1:nbii(is))=
     *      ur(ii2(jd1:jd2)-ndims0,ii2(jd1:jd2))
            if(nprint.ge.1) then
               print*,'sym',is,'  matrice extraite'
               call scripto(ul(1:nbii(is),1:nbii(is)),nbii(is),
     *         nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)))
            endif
            call orientation2(ul(1:nbii(is),1:nbii(is)),nbii(is),
     *      orbi(ii2(jd1:jd2)),v(1:nbii(is),jd1:jd2),yor)
c           diagonalisation, orbitales locales (dans v)
            if(yor)
     *      call hdiag(ul(1:nbii(is),1:nbii(is)),v(1:nbii(is),jd1:jd2)
     *      ,nbii(is),nbii(is))
            print*,' '
            print'(a,i3,a,/)',
     *      'sym',is,'  occupations, orbitales naturelles'
            do k=1,nbii(is)
               if(ul(k,k)==-10.d0) ul(k,k)=1.d0
            enddo
            print'(14x,10f8.4)',(ul(k,k),k=1,nbii(is))
            if(iofin.gt.1)call scripto(v(1:nbii(is),jd1:jd2),
     *      nbii(is),nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)))
            do k=jd1,jd2
               occup(k)=ul(k-jd1+1,k-jd1+1)
               ios(k)=is
            enddo
         enddo
         print*,'.......................................'
         if(yw)print*,'OCCUP',occup(1:norb)
         if(yw)print*,'NBOC,NBAL',nboc,nbal
         if(yw)print*,'NOR2',nor2
c----------------------------------------------------------------
c        on connait nboc et nbal (nb d'occupees et d'anti-liantes
c        pour la liaison il)
c        on va maintenant calculer nbocs(1:nsym,il) et nbals(1:nsym,il)
c        (nb d'occupees et d'anti-liantes par sym et par liaison)
c        en prenant les nboc plus occupees pour nbocs(1:nsym,il)
c        et les nbal moins occupees pour nbals(1:nsym,il)
c----------------------------------------------------------------
         mboc=nboc
         mbal=nbal
         if(yw)print*,'mboc,mbal',mboc,mbal
         mmm=maxval(isym(1:nsym))
         if(yw)print*,'ios',ios(1:nor2)
         yo(1:nor2)=.false.
         u2=0.d0
         ios2=0
         if(yw)print*,'occup',occup(1:nor2)
         ! on cherche les mboc plus grandes occupations
         do k=1,mboc
            aa=0.d0
            do l=1,nor2
               if(yo(l)) cycle
               if(yw)print*,'l,occup(l),aa,yo(l)',l,occup(l),aa,yo(l)
               if(occup(l).gt.aa) then
                  ipg=l
                  aa=occup(l)
               endif
            enddo
            yo(ipg)=.true.
            if(yw)print*,'ipg',ipg,k,mboc
            ios2(k)=ios(ipg)
            u2(1:mmm,k)=v(1:mmm,ipg)
            if(yw)print*,'ios2',ios2(1:nor2)
            if(yw)print*,'y',yo(1:nor2)
            if(yw)print*,'aa',aa
         enddo
         !print*,'U2'
         !call mscript(u2(1:mmm,1:mboc))
         ! on cherche les mbal plus petites occupations
         yv(1:nor2)=.false.
         do k=1,mbal
            aa=2.d0
            do l=1,nor2
               if(yv(l)) cycle
               if(occup(l).lt.aa.and.occup(l)>-10.d0) then
                  ipg=l
                  aa=occup(l)
               endif
            enddo
            yv(ipg)=.true.
            ios2(nor2-k+1)=ios(ipg)
            u2(1:mmm,nor2-k+1)=v(1:mmm,ipg)
         enddo
c
c------------------------------------------------------------
c        gaps entre les occupees et les eliminees
c        et les eliminees et les virtuelles
c------------------------------------------------------------
c
         nelim=nor2-nboc-nbal
         occumin=2.d0
         elimin=2.d0
         almin=2.d0
         occumax=0.d0
         elimax=0.d0
         almax=0.d0
         do k=1,nor2
            if(.not.yo(k)) then
               if(.not.yv(k)) then
                  elimin=min(elimin,occup(k))
                  elimax=max(elimax,occup(k))
               else
                  almin=min(almin,occup(k))
                  almax=max(almax,occup(k))
               endif
            else
               occumin=min(occumin,occup(k))
               occumax=max(occumax,occup(k))
            endif
         enddo
         namel=' '
         namel(8:58)=
     *   '...        /  /        ...         /  /         ...'
         print*,' '
         print'(70a1)',('-',k=1,70)
         print*, '   Occupees               Eliminees   '//
     *   '          A-L, Virtuelles'
         if(nboc.gt.1)write(namel(2:7),'(f6.4)') occumax
         if(nboc.gt.0)write(namel(12:17),'(f6.4)') occumin
         if(nelim.eq.1) then
            write(namel(30:35),'(f6.4)') elimin
         else if(nelim.gt.1)then
            write(namel(25:30),'(f6.4)') elimax
            write(namel(36:41),'(f6.4)') elimin
         endif
         if(nbal.gt.1)write(namel(49:55),'(f6.4)') almax
         if(nbal.gt.0)write(namel(60:66),'(f6.4)') almin
         print'(a)',trim(namel)
         print*,' '
         namel(1:51)=' '
         namel(1:7)=' Gaps :'
         ideb=11
         if(nboc.ne.0.and.nelim.ne.0) then
            write(namel(11:22),'(a,f9.4)')
     *      'O/E',occumin-elimax
            ideb=ideb+20
         endif
         if(nbal.ne.0.and.nelim.ne.0) then
            write(namel(ideb:ideb+11),'(a,f9.4)')
     *      'E/V',Elimin-almax
            ideb=ideb+20
         endif
         if(ideb.eq.11.and.nbal.ne.0.and.nboc.ne.0) then
            write(namel(11:22),'(a,f9.4)')
     *      'O/V',occumin-almax
         endif
         print'(a)',namel(1:51)
c     *   print'(a,f9.4,a,f9.4)',' Gaps :   O/E',occumin-elimax,'   E/V'
c     *   Elimin-almax
         if(nboc.ne.0.and.nelim.ne.0.and.occumin-elimax.lt.0.3) print*,
     *   '******ATTENTION******* Gap Occ/Elim petit'
         if(nbal.ne.0.and.nelim.ne.0.and.elimin-almax.lt.0.3) print*,
     *   '******ATTENTION******* Gap Elim/virt petit'
         if(nboc.ne.0.and.nbal.ne.0.and.occumin-almax.lt.0.3) print*,
     *   '******ATTENTION******* Gap Occ/Virt petit'
         print*,' '
 
c
 
         if(yw)print*,'ios2',ios2(1:nor2)
         if(yw)call scripto(u2(1:nor2,1:nor2),
     *   nor2,nor2,nor2,nor2,orbi(ii(1:nor2)))
         nbocs(1:nsym,il)=0
         nbals(1:nsym,il)=0
         do k=1,mboc
            nbocs(ios2(k),il)=nbocs(ios2(k),il)+1
         enddo
         do k=nor2,nor2-mbal+1,-1
            nbals(ios2(k),il)=nbals(ios2(k),il)+1
         enddo
         print'(a45,8i3)',
     *   'nombre d''orbitales occupees par symetrie    '
     *   ,nbocs(1:nsym,il)
         print'(a45,8i3)',
     *   'nombre d''orbitales anti-liantes par symetrie'
     *   ,nbals(1:nsym,il)
         call stoinfo(orb,nsym,nbocs(1:nsym,il),nbals(1:nsym,il))
         if(orb(1:1).eq.'C') icore(1:nsym)=icore(1:nsym)+
     *   nbocs(1:nsym,il)
         if(orb(1:1).eq.'G') igel(1:nsym)=igel(1:nsym)+
     *   nbocs(1:nsym,il)
c         print*,'icore',icore(1:nsym)
         if(nbp.ne.0) then
            print*,'NB: Ces orbitales seront projetees,',
     *      ' les occupations donnees ici sont plus grandes que les'
            print *,'occupations retenues a la fin du calcul.'
         endif
         if(ywo)print*,'ii fin',ii(1:iofin)
         if(ywo)print*,'ii2 fin',ii2(1:iofin)
         idebs=0
c-------------------------------------------------------------
c        boucle sur les symetries
c        fabrication des orbitales locales pour chaque sym
c-------------------------------------------------------------
         if(yw)print*,'Nbii',nbii(1:nsym)
         do is=1,nsym
            ndims=isym(is) ; ndims0=isymt(is-1)
            nd1=1+ndims0 ; nd2=ndims+ndims0
            jd1=nbiit(is-1)+1 ; jd2=nbiit(is)
            iofin=nbii(is)
            if(nbii(is).eq.0) cycle
            nboc=nbocs(is,il)
            nbal=nbals(is,il)
            if(nprint.ge.2) then
               print*,' '
               print*,'occupations, orbitales naturelles, sym',is
               print'(9x,10f8.4)',occup(jd1:jd2)
               if(yw)print*,'occup tot',occup(1:nor2)
               if(yw)print *,'jd1,jd2',jd1,jd2
               if(iofin.gt.1)call scripto(v(1:iofin,jd1:jd2)
     *         ,iofin,iofin,
     *         iofin,iofin,orbi(ii2(jd1:jd2)))
               if(yw)print*,'is,nbocs(is,il),nbals(is,il) ',
     *         is,nbocs(is,il),nbals(is,il)
               if(nbals(is,il).eq.0) then
                  write(75,*) ' occupees',1,' -',nbocs(is,il),'$'
                  call scril
               else if(nbocs(is,il).eq.0) then
                  write(75,*)
     *            ' virtuelles',iofin-nbals(is,il)+1,' -'
     *            ,iofin,'$'
                  call scril
               else
                  write(75,*)
     *            ' occupees',1,' -',nbocs(is,il)
     *            ,'....... virtuelles'
     *            ,iofin-nbals(is,il)+1,' -',iofin,'$'
                  call scril
               endif
               print*,' '
            endif
            idebs=idebs+nbii(is)
c           on replace les orbitales de liaison dans la grande matrice
c           idem pour les occupations
            nboc=nbocs(is,il)
            nbal=nbals(is,il)
            nboctot=nboctots(is)
            nbaltot=nbaltots(is)
c            ii2(1:iofin)=ii2(jd1:jd2)
c            v(1:iofin,1:iofin)=u2(1:iofin,jd1:jd2)
            if(yw)print*,'ii2',ii2(jd1:jd2)
            if(yw)print*,'nboctot',nboctot
            if(yw)print*,'nboc',nboc
            if(yw)print*,'v',v(1:iofin,1+ndims0:nboc+ndims0)
            do k=1,nboc
               kkocc=kkocc+1
               if(yw)print*,'kkocc',kkocc
               if(yw)print*,'ii2(jd1:jd2)',ii2(jd1:jd2)
               oocc(ii2(jd1:jd2),kkocc)=v(1:iofin,k+nbiit(is-1))
               isocc(kkocc)=is
               occup3o(kkocc)=occup(k+nbiit(is-1))
               tipoo3(kkocc)(1:llabel)=orb(1:llabel)
               jlocc(kkocc)=il
               if(yw)print*,'v1',v(1:iofin,k)
               if(yw)print*,'ii2(jd1:jd2)-ndims0',ii2(jd1:jd2)-ndims0
               if(yw)print*,'ii2',ii2(jd1:jd2)
c               if(yw)call scripto(u(1:ndims,nd1:nd2),ndims,ndims,ndims,
c     *         ndims,orbi(nd1:nd2))
            enddo
            do k=1,nbal
               kkvir=kkvir+1
               ovir(ii2(jd1:jd2),kkvir)
     *         =v(1:iofin,nbiit(is)-k+1)
               isvir(kkvir)=is
               occup3v(kkvir)=occup(nbiit(is)-k+1)
               tipov3(kkvir)(1:llabel)=orb(1:llabel)
               jlvir(kkvir)=il
               if(yw)print*,'is',is
               if(yw)print*,'nbaltot',nbaltot
               if(yw)print*,'ndims,ndims0',ndims,ndims0
               if(yw)print*,'v2',v(1:iofin,nbii(is)-k+1+nbiit(is-1))
               if(yw)print*,'nor2',nor2
               if(yw)print*,'nbii(is)',nbii(is)
               call flush(6)
               if(yw)print*,ii2(jd1:jd2)-ndims0
               if(yw)print*,'ii2(jd1:jd2)-ndims0',ii2(jd1:jd2)-ndims0
               if(yw)print*,'ii2',ii2(jd1:jd2)
c               if(yw)call scripto(u(1:ndims,nd1:nd2),ndims,ndims,ndims,
c     *         ndims,orbi(nd1:nd2))
            enddo
            nboctots(is)=nboctots(is)+nbocs(is,il)
            nbaltots(is)=nbaltots(is)+nbals(is,il)
         enddo
c------------------------------------------------------
c        fin de la boucle sur les symetries
c        les orbitales de la liaison il ont ete rajoutees
c        a la grande matrice
c------------------------------------------------------
         if(yw) then
            print*,'oocc a la fin'
            call scripto(oocc(1:norb,1:ioc),norb,ioc,norb,
     *      ioc,orbi)
            print*,'ovir a la fin'
            call scripto(ovir(1:norb,1:ial),norb,ial,norb,
     *      ial,orbi)
         endif
c------------------------------------------------------
c        fin de la boucle sur les liaisons
c        les orbitales de la liaison il ont ete rajoutees
c        a la grande matrice
c------------------------------------------------------
      print*,
     *'*===========================================================*'
      enddo
      if(yw)print*,'isocc',isocc(1:ioc)
      if(yw)print*,'isvir',isvir(1:ial)
c
c-------------------------------------------------------
c     on regroupe les orbitales par symetrie
c-------------------------------------------------------
c
      kk=0
      nsoc=0
      deallocate (u)
      deallocate (ul)
      allocate (u(norb,ioc))
      allocate (ul(norb,ial))
      allocate(occup4o(ioc))
      allocate(occup4v(ial))
      allocate(tipoo(ioc))
      allocate(tipov(ial))
      tipoo=' ' ; tipov=' '
      do is=1,nsym
         ndims=isym(is)
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         do k=1,ioc
            if(is.eq.isocc(k)) then
               kk=kk+1
               iordocc(kk)=k
               u(1:ndims,kk)=oocc(ndims0+1:ndims0+ndims,k)
               occup4o(kk)=occup3o(k)
               tipoo(kk)=tipoo3(k)
               if(yw)print*,'tipoo',kk,tipoo(kk)
               nsoc(is)=nsoc(is)+1
            endif
         enddo
      enddo
      if(yw) then
         do k=1,nl
            print*,'il,ioproj',il,ioproj(1:noproj(k),k)
         enddo
      endif
         if(yw) then
            print*,'us a la fin'
            do is=1,nsym
               ndims=isym(is)
               ndims0=isymt(is-1)
               nd1=1+ndims0
               nd2=ndims+ndims0
!               call scripto(u(1:ndims,nd1:nd2),ndims,ndims,ndims,
!     *         ndims,orbi(nd1:nd2))
                  print*,'fin liaison  sym',is,' ioref',ioref(1:nl)
                  print*,'fin liaison  sym',is,' jproj',jproj(1:nbp)
            enddo
         endif
      nsoc2=nsoc
      do is=1,nsym
         nsoc(is)=nsoc(is)+nsoc(is-1)
      enddo
      if(yw)print*,'nsoc',nsoc(1:nsym)
      if(nprint.ge.1) then
         do is=1,nsym
            ndims=isym(is)
            if(ndims.eq.0) cycle
            print*,'orbitales occupees (avant projection,',
     *      ' dans la base des OAO)   sym',is
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            ideb=nsoc(is-1)+1
            ifin=nsoc(is)
            il=ifin-ideb+1
            call scripto1(u(1:ndims,ideb:ifin),ndims,il,ndims,
     *      il,orbi(nd1:nd2))
         enddo
      endif
c         print3001,'occup4o',occup4o(1:kkocc)
c         print3001,'occup4v',occup4v(1:kkvir)
c
      kk=0
      nsal=0
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         do k=1,ial
            if(is.eq.isvir(k)) then
               kk=kk+1
               iordvir(kk)=k
               ul(1:ndims,kk)=ovir(ndims0+1:ndims0+ndims,k)
               occup4v(kk)=occup3v(k)
               tipov(kk)=tipov3(k)
               if(yw)print*,'tipov',kk,tipov(kk)
               nsal(is)=nsal(is)+1
            endif
         enddo
      enddo
      nsal2=nsal
      do is=1,nsym
         nsal(is)=nsal(is)+nsal(is-1)
      enddo
      print*,'nsal',nsal(1:nsym)
      if(nprint.ge.1) then
         do is=1,nsym
            ndims=isym(is)
            if(ndims.eq.0) cycle
            print*,'orbitales virtuelles (avant projection)',
     *      ' dans la base des OAO   sym',is
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            ideb=nsal(is-1)+1
            ifin=nsal(is)
            il=ifin-ideb+1
            call scripto1(ul(1:ndims,ideb:ifin),ndims,il,ndims,
     *      il,orbi(nd1:nd2))
         enddo
      endif
c------------------------------------------------------
c     fin de la boucle sur les liaisons
c------------------------------------------------------
c------------------------------------------------------
c     projections
c------------------------------------------------------
 3000 format(a20,10(10i4),/)
 3002 format(a42,10(10i4),/)
 3001 format(a20,10(f8.4),/)
      if(yw) then
         do k=1,nl
            print*,'il,ioproj',il,ioproj(1:noproj(k),k)
         enddo
         print3000,'projection    ioref',ioref(1:nl)
         print3000,'projection    jproj',jproj(1:nbp)
         print3000,'jlocc',jlocc(1:ioc)
         print3000,'jlvir',jlvir(1:ial)
         print3000,'iordocc',iordocc(1:ioc)
         print3000,'iordvir',iordvir(1:ial)
         call flush(6)
      endif
      jlocc(1:ioc)=jlocc(iordocc(1:ioc))
      jlvir(1:ial)=jlvir(iordvir(1:ial))
      if(yw) then
         print3000,'jlocc',jlocc(1:ioc)
         print3000,'jlvir',jlvir(1:ial)
      endif
      print*,' '
      ifin=0
      do kk=1,ioc,10
         ideb=ifin+1
         ifin=min(ideb+9,ioc)
         print3000,'orbitales occ', (i,i=ideb,ifin)
         print3000,'liaisons     ', (jlocc(i),i=ideb,ifin)
         print*,' '
      enddo
      ifin=0
      do kk=1,ial,10
         ideb=ifin+1
         ifin=min(ideb+9,ial)
         print3000,'orbitales vir', (i,i=ideb,ifin)
         print3000,'liaisons     ', (jlvir(i),i=ideb,ifin)
         print*,' '
      enddo
      print*,'nombre d''occupees par symetrie  ',(nsoc(k)-nsoc(k-1)
     *,k=1,nsym)
      print*,'nombre de virtuelles par symetrie',(nsal(k)-nsal(k-1)
     *,k=1,nsym)
      kk=0
      ivirt=0
      do k=1,norb
         if(yvirt(k)) then
            kk=kk+1
            ivirt(kk)=k
         endif
      enddo
      nvirt=0
      kk=0
      do is=1,nsym
         do jj=1,isym(is)
            kk=kk+1
            ndims=isym(is)
            if(ndims.eq.0) cycle
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            if(yvirt(kk)) nvirt(is)=nvirt(is)+1
         enddo
      enddo
      !print'(''yvirt'',30l1)', yvirt(1:norb)
      !print'(''ivirt'',30i3)', ivirt(1:kk)
      write(50) kk,ivirt(1:kk)
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
c            print*,'us avant projection',ndims
c            call scripto(u(1:ndims,nd1:nd2),ndims,ndims,ndims,
c     *      ndims,orbi(nd1:nd2))
         ideb=nsoc(is-1)+1
         ifin=nsoc(is)
         idf=ifin-ideb+1
!         if(idf.gt.nfix) stop' occ nfix trop grand'
         print*,ideb,ifin
         if(ideb.le.ifin)
     *   call proj(jlocc(ideb:ifin),nl,u(1:ndims,ideb:ifin),ndims,
     *   idf,nd1,nd2,ioproj,ioref,is,iocp(is),occup4o(ideb:ifin),
     *   tipoo(ideb:ifin),norb,maxproj,noproj)
c        on compte les "V"
         nsoc3(is)=0
         do k=ideb,ifin
            ll=index(tipoo(k),'_')
            if(ll.eq.0) ll=len_trim(tipoo(k))
            if(index(tipoo(k)(1:ll),'V').ne.0) nsoc3(is)=nsoc3(is)+1
         enddo
         ifin=ifin-iocp(is)
         ideb=nsal(is-1)+1
         ifin=nsal(is)
         idf=ifin-ideb+1
!         if(idf.gt.nfix) stop' al nfix trop grand'
         if(ideb.le.ifin)
     *   call proj(jlvir(ideb:ifin),nl,ul(1:ndims,ideb:ifin),ndims,
     *   idf,nd1,nd2,ioproj,ioref,is,ialp(is),occup4v(ideb:ifin),
     *   tipov(ideb:ifin),norb,maxproj,noproj)
         ifin=ifin-ialp(is)
      enddo
c     on enleve les orbitales eliminees par projection
c     nsoc2 est le nb d'orbitales occupees par symetrie
      nsoc2(1:nsym)=nsoc2(1:nsym)-iocp(1:nsym)
      nsal2(1:nsym)=nsal2(1:nsym)-ialp(1:nsym)
      write(50) nsoc2(1:nsym)-nsoc3(1:nsym),nsal2(1:nsym)+nsoc3(1:nsym)
!      write(50) nsoc2(1:nsym)-nsoc3(1:nsym),(isym(k)-nsoc2(k)+nsoc3(k),
!     *k=1,nsym)
      if(yw)print*,'nsoc',nsoc
      noc=nsoc(nsym)-sum(iocp(1:nsym))
      if(yw)print*,'noc',noc
      if(yw)print*,'iocp',iocp(1:nsym)
      if(yw)print*,'ialp',ialp(1:nsym)
      iecro=0
      iecrv=0
      print*,' '
      print*,' '
      print*,'========ORBITALES NON ORTHOGNALES FINALES=========='
      noac=0
      rewind 20
      deallocate(u2)
      open(53,status='scratch',form='unformatted')
      open(54,status='scratch',form='unformatted')
      open(55,status='scratch',form='unformatted')
      kkvirt=0
      noac=0
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         allocate(u2(ndims,ndims))
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         ideb=nsoc(is-1)+1
         ifin=nsoc(is)-iocp(is)
         idebo=ideb
         ifino=ifin
         idf=ifin-ideb+1
         kkk=0
         if(ideb.gt.ifin) then
            write(50) idf,ndims
            read(20)
            goto 15
         endif
         write(75,*)' symetrie',is,' occupations et orbitales$'
         call scril
c        on reordonne en fonction du type de l'orbitale
         call reortypo(ndims,ifin-ideb+1,occup4o(ideb:ifin),
     *   tipoo(ideb:ifin),u(1:ndims,ideb:ifin),ngelo(is))
         if(yw)print'(14x,10f8.4)',(occup4o(ideb:ifin))
c         print'(14x,10a8)',(tipoo(ideb:ifin))
c        on recalcule les occupations
         !print*,'lecture 20',ndims
         read(20) ur(1:ndims,1:ndims)
         !u1(1:ndims,ideb:ifin)
!         call script(u(1:ndims,ideb:ifin),ndims,idf,ndims,idf)
         u2(:,1:idf)
     *   =matmul(ur(1:ndims,1:ndims),u(1:ndims,ideb:ifin))
!         call script(u2(:,1:idf),ndims,idf,ndims,idf)
         do k=ideb,ifin
            occup4o(k)=
     *      dot_product(u(1:ndims,k),u2(:,k-ideb+1))
!*      dot_product(u(1:ndims,k),u1(1:ndims,k))
         enddo
!         print'(14x,10f8.4)',(occup4o(ideb:ifin))
         kk=0
         do k=ideb,ifin
            llabel0=index(tipoo(k),'_')-1
            if(llabel0.eq.-1) llabel0=len_trim(tipoo(k))
            kk=kk+1
            if(index(tipoo(k)(1:llabel0),'A').ne.0) then
               if(numac0(1).eq.0.or.yac0(isymt(is-1)+kk)) then
                  !noac=noac+1
                  !numac(noac)=isymt(is-1)+kk
c                  print*,'Noac,isymt(is-1)+kk',noac,isymt(is-1)+kk
               else
c                  print*,'coucou5',k,tipoo(k)(1:1)
                  !tipoo(k)(1:1)='O'
               endif
            endif
         enddo
c        on complete la base par des orbitales atomiques sur
c        les virtuelles qui n'ont pas ete donnees
c        on passe les orbitales marquees "V" dans les virtuelles
         kk=ideb-1
         do k=ideb,ifin
            ll=index(tipoo(k),'_')
            if(ll.eq.0) ll=len_trim(tipoo(k))
            if(yw)print*,'tipoo',k,tipoo(k)
            if(index(tipoo(k)(1:ll),'V').eq.0) then
               kk=kk+1
               !u1(1:ndims,kk)=u(1:ndims,k)
               u2(:,kk-ideb+1)=u(1:ndims,k)
               tipoo(kk)=tipoo(k)
               occup4o(kk)=occup4o(k)
            else
c               print*,'coucou'
               kkk=kkk+1
               s(1:ndims,kkk)=u(1:ndims,k)
               tipov3(kkk)=tipoo(k)
               !if(kkk>ial) stop'kkk'
               occup(kkk)=occup4o(k)
            endif
         enddo
         ifin=kk
         !write(50) ifin-ideb+1,ndims,u1(1:ndims,ideb:ifin)
!         write(50) ifin-ideb+1,ndims,u2(:,1:idf)
!     *   ,occup4o(ideb:ifin),tipoo(ideb:ifin)
         !call scriptol(u1(1:ndims,ideb:ifin),ndims,idf-kkk,ndims,
!         call scriptol(u2(:,1:idf),ndims,idf-kkk,ndims,
!     *   idf-kkk,orbi(nd1:nd2),
!     *   (/(isymt(is-1)+k,k=1,idf-kkk)/),
!     *   tipoo(ideb:ifin),occup4o(ideb:ifin))
c
c        on recommence pour les virtuelles
c
 15      continue
         iecro=nsoc(is)
         ideb=nsal(is-1)+1
         ifin=nsal(is)-ialp(is)
         idfo=idf
         idf=ifin-ideb+1
         idfv=idfo+idf
         if(ideb.gt.ifin) then
            write(50) idf,ndims
            goto 16
!            print*,'Deallocate',is
!            deallocate(u2)
!            kkvirt=kkvirt+ndims-idfv
!            cycle
         endif
         call reortypv(ndims,ifin-ideb+1,occup4v(ideb:ifin),
     *   tipov(ideb:ifin),ul(1:ndims,ideb:ifin),ngelv(is))
         if(yw)print'(14x,10f8.4)',(occup4v(ideb:ifin))
c         print'(14x,10a8)',(tipov(ideb:ifin))
c        on recalcule les occupations
         !u1(1:ndims,ideb:ifin)
         ur(1:ndims,1:idf)
     *   =matmul(ur(1:ndims,1:ndims),ul(1:ndims,ideb:ifin))
         do k=ideb,ifin
            occup4v(k)=
!*      dot_product(ul(1:ndims,k),u1(1:ndims,k))
     *      dot_product(ul(1:ndims,k),ur(1:ndims,k-ideb+1))
         enddo
!         print'(14x,10f8.4)',(occup4v(ideb:ifin))
         kk=0
         do k=ideb,ifin
            llabel0=index(tipov(k),'_')-1
            kk=kk+1
            if(index(tipov(k)(1:llabel0),'A').ne.0) then
               if(numac0(1).eq.0.or.yac0(isymt(is-1)+kk+nsoc2(is))) then
                  !noac=noac+1
                  !numac(noac)=isymt(is-1)+kk+nsoc2(is)
c                  print*,'noac,...',noac,isymt(is-1)+kk+nsoc2(is)
               else
                  !tipov(k)(1:1)='O'
c                  print*,'coucou6',k
               endif
               if(yw)print*,'noac,numac',noac,numac(1:noac)
            endif
         enddo
         kkk1=kkk+idfo
         if(kkk1+idf.gt.ndims) then
            print*,'sym',is,'  nombre d''orb trop grand !',kkk1+idf,
     *      ndims
            call verif
         endif
         !u1(1:ndims,1:kkk)=s(1:ndims,1:kkk)
         u2(:,1+idfo:kkk1)=s(1:ndims,1:kkk)
         !u1(1:ndims,kkk+1:kkk+idf)=ul(1:ndims,ideb:ifin)
         u2(:,kkk1+1:kkk1+idf)=ul(1:ndims,ideb:ifin)
         !occup(kkk+1:kkk+idf)=occup4v(ideb:ifin)
         occup(kkk1+1:kkk1+idf)=occup4v(ideb:ifin)
         !tipov3(kkk+1:kkk+idf)=tipov(ideb:ifin)
         tipov3(kkk1+1:kkk1+idf)=tipov(ideb:ifin)
         idf=idf+kkk
 
         !write(50) idf,ndims,u1(1:ndims,1:idf)
!*   ,occup(1:idf),tipov3(1:idf)
!         write(50) idf,ndims,u2(:,idfo+1:idfv)
!     *   ,occup(idfo+1:idfv),tipov3(idfo+1:idfv)
         !call scriptol(u1(1:ndims,1:idf),ndims,idf,ndims,
!*   idf,orbi(nd1:nd2),
!*   (/(isymt(is-1)+nsoc2(is)-kkk+k,k=1,idf)/),
!*   tipov3(1:idf),occup(1:idf))
!         call scriptol(u2(:,idfo+1:idfv),ndims,idf,ndims,
!     *   idf,orbi(nd1:nd2),
!     *   (/(isymt(is-1)+nsoc2(is)-kkk+k,k=1,idf)/),
!     *   tipov3(idfo+1:idfv),occup(idfo+1:idfv))
         iecrv=iecrv+ndims-nsoc2(is)
 16      continue
         !print*,'idfv',idfv
         !print*,'sum',isym(is)-nvirt(is)
         if(isym(is)-nvirt(is)<idfv) then
            print'(a,i1,3a)'
     *      ,'Dans cette symetrie (',is,'), le nombre de'
            print*,' liaisons est superieur au nombre d''OA pour les',
     *      ' decrire'
            print*,idfv,' liaisons'
            print*,isym(is)-nvirt(is),' OA'
            print*,'Plus d''OA doivent apparaitre'
            call infodebug(nsym,is)
            call verif
            stop
         endif
! on complete les orbitales par les OA pures
         do k=idfo+1,idfv
         enddo
         tipo(idfo+1:idfv)=tipov3(idfo+1:idfv)
         u2(1:ndims,idfv+1:ndims)=0.d0
         !print'(a,50i5)','ivirt',ivirt
         do k=idfv+1,ndims
            kkvirt=kkvirt+1
            if(ivirt(kkvirt)==0) exit
            ivv=ivirt(kkvirt)-isymt(is-1)
            ivv1=ivirt(kkvirt)
            !print'(a,12i5)','k,kkvirt,ivv,ivv1',k,kkvirt,ivv,ivv1
            if(ivv>ndims) cycle
            if(ivv.le.0) then
               print*,'Il y a un probleme dans les occupations des',
     *         ' orbitales.'
               print*,'ce probleme apparait quand on a voulu '
     *         ,'completer la base des liaisons par des OA'
               print*,'Vous avez sans doute defini trop de liaisons',
     *         ' par rapport aux OA qui apparaissent dansles donnees'
               print*,'Verifiez entre autres aussi les gaps'
               print*,'symetrie',is
               print*,'nombre de liaisons occupees dans la sym',idfo
               print*,'nombre de liaisons non occupees dans la sym'
     *         ,idfv-idfo
               print*,'nombre total d''orbitales dans la symetrie'
     *         , ndims
               print*,'nombre de liaisons rajoutees sous forme d''OA',
     *         ' dans les sym precedentes',kkvirt
               print*,'ivv,kkvirt',ivv,kkvirt
               print*,'ivv1',ivv1
               print*,'k,idfv,ndims,is,isymt(is-1)',k,idfv,ndims,is
     *         ,isymt(is-1)
               print*,'ivirt',ivirt
     *         ,isymt(is-1)
               call verif
               stop
            endif
            tipov3(k)='T_'//trim(orbi(ivv1)(1:4))//'.'
     *      //trim(orbi(ivv1)(5:8))
            !print*,'is,ivv,orbi',is,ivv,orbi(ivv)
            !print*,'is,ivv1,orbi',is,ivv1,orbi(ivv1)
            u2(ivv,k)=1.d0
            occup(k)=0.d0
            if(yw)print*,'ivirt(kkvirt)-ndims0,k',ivirt(kkvirt)-ndims0,k
         enddo
! on reordonne dans l'ordre inactives-actives-virtuelles
         noacs(is)=0
         call reoriav(u2(:,1:idfo),occup4o(idebo:ifino),
     *   tipoo(idebo:ifino),'occ',ndims,idfo,ifino-idebo+1,
     *   ifino-idebo+1,ndims,noacs(is))
         call reoriav(u2(:,idfo+1:ndims),occup(idfo+1:ndims),
     *   tipov3(idfo+1:ndims),'vir',ndims,ndims-idfo,ndims-idfo,
     *   ndims-idfo,ndims,noacs(is))
         kk=0
         do k=idebo,ifino
            kk=kk+1
            if(tipoo(k)(1:1)=='A') then
               if(numac0(1).eq.0.or.yac0(isymt(is-1)+kk)) then
                  noac=noac+1
                  numac(noac)=isymt(is-1)+kk
!                  print*,'noac,k,kk,isymt(is-1)+kk'
!     *            ,noac,k,kk,isymt(is-1)+kk
               else
                  tipoo(k)(1:1)='O'
               endif
            endif
         enddo
         do k=idfo+1,ndims
            kk=kk+1
            if(tipov3(k)(1:1)=='A') then
               if(numac0(1).eq.0.or.yac0(isymt(is-1)+kk)) then
                  noac=noac+1
                  numac(noac)=isymt(is-1)+kk
!                  print*,'v noac,k,kk,isymt(is-1)+kk'
!     *            ,noac,k,kk,isymt(is-1)+kk
               else
                  tipov3(k)(1:1)='O'
               endif
            endif
         enddo
!         call reoriav(u2(:,1:idfo),occup4o(idebo:ifino),
!     *   tipoo(idebo:ifino),'occ',ndims,idfo,ifino-idebo+1,
!     *   ifino-idebo+1,ndims)
!         call reoriav(u2(:,idfo+1:ndims),occup(idfo+1:ndims),
!     *   tipov3(idfo+1:ndims),'vir',ndims,ndims-idfo,ndims-idfo,
!     *   ndims-idfo,ndims)
            



         
         print*,' '
         print*,'occupees'
         print*,' '
         call scriptol(u2(:,1:idfo),ndims,idfo,ndims,
     *   idfo,orbi(nd1:nd2),
     *   (/(isymt(is-1)+k,k=1,idfo)/),
     *   tipoo(idebo:ifino),occup4o(idebo:ifino))
         print*,' '
         print*,'virtuelles de valence   sym',is
         print*,' '
         call scriptol(u2(:,idfo+1:idfv),ndims,idf,ndims,
     *   idf,orbi(nd1:nd2),
     *   (/(isymt(is-1)+nsoc2(is)-kkk+k,k=1,idf)/),
     *   tipov3(idfo+1:idfv),occup(idfo+1:idfv))
! on preecrit
         write(53) u2
         write(54) occup4o(idebo:ifino),occup(idfo+1:ndims)
         write(55) tipoo(idebo:ifino),tipov3(idfo+1:ndims)
         deallocate(u2)
      enddo
! on ecrit le fichier d'orbitales en clair
      rewind 53
      rewind 54
      rewind 55
      open(56,status='scratch',form='unformatted')
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(53) u1(1:ndims,1:ndims)
         write(56) u1(1:ndims,1:ndims)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(54) occup(1:ndims)
         write(56) occup(1:ndims)
      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         read(55) tipo(1:ndims)
         write(56) tipo(1:ndims)//'      '
      enddo
      close(53)
      close(54)
      close(55)
      call ecriorb('* Orbitales Locales NON orthogonales (Schmudorb)',
     *'NONORLOC',nsym,isym,56,53)
      print*,'debut modif NADIA'
!
!NADIA : creation de LoInfo necessaire pour exsci
!--------------------------------------------------------
!     reorder LO's
!--------------------------------------------------------
!
      kk=0
      allocate(iord(norb))
      allocate(fsym(norb*gap))
      iord=0
!      do k=1,norb
!         print*,'LO',k,flab(k),fsym(k),focvir(k)
!      enddo
      do is=1,nsym
         call cherchelo(is,'OCC ','G',kk,iord,norb)
         call cherchelo(is,'OCC ','C',kk,iord,norb)
         call cherchelo(is,'OCC ','O',kk,iord,norb)
         call cherchelo(is,'ACTO','A',kk,iord,norb)
         call cherchelo(is,'ACTV','A',kk,iord,norb)
         call cherchelo(is,'VIRT','O',kk,iord,norb)
         call cherchelo(is,'VIRT','T',kk,iord,norb)
         call cherchelo(is,'VIRT','G',kk,iord,norb)
      enddo
      fsym(1:norb)=fsym(iord(1:norb))
      focc(1:norb)=focc(iord(1:norb))
      deallocate(work2)
      allocate(work2(norb,norb))
      do k1=1,norb
         do k=1,norb
            work2(k,k1)=flo(k,iord(k1))
         enddo
      enddo
      flo(1:norb,1:norb)=work2
      flab(1:norb)=flab(iord(1:norb))
      fdat1(1:norb)=fdat1(iord(1:norb))
      focvir(1:norb)=focvir(iord(1:norb))
      atoms_in_LO(1:norb,:)=atoms_in_LO(iord(1:norb),:)
      fnat(1:norb)=fnat(iord(1:norb))
      nwk=norb
      iwk=(/(k,k=1,nwk)/)
      frozen=0
      delete=0
      do is=1,nsym
         print*,'SYM',is
         do k=isymt(is-1)+1,isymt(is-1)+fermi0(is)
            if(flab(k)(1:1)=='G') frozen(is)=frozen(is)+1
         enddo
         do k=isymt(is-1)+fermi0(is)+1,isymt(is)
            if(flab(k)(1:1)=='G') delete(is)=delete(is)+1
         enddo
         print'(40a2)',flab(isymt(is-1)+1:isymt(is))(1:1)//' '
      enddo

!--------------------------------------------------------
!     Create file containing the various fl...
!--------------------------------------------------------
!
       call crea_LoOinfo(iord,norb)
! fin nadia

      close(53)
      do k=nsym,1,-1
         nsoc(k)=nsoc(k)-nsoc(k-1)
         nsal(k)=nsal(k)-nsal(k-1)
      enddo
      nsoc(1:nsym)=nsoc(1:nsym)-iocp(1:nsym)
      nsal(1:nsym)=nsal(1:nsym)-ialp(1:nsym)
      print*,'     ORBITALES MOLECULAIRES ("LIAISONS") DONNEES'
      print3002,'Nombre d''occupees par symetrie          ',
     *(nsoc(k),k=1,nsym)
      print3002,'Nombre de virtuelles de valence par sym ',
     *(nsal(k),k=1,nsym)
      print3002,'                            total       ',
     *nsoc(1:nsym)+nsal(1:nsym)
      print3002,'dont :                                  '
      print3002,'Nombre d''orb de coeur par symetrie     ',
     *(icore(k),k=1,nsym)
      print3002,'Nombre d''orb gelees par symetrie       ',
     *(igel(k),k=1,nsym)
      print3002,'Nombre d''actives par symetrie          ',
     *(noacs(k),k=1,nsym)
      open(50,status='unknown',file='OAO',form='unformatted')
      print*,' '
      print*,'     ORBITALES ATOMIQUES'
      print3002,'nombre total d''orb par symetrie        ',
     *(isym(k),k=1,nsym)
!     nn=0
!     do k=1,norb
!        if(.not.yvirt(k)) nn=nn+1
!     enddo
      print*,' '
      print*,'     ORBITALES ATOMIQUES PRESENTES DANS LES DONNEES'
      print3002,'nombre d''OA presentes                   ',
     *isym(1:nsym)-nvirt(1:nsym)
      print3002,'nombre d''OA virtuelles par symetrie (qui'
      print3002,'n''apparaissent pas dans les donnees)    ',
     *nvirt(1:nsym)
      ierr=0
      ierr1=0
      do is=1,nsym
         if(nsoc(is)+nsal(is)+nvirt(is).ne.isym(is)) ierr=1
         if(nsoc2(is).ne.fermi0(is)) ierr1=1
      enddo
c      if(nsoc(1:nsym)+nsal(1:nsym)+nvirt(1:nsym).eq.isym(1:nsym)) then
      print*,' '
 
      if(ierr.eq.0.and.ierr1.eq.0) then
         print*,'*******FIN CORRECTE DU CALCUL*******'
         print*,'on a bien :'
      else if(ierr.eq.0) then
         print*,'*******ERREUR********'
         print*,'NIVEAU DE FERMI MAL POSITIONNE'
         print*,'on doit avoir :'
      else if(ierr1.eq.0) then
         print*,'*******ERREUR********'
         print*,'MAUVAIS NOMBRE D''ORBITALES'
         print*,'on doit avoir :'
      else
         print*,'*******ERREUR********'
         print*,'NIVEAU DE FERMI MAL POSITIONNE'
         print*,'MAUVAIS NOMBRE D''ORBITALES'
         print*,'on doit avoir :'
      endif
      print3002,'nombre d''OA presentes dans les donnees  ',
     *isym(1:nsym)-nvirt(1:nsym)
      print3002,'= nombre total d''OM (liaisons)          ',
     *nsoc(1:nsym)+nsal(1:nsym)
      print3002,'niveau de fermi des orbitales SCF',
     *fermi0(1:nsym)
      print3002,'= nombre total d''OM (liaisons) occupees ',
     *nsoc2(1:nsym)
      print*,' '
      if(ierr.ne.0.or.ierr1.ne.0) call verif
      if(ierr.eq.0.or.ierr1.eq.0) then
         do is=1,nsym
            y=.false.
            if(nsoc(is)+nsal(is)+nvirt(is).ne.isym(is)) y=.true.
            if(nsoc2(is).ne.fermi0(is)) y=.true.
            if(y) then
               print*,'orbitales de la symetrie ',is
               call infodebug(nsym,is)
            endif
         enddo
      endif
      print*,' '
!      print*,'*******DONNEES PAR DEFAUT DE SCHMUDORT*******'
!      write(6,'(a12,20(i3,'',''))') ' &ort icore=',
!     *icore(1:nsym)+igel(1:nsym)
!      write(6,'(a,20(i3,'',''))') ' numac=',numac(1:noac)
      write(6,'(a)') ' /'
      print*,'*******DONNEES POUR MOTRA*******'
      print*,'FROZEN'
      print'(8i4)',ngelo(1:nsym)
      print*,'DELETE'
      print'(8i4)',ngelv(1:nsym)
      write(6,'(a)') ' /'
      print*,'*******DONNEES POUR MOLCOST*******'
      write(6,'(a13,20(i3,'',''))') ' &cost fermi=',
     *fermi0(1:nsym)-ngelo(1:nsym)
      write(6,'(a8,20(i3,'',''))') ' frozen=',
     *(ngelo(k),k=1,nsym)
      write(6,'(a8)') ' prefix='
      write(6,'(a8)') ' .......'
!      open(51,status='unknown',file='SCH_INFO',form='unformatted')
!      write(51) icore(1:nsym)+igel(1:nsym)
!      write(51) noac,numac(1:noac)
!      write(51) isym(1:nsym)
!      write(51) ngelo(1:nsym),ngelv(1:nsym)
!      write(51) nsoc2(1:nsym),fermi0(1:nsym)
 
      print*,' '
      print*,
     *'*===========================================================*'
      stop
      return
      end
       subroutine stoinfo(orb,nsym,nbocs,nbals)
      character(3000) orb
      dimension nbocs(nsym),nbals(nsym)
      i=index(orb,' ')
      write(76,1000) orb(1:i-1),nbocs,nbals
 1000 format(a18,16i2)
      return
      end
       subroutine infodebug(nsym,is)
      character(18) orb
      dimension nbocs(8),nbals(8)
!!!!!!!!!!!!subroutine a supprimer
      return
      rewind(76)
      call titre('occupation des OL dans cette symetrie#',40)
      noc=0
      nal=0
      print*,
     *'       ORB              occ    virt  tot occ  tot virt total'
      do
         read(76,1000,end=1) orb,nbocs(1:nsym),nbals(1:nsym)
         noc=noc+nbocs(is)
         nal=nal+nbals(is)
         write(6,1001) orb,nbocs(is),nbals(is),noc,nal,noc+nal
      enddo
 1    continue
 1000 format(a18,16i2)
 1001 format(a18,5i8)
      return
      end
! AJOUT NADIA - pour construire la file LoInfo necessaire a exsci
! cherchlo et creaLoinfo
! module dolo
       subroutine cherchelo(is,occ_loc,lab,kk,iord,norb)
      use mod_dolo
      character(4) occ_loc
      character lab
      dimension iord(norb)
!      print*,'***********************************',occ_loc,' ',lab
      do k=1,norb
!         print*,'coucou1 ',focvir(k),occ_loc
!         do i=1,4
!          print*,focvir(k)(i:i),occ_loc(i:i)
!         enddo
         if(fsym(k)/=is) cycle
         if(focvir(k)==occ_loc) then
!         print*,'coucou2 ',flab(k)(1:1),lab
            if(flab(k)(1:1)==lab) then
               kk=kk+1
               iord(kk)=k
!               print*,'cherche',kk,k,'  ',lab,'  ',occ_loc,'  ',flab(k)
            endif
         endif
      enddo
      return
      end
       subroutine crea_LoOinfo(iord,norb)
      use mod_dolo
      dimension iord(norb)
      character(3) aov
      character(18) flab_tmp
      character(9) fsigpi_tmp
!      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      open(99,file=trim(prefix)//'LOinfo',status='unknown')
      write(99,*) norb
!
! Ecriture du fichier LOinfo contenant des infos sur les OL
!
!
!   generation de l'ordre ijkloc
! Calcul iord: ordre des OL OCC/ACTocc/ACTvirt/VIRT
!
      iord=0
      n=0
      ! 4 cas pour OCC/ACTocc/ACTvirt/VIRT
      do icas=1,4
         do i=1,norb
            if(flab(i)(1:1)=='G') cycle
            if(icas==1.and.focvir(i)/='OCC') cycle
            if(icas==2.and.focvir(i)/='ACTO') cycle
            if(icas==3.and.focvir(i)/='ACTV') cycle
            if(icas==4.and.focvir(i)/='VIRT') cycle
            if(iord(i)/=0) cycle
! on a trouve une orbitale non encore assignee
            n=n+1
            iord(i)=n
            !print*,'LOinf1',icas,n,i,flab(i),'  ',focvir(i),fsym(i)
! on cherche celles de meme nom et de meme oav (occ,act ou vir)
            do j=i+1,norb
               if(focvir(i)/=focvir(j)) cycle
               if(flab(i)==flab(j)) then
                  n=n+1
                  iord(j)=n
!                 print*,'LOinf2',icas,n,j,flab(j),'
!                 ',focvir(j),fsym(j)
               endif
            enddo
         enddo
      enddo

! fill atoms_in_lo for "T_" LO's
!
      do io=1,norb
         if(flab(io)(1:2)=='T_') then
            ind=index(flab(io),'.')
            fnat(io)=1
            atoms_in_lo(io,1)=flab(io)(3:ind-1)
         endif
      enddo
!
! end filling fsigpi. fsigpi(io) indicates if LO io is sigma,pi...
! possible values: SIG PI DIFF_S DIFF_D CORE LP
!
      do io=1,norb
         if(fsigpi(io)==' ') then
! frozen
            if(flab(io)(1:1)=='G') cycle
! core
            if(flab(io)(1:1)=='C') then
               fsigpi(io)='CORE'
               cycle
            endif
! diff
            if(flab(io)(1:1)=='T') then
               fsigpi(io)='DIFF_'
               ind=index(flab(io),'.')
               if(flab(io)(ind+1:ind+1)=='1') then
                  fsigpi(io)(6:6)=flab(io)(ind+2:ind+2)
               else if(flab(io)(ind+1:ind+1)=='2'.or.
     *         flab(io)(ind+1:ind+3)=='3d0') then
                  fsigpi(io)(6:7)=flab(io)(ind+2:ind+3)
               else if(flab(io)(ind+1:ind+1)>='3') then
                  fsigpi(io)(6:8)=flab(io)(ind+2:ind+4)
               endif
               cycle
            endif
! search suffix
            l=len_trim(flab(io))
            do k=l-1,1,-1
               if(flab(io)(k:k)=='.') then
                  if(flab(io)(k+1:k+2)=='LP') then
                     fsigpi(io)='LP'
                  else if(flab(io)(k+1:k+2)=='VI') then
                     ind=index(flab(io),'.')
                     fsigpi(io)='EMPTY_'//flab(io)(ind+1:ind+1)
                  else if(flab(io)(k+1:k+2)=='SG') then
                     fsigpi(io)='SIG'
                  else if(flab(io)(k+1:k+2)=='PI') then
                     fsigpi(io)='PI'
                  else if(flab(io)(k+1:k+2)=='DL') then
                     fsigpi(io)='PI'
                  endif
               endif
            enddo
         endif
      enddo
      do i=1,norb
         if(iord(i).ne.0) then
            flab_tmp=flab(i)
            call maj(flab_tmp,18)
            fsigpi_tmp=fsigpi(i)
            call maj(fsigpi_tmp,9)
            write(99,'(2i4,1x,a18,1x,a4,1x,a9,i4,1x,100a4)')
     *      i,iord(i),flab_tmp,focvir(i),fsigpi_tmp
     *      ,fnat(i),atoms_in_LO(i,1:fnat(i))
         endif
      enddo
      print*,' '
      close(99)
      return
      end

