      subroutine genelo(AA,nboc,nbal)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
c-----------------------------------------------------------
c     extract local density matrix
c     form LO
c-----------------------------------------------------------
c
      character(len_datlist) AA,bb
      character(4) atom1
      character(8) orbi1,orbi2
      character(300) aaa
      dimension nbii(maxsym)
      dimension nvirt(maxsym)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      integer,dimension(:),allocatable :: ii
      common/pr/nprint
 
      if(yes)print*,'entree genelo'
      rewind 92
      long=len_trim(AA)
      ywo=.false.
      yw=.false.
      !if(in_progress=='BOND') print'(/,a)', 'BOND_generated data:'
      if(in_progress=='BOND')print*,trim(AA)
 
!      write(6,*)
!     *'*===========================================================*'
      !write(6,*) 'DATA'
      !write(6,*) trim(aa)
      !write(92,*) 'DATA'
      write(92,*) trim(aa)
      write(92,*)
     *'*===========================================================*'
      write(ifilpr,*)
     *'*===========================================================*'
      write(ifilpr,*) '        -------------------------'
      write(ifilpr,*) '         Basic Data              '
      write(ifilpr,*) '        -------------------------'
      write(ifilpr,*) trim(aa)
      write(ifilpr,*) ' '
      write(ifilpr,*)
     *'*===========================================================*'
      write(ifilpr,*) ' '
!
!----------------------------------------------------------------
!     treat ORTH and PARA keywords, and cancel the information
!----------------------------------------------------------------
!
      call orientation(AA(1:long))
!
!---------------------------------------------------------
!     Read LO atoms  (loop until no more atom is found)
!---------------------------------------------------------
!
      iodeb=1
      nbii(1:nsym)=0
      iii=0
      if(yw)print*,'allo',allocated(ii)
      if(.not.allocated(ii)) allocate(ii(norb))
      if(yw)print*,'allo',allocated(ii),norb
      idebat=index(AA,' ')+1
      llabel=idebat-2
      if(llabel.gt.18) then
         print*,'too long label ',AA(1:llabel)
         stop
      endif
      fnat_tmp=0
      do
         longat=index(AA(idebat:long),' ')-1
         ifinat=idebat+longat-1
         atom1='    '
         atom1(1:longat)=AA(idebat:ifinat)
         write(92,*) 'atome  ','====',atom1,'===='
         write(ifilpr,*) 'atome  ','====',atom1,'===='
         if(yw) write(6,*) 'atome present dans le label  '
     *   ,'====',atom1,'===='
         fnat_tmp=fnat_tmp+1
         atoms_in_LO_tmp(fnat_tmp)=atom1
!
!---------------------------------------------------------
! READ ATOM lo'S
! NOR2 IS THE NUMBER OF AO PRESENT IN THE DATA
! NBII(1:NSYM) IS THE NUMBER OF AO IN EACH SYMMETRY
! II(1:NOR2) GIVES THE RANK OF THESE AO's IN THE TOTAL BASIS OF AO's
!---------------------------------------------------------
!
         if(yw)print*,'idebat,ifinat,longat',idebat,ifinat,longat
         if(yw)
     *   print*,'(le nom de l''atome, de longueur longat, est ecrit ',
     *   'de idebat a ifinat'
         ideb=idebat+longat+1
         !print*,'AA1 ',trim(AA(ideb:long))
         ideb2=index(AA(ideb:long),':')
         if(ideb2.eq.0) then
            ! il n'y a pas d'autre atomes dans la donnee
            ifin=index(AA(ideb:long),' (')+ideb-2
         else
            ifin=ideb2-3+ideb
         endif
         if(yw)print*,'ideb,ifin',ideb,ifin,aa(ideb:ifin)
         if(yw) print*,'la base de l''atome est ecrite de ideb a ifin)'
         nbo=1
         do k=ideb,ifin
            if(AA(k:k).eq.' ') nbo=nbo+1
         enddo
         if(ywo)print*,'nbo (nombre d''oOA en donnee)',nbo
         iofin=iodeb+nbo-1
         iodeb1=iodeb
         iodeb2=iodeb
c----------------------------------------------------------
c        pour l'atome atom1 :
c        boucle sur les symetries
c        puis boucle sur les orbitales concernees
c----------------------------------------------------------
         if(yw)print*,'nsym',nsym
         do is=1,nsym
            ndims=isym(is)
            ndims0=isymt(is-1)
            ideb1=ideb
            do ibo=1,nbo
!
!------------------------------------------------------------
! build orbi1 (char(8)) orbi1=atom1//1S, atom1//2P ...
! orbi1 will be compared with orbi, list of AO labels
! nu is: 1s(nu), to be compared with the nu-th orbi1 or orbi
!------------------------------------------------------------
!
               orbi1(1:4)=atom1
               orbi1(5:8)=' '
               l=index(AA(ideb1:ifin),'(')-1
               orbi1(5:5+l-1)=AA(ideb1:ideb1+l-1)
               if(ywo)print *,' '
               if(ywo)print*,'orbi1  ',orbi1
               if(ywo)print*,
     *         '(orbi1 est le label d''OA reforme a partir',
     *         ' de la donnee)'
               i=index(AA(ideb1+l+2:ifin),')')
               read(AA(ideb1+l+1:ideb1+l+i),*) nu
               nu1=0
c              on a forme l'orbitale type orbi1.
c              on cherche orbi1 dans la liste des labels d'OA
c              il faudra prendre la nu-ieme
               if(ywo)print*,'nu',nu
               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
                     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
                     if(yw)print'(a,i3,a,a,a,i5)',
     *               'trouve OA  sym=',is,'  OA    ',orbi(k),
     *               'numero ds la liste des OA:',k+ndims0
                  endif
               enddo
               i=index(AA(ideb1:ifin),' ')
               ideb1=i+ideb1
               if(ywo)print*,'nouvel ideb1 (pour l''OA suivante du',
     *         ' du string de donnee',ideb1
            enddo
         enddo
c---------------------------------------------------------------------
c end loop on symmetries and orbitals
c---------------------------------------------------------------------
         nor2=iii
         if(yw)print*,'NBII',nbii(1:nsym)
         if(yw)print*,'Ii',ii(1:norb)
         if(iodeb2.eq.iodeb1) then
            print*,'orbital index not found'
            print*,orbi1
            return
         endif
c 7       continue
!
!-----------------------------------------------------
! Used AO's are noted in yvirt
!-----------------------------------------------------
!
c        on note les OA virtuelles dans yvirt, puis a la fin de ii
         if(yw)print*,'iodeb,iofin',iodeb,iofin
         yvirt(ii(iodeb:iofin))=.false.
         yvirt(ii(1:nor2))=.false.
         if(ywo)write(6,'(a24,10i4,10(/,22x,10i4))')
     *   'OA(s) numero : ',ii(iodeb:iofin)
         if(ywo) print'(a)', 'yvirt'
         if(ywo) print'(40l1)',yvirt(1:nor2)
         !if(ifin.ne.long) then
         if(ideb2/=0) then
            idebat=ifin+4
            iodeb=iofin+1
            if(yw)print*,'idebat,iodeb',idebat,iodeb
            cycle
c           atome suivant de la liaison
         else
            exit
         endif
 
      enddo
      do is=1,nsym
         if(yw)print*,'.......................................'
         if(yw)print*,'nbii',nbii(1:nsym)
         if(yw)print*,'nor2',nor2
      enddo
c---------------------------------------------------------
c           FIN DE LA BOUCLE SUR LES ATOMES DE LA LIAISON
c---------------------------------------------------------
c
      call genelo2(AA,ii,nbii,nor2,nboc,nbal,iofin)
! Append details written on 76 to ifilpr
      rewind 76
      write(ifilpr,'(/)')
      write(ifilpr,'("-------")')
      write(ifilpr,'("Details")')
      write(ifilpr,'("-------")')
      do
         read(76,'(a300)',end=20) aaa
         write(ifilpr,'(a)') trim(aaa)
      enddo
 20   continue
      if(yes) print*,'sortie genelo'
      return
      end
       subroutine genelo2(AA,ii,nbii,nor2,nboc,nbal,iofin)
      use mod_dolo
      use mod_rotat
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      real(8),allocatable,dimension(:,:) :: ul,v,u2
      dimension ii(norb),nbii(maxsym),nbiit(0:maxsym)
      integer,dimension(:),allocatable :: ii2,ios,ios2
      double precision,dimension(:),allocatable :: w,w1,occup,occup1,
     *occup2
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      allocatable yo(:),yv(:)
      character(300) namel
      dimension nbocs(maxsym),nbals(maxsym)
      character(len_datlist) AA
      dimension icore(maxsym),igel(maxsym)
      dimension imaxloc(1)
      common/pr/nprint
      integer nbjj(maxsym),nbjjt(0:maxsym)
      yw=.false.
      ywo=.false.
      if(yes)print*,'entree genelo2',norb
      allocate(ii2(norb))
      allocate(ios2(norb))
      allocate(ul(norb,norb))
      allocate(v(norb,norb))
      allocate(u2(norb,norb))
      allocate(occup(norb))
      allocate(occup1(norb))
      allocate(occup2(norb))
      allocate(ios(norb))
      allocate(yo(norb))
      allocate(yv(norb))
!
!--------------------------------------------------------
! Loop on symmetries
!--------------------------------------------------------
!
c
c-----------------------------------------------------------
c     extract local density matrices for each symmetry
c-----------------------------------------------------------
c
      nbiit(0)=0
      nbjjt(0)=0
      iunit=76
      nbjj=nbii
      rewind 76
      do is=1,nsym
         nbiit(is)=nbiit(is-1)+nbii(is)
         nbjjt(is)=nbjjt(is-1)+nbjj(is)
         if(yw)print*,'nbii(is)',is,nbii(is)
         if(yw)print*,'nbiit(is)',is,nbiit(is)
         if(yw)print*,'nbjjt(is)',is,nbjjt(is)
         if(yw)print*,'nrot',nrot
         if(nbii(is).eq.0) cycle
         write(76,*)'.......................................'
         if(yw)write(6,*)'.......................................'
         ndims0=isymt(is-1)
         id1=nbiit(is-1)+1 ; id2=nbiit(is)
         jd1=nbjjt(is-1)+1 ; jd2=nbjjt(is)
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:nbii(is))
         ul(1:nbii(is),1:nbii(is))=
     *   gamma(ii2(id1:id2)-ndims0,ii2(id1:id2))
         if(nprint.ge.0) then
            write(76,*)'sym',is,'  matrice extraite'
            call scripto3(ul(1:nbii(is),1:nbii(is)),nbii(is),
     *      nbii(is),nbii(is),nbii(is),orbi(ii2(id1:id2)),76)
         endif
         write(76,*)' '
         write(76,'(a,i3,a,/)')
     *   'sym',is,'  occupations, orbitales naturelles'
         if(yw)write(6,*)' '
         if(yw)write(6,'(a,i3,a,/)')
     *   'sym',is,'  occupations, orbitales naturelles'
         if(nrot/=0) then
            call rotat2(ul(1:nbii(is),1:nbii(is)),nbii(is),nbjj(is),
     *      orbi(ii2(id1:id2)),sym1,nsym,is,v(1:nbii(is),jd1:jd2))
            nbjjt(is)=nbjjt(is-1)+nbjj(is)
            if(yw)print*,'nbjjt',is,nbjjt(is)
            write(76,'(14x,10f8.4)')(ul(k,k),k=1,nbjj(is))
            if(yw)write(6,'(14x,10f8.4)')(ul(k,k),k=1,nbjj(is))
            if(iofin.gt.1)call scripto3(v(1:nbii(is),jd1:jd2),
     *      nbii(is),nbjj(is),nbii(is),
     *      nbjj(is),orbi(ii2(jd1:jd2)),76)
            if(iofin.gt.1.and.yw)call scripto3(v(1:nbii(is),jd1:jd2),
     *      nbii(is),nbjj(is),nbii(is),
     *      nbjj(is),orbi(ii2(jd1:jd2)),6)
            do k=jd1,jd2
               occup(k)=ul(k-jd1+1,k-jd1+1)
               ios(k)=is
            enddo
            mor2=nbjjt(nsym)
         else
            call orientation2(ul(1:nbii(is),1:nbii(is)),nbii(is),
     *      orbi(ii2(jd1:jd2)),v(1:nbii(is),jd1:jd2),yor,orient)
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))
            do k=1,nbii(is)
               if(ul(k,k)==-10.d0) ul(k,k)=1.d0
            enddo
            write(76,'(14x,10f8.4)')(ul(k,k),k=1,nbii(is))
            if(yw)write(6,'(14x,10f8.4)')(ul(k,k),k=1,nbjj(is))
            if(iofin.gt.1)call scripto3(v(1:nbii(is),jd1:jd2),
     *      nbii(is),nbjj(is),nbii(is),nbjj(is),orbi(ii2(jd1:jd2)),76)
            if(iofin.gt.1.and.yw)call scripto3(v(1:nbii(is),jd1:jd2),
     *      nbii(is),nbjj(is),nbii(is),nbjj(is),orbi(ii2(jd1:jd2)),6)
            do k=jd1,jd2
               occup(k)=ul(k-jd1+1,k-jd1+1)
               ios(k)=is
            enddo
            mor2=nor2
         endif
      enddo
      write(76,*)'.......................................'
      if(yw)print*,'NBJJT',nbjjt(0:nsym)
      if(yw)print*,'OCCUP',occup(1:nbjjt(nsym))
      if(yw)print*,'NBOC,NBAL',nboc,nbal
      if(yw)print*,'NOR2',nor2
      if(yw)print*,'MOR2',mor2
      if(yw)print*,'nbiit',nbiit(0:nsym)
      if(yw)print*,'nrot',nrot
!
!-----------------------------------------------------------------
! nboc, nbal = nb of occ and anti-bonding LO
! let's build now  nbocs(1:nsym) and nbals(1:nsym)
! (nb of occ and anti-bonding LO's per symmetry)
! choose the nboc most occupied LO in all symmetries to build nbocs
! choose the nbal less occupied LO in all symmetries to build nbals
!-----------------------------------------------------------------
!
      mboc=nboc
      mbal=nbal
      if(yw)print*,'mboc,mbal',mboc,mbal
      mmm=maxval(isym(1:nsym))
      if(yw)print*,'ios',ios(1:mor2)
      u2=0.d0
      ios2=0
      occup1=occup
      if(yw)print*,'occup',occup(1:mor2)
      ! on cherche les mboc plus grandes occupations
      yo(1:mor2)=.false.
      do k=1,mboc
         cc=0.d0
         do l=1,mor2
            if(yo(l)) cycle
            !if(yw)print*,'l,occup(l),cc,yo(l)',l,occup(l),cc,yo(l)
            if(occup(l).ge.cc) then
               ipg=l
               cc=occup(l)
            endif
         enddo
         yo(ipg)=.true.
         if(yw)print*,'ipg',ipg,k,cc,ios(ipg)
         ios2(k)=ios(ipg)
         is=ios2(k)
         if(yw)print*,'u2',nbiit(is-1)+1,nbiit(is-1)+nbii(is),k,is
         u2(nbiit(is-1)+1:nbiit(is-1)+nbii(is),k)=v(1:nbii(is),ipg)
         occup2(k)=occup(ipg)
         if(yw)print*,'ios2',ios2(1:mor2)
         if(yw)print*,'yo',yo(1:mor2)
      enddo
      ! on cherche les mbal plus petites occupations
      if(yw)print*,'mor2',mor2
      yv(1:mor2)=.false.
      do k=1,mbal
         cc=2.d0
         do l=1,mor2
            if(yv(l)) cycle
            is=ios(l)
            if(all(v(1:nbii(is),l)<1.d-10)) cycle
            if(occup(l).le.cc) then
               ipg=l
               cc=occup(l)
            endif
         enddo
         yv(ipg)=.true.
         if(yw)print*,'ipg',ipg,k,cc,ios(ipg)
         ios2(mor2-k+1)=ios(ipg)
         is=ios2(mor2-k+1)
         u2(nbiit(is-1)+1:nbiit(is-1)+nbii(is),mor2-k+1)=
     *   v(1:nbii(is),ipg)
         occup2(mor2-k+1)=occup(ipg)
         if(yw)print*,'al ios2',ios2(1:mor2)
         if(yw)print*,'yv',yv(1:mor2)
      enddo
c
c---------------------------------------------------------
c     gaps entre les occupees et les eliminees
c     et les eliminees et les virtuelles
c---------------------------------------------------------
c
      nelim=mor2-nboc-nbal
      occumin=2.d0
      elimin=2.d0
      almin=2.d0
      occumax=0.d0
      elimax=0.d0
      almax=0.d0
      k=0
      do is=1,nsym
         do i=1,nbjj(is)
         k=k+1
         !write(76,*)'k,yo(k),yv(k)',k,yo(k),yv(k)
         if(.not.yo(k)) then
            if(.not.yv(k)) then
!              si le vecteur est nul, il a ete projete par orientation
!              ne pas alors le considerer dans les elimines
!              (ni occ ni virt)
               if(all(v(1:nbii(is),k)<1.d-10)) cycle
               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
      enddo
      namel=' '
      namel(8:58)=
     *'...        /  /        ...         /  /         ...'
      write(76,*)' '
      write(76,'(70a1)')('-',k=1,70)
      write(76,*) '   Occupees               Eliminees   '//
     *'          A-L, Virtuelles'
      if(yw)write(6,*)' '
      if(yw)write(6,'(70a1)')('-',k=1,70)
      if(yw)write(6,*) '   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
      write(76,'(a)')trim(namel)
      write(76,*)' '
      if(yw)write(6,'(a)')trim(namel)
      if(yw)write(6,*)' '
      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
      write(76,'(a)')namel(1:51)
      if(yw)write(6,'(a)')namel(1:51)
c     *print'(a,f9.4,a,f9.4)',' Gaps :   O/E',occumin-elimax,'   E/V'
c     *Elimin-almax
      ywarn=.false.
      if(nboc.ne.0.and.nelim.ne.0.and.occumin-elimax.lt.0.3) then
         ywarn=.true.
         write(76,*)'******WARNING******* Small Occ/Elim gap'
         if(yw)write(6,*)'******WARNING******* Small Occ/Elim gap'
         write(89,'(a,f10.4)')
     *   '******WARNING******* Small Occ/Elim gap',occumin-elimax
         write(6,'(a,f10.4)')
     *   '******WARNING******* Small Occ/Elim gap',occumin-elimax
      endif
      if(nbal.ne.0.and.nelim.ne.0.and.elimin-almax.lt.0.3) then
         ywarn=.true.
         write(76,*)'******WARNING******* Small Elim/virt gap'
         if(yw)write(6,*)'******WARNING******* Small Elim/virt gap'
         write(89,'(a,f10.4)')
     *   '******WARNING******* Small Elim/virt gap',elimin-almax
         write(6,'(a,f10.4)')
     *   '******WARNING******* Small Elim/virt gap',elimin-almax
      endif
      if(nboc.ne.0.and.nbal.ne.0.and.occumin-almax.lt.0.3) then
         ywarn=.true.
         if(yw)write(6,*)'******WARNING******* Small Occ/Virt gap'
         write(76,*)'******WARNING******* Small Occ/Virt gap'
         write(89,'(a,f10.4)')
     *   '******WARNING******* Small Occ/Virt gap',occumin-almax
         write(6,'(a,f10.4)')
     *   '******WARNING******* Small Occ/Virt gap',occumin-almax
      endif
      if(ywarn) then
         print'(a)', 'Corresponding basic data:'
         print'(i5,a)', idatlist,'  '//trim(aa)
         print*,' '
         write(89,'(a)') 'Corresponding basic data:'
         write(89,'(i5,a)') idatlist,'  '//trim(aa)
         write(89,*)'============================================='
      endif
       !if(iunit5==5) stop
!
!------------------------------------------------------------
! no warning if data are read on OLD_DATA
!------------------------------------------------------------
!
      if(iunit5==91) ywarn=.false.
!
!------------------------------------------------------------
! nb of Lo per symmetry
!------------------------------------------------------------
!
      if(yw)print*,'ios2',ios2(1:mor2)
      if(yw)call scripto(u2(1:nor2,1:mor2),
     *nor2,mor2,nor2,mor2,orbi(ii(1:nor2)))
      nbocs(1:nsym)=0
      nbals(1:nsym)=0
      do k=1,mboc
         nbocs(ios2(k))=nbocs(ios2(k))+1
      enddo
      do k=mor2,mor2-mbal+1,-1
         nbals(ios2(k))=nbals(ios2(k))+1
      enddo
      write(76,'(a45,8i3)')
     *'nombre d''orbitales occupees par symetrie    '
     *,nbocs(1:nsym)
      write(76,'(a45,8i3)')
     *'nombre d''orbitales anti-liantes par symetrie'
     *,nbals(1:nsym)
      if(yw)write(6,'(a45,8i3)')
     *'nombre d''orbitales occupees par symetrie    '
     *,nbocs(1:nsym)
      if(yw)write(6,'(a45,8i3)')
     *'nombre d''orbitales anti-liantes par symetrie'
     *,nbals(1:nsym)
!
!------------------------------------------------------------
! Display if warning
!------------------------------------------------------------
!
      if(ywarn) then
         namel=' '
         write(6,form_dolo) 'Display details (Y/N) ?'
 20      continue
         read(5,'(a1)') reponse
          print*,'lect dans genelo'
         call maj(reponse,1)
         print*,reponse
         if(reponse=='Y') then
            rewind 76
            do
               read(76,'(a300)',end=10) namel
               print'(a)', trim(namel)
            enddo
 10         continue
 30         continue
            write(6,form_dolo)'change data (Y/N) ?'
            read(5,'(a1)') reponse
            call maj(reponse,1)
            if(reponse=='Y') then
               print*,'Data canceled'
               dataOK=.false.
               return
            else if(reponse=='N') then
            else
               print*,'wrong data: ',reponse
               goto 30
            endif
         else if(reponse=='N') then
         else
            print*,'wrong data: ',reponse
            goto 20
         endif
      endif
!
!------------------------------------------------------------
! Write nbocs, nbal on disc
!------------------------------------------------------------
!
 
      call stoinfo(AA,nsym,nbocs(1:nsym),nbals(1:nsym))
      if(AA(1:1).eq.'C') icore(1:nsym)=icore(1:nsym)+
     *nbocs(1:nsym)
      if(AA(1:1).eq.'G') igel(1:nsym)=igel(1:nsym)+
     *nbocs(1:nsym)
c      print*,'icore',icore(1:nsym)
      if(ywo)print*,'ii fin',ii(1:iofin)
      if(ywo)print*,'ii2 fin',ii2(1:iofin)
      idebs=0
      call storelo2(AA,ii2(1:mor2),u2(1:nor2,1:mboc),
     *u2(1:nor2,mor2-mbal+1:mor2),ios2(1:mor2),
     *occup2(1:mboc),occup2(mor2-mbal+1:mor2),nor2,mor2,mboc,mbal)
      if(yes)print*,'sortie genelo2',norb
 
      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
C       subroutine genelo2v(AA,ii,nbii,nor2,nboc,nbal,iofin)
C      use mod_dolo
C      use mod_rotat
C      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
C      real(8),allocatable,dimension(:,:) :: ul,v,u2
C      dimension ii(norb),nbii(maxsym),nbiit(0:maxsym)
C      integer,dimension(:),allocatable :: ii2,ios,ios2
C      double precision,dimension(:),allocatable :: w,w1,occup,occup1,
C     *occup2
C      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
C      allocatable yo(:),yv(:)
C      character(300) namel
C      dimension nbocs(maxsym),nbals(maxsym)
C      character(len_datlist) AA
C      dimension icore(maxsym),igel(maxsym)
C      dimension imaxloc(1)
C      common/pr/nprint
C      yw=.true.
C      ywo=.false.
C      if(yes)print*,'entree genelo2',norb
C      allocate(ii2(norb))
C      allocate(ios2(norb))
C      allocate(ul(norb,norb))
C      allocate(v(norb,norb))
C      allocate(u2(norb,norb))
C      allocate(occup(norb))
C      allocate(occup1(norb))
C      allocate(occup2(norb))
C      allocate(ios(norb))
C      allocate(yo(norb))
C      allocate(yv(norb))
C!
C!--------------------------------------------------------
C! Loop on symmetries
C!--------------------------------------------------------
C!
Cc
Cc-----------------------------------------------------------
Cc     extract local density matrices for each symmetry
Cc-----------------------------------------------------------
Cc
C      nbiit(0)=0
C      iunit=76
C      rewind 76
C      do is=1,nsym
C         nbiit(is)=nbiit(is-1)+nbii(is)
C         print*,'nbii(is)',nbii(is)
C         if(nbii(is).eq.0) cycle
C         write(76,*)'.......................................'
C         write(6,*)'.......................................'
C         ndims0=isymt(is-1)
C         jd1=nbiit(is-1)+1 ; jd2=nbiit(is)
Cc        on se sert de ii2 = (ii reordonne) pour que les
Cc        orbitales locales arrivent sym par sym
C         ii2=ii
C         call reor(nor2,ii2)
C         if(yw)print*,'ii2',ii2(1:nbii(is))
C         ul(1:nbii(is),1:nbii(is))=
C     *   gamma(ii2(jd1:jd2)-ndims0,ii2(jd1:jd2))
C         if(nprint.ge.0) then
C            write(76,*)'sym',is,'  matrice extraite'
C            write(6,*)'sym',is,'  matrice extraite'
C            call scripto3(ul(1:nbii(is),1:nbii(is)),nbii(is),
C     *      nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)),76)
C            call scripto3(ul(1:nbii(is),1:nbii(is)),nbii(is),
C     *      nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)),6)
C         endif
C         write(76,*)' '
C         write(76,'(a,i3,a,/)')
C     *   'sym',is,'  occupations, orbitales naturelles'
C         write(6,*)' '
C         write(6,'(a,i3,a,/)')
C     *   'sym',is,'  occupations, orbitales naturelles'
C         if(nrot/=0) then
C            nnbiis=nbii(is)
C            call rotat2(ul(1:nbii(is),1:nbii(is)),nnbiis,
C     *      orbi(ii2(jd1:jd2)),sym1,nsym,is,v(1:nbii(is),jd1:jd2))
C            write(76,'(14x,10f8.4)')(ul(k,k),k=1,nnbiis)
C            write(6,'(14x,10f8.4)')(ul(k,k),k=1,nnbiis)
C            jjd1=jd1
C            jjd2=jd1+nnbiis-1
C            if(iofin.gt.1)call scripto3(v(1:nbii(is),jjd1:jjd2),
C     *      nbii(is),nbii(is),nbii(is),nbii(is),orbi(ii2(jjd1:jjd2)),76)
C            if(iofin.gt.1)call scripto3(v(1:nbii(is),jjd1:jjd2),
C     *      nbii(is),nnbiis,nbii(is),nnbiis,orbi(ii2(jd1:jd2)),6)
C            do k=jjd1,jjd2
C               occup(k)=ul(k-jjd1+1,k-jjd1+1)
C               ios(k)=is
C            enddo
C         else
C            call orientation2(ul(1:nbii(is),1:nbii(is)),nbii(is),
C     *      orbi(ii2(jd1:jd2)),v(1:nbii(is),jd1:jd2),yor,orient)
Cc           diagonalisation, orbitales locales (dans v)
C            if(yor)
C     *      call hdiag(ul(1:nbii(is),1:nbii(is)),v(1:nbii(is),jd1:jd2)
C     *      ,nbii(is),nbii(is))
C            do k=1,nbii(is)
C               if(ul(k,k)==-10.d0) ul(k,k)=1.d0
C            enddo
C            write(76,'(14x,10f8.4)')(ul(k,k),k=1,nbii(is))
C            write(6,'(14x,10f8.4)')(ul(k,k),k=1,nbii(is))
C            if(iofin.gt.1)call scripto3(v(1:nbii(is),jd1:jd2),
C     *      nbii(is),nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)),76)
C            if(iofin.gt.1)call scripto3(v(1:nbii(is),jd1:jd2),
C     *      nbii(is),nbii(is),nbii(is),nbii(is),orbi(ii2(jd1:jd2)),6)
C            do k=jd1,jd2
C               occup(k)=ul(k-jd1+1,k-jd1+1)
C               ios(k)=is
C            enddo
C         endif
C      enddo
C      write(76,*)'.......................................'
C      if(yw)print*,'OCCUP',occup(1:norb)
C      if(yw)print*,'NBOC,NBAL',nboc,nbal
C      if(yw)print*,'NOR2',nor2
C      if(yw)print*,'nbiit',nbiit(0:nsym)
C!
C!-----------------------------------------------------------------
C! nboc, nbal = nb of occ and anti-bonding LO
C! let's build now  nbocs(1:nsym) and nbals(1:nsym)
C! (nb of occ and anti-bonding LO's per symmetry)
C! choose the nboc most occupied LO in all symmetries to build nbocs
C! choose the nbal less occupied LO in all symmetries to build nbals
C!-----------------------------------------------------------------
C!
C      mboc=nboc
C      mbal=nbal
C      if(yw)print*,'mboc,mbal',mboc,mbal
C      mmm=maxval(isym(1:nsym))
C      if(yw)print*,'ios',ios(1:nor2)
C      u2=0.d0
C      ios2=0
C      occup1=occup
C      if(yw)print*,'occup',occup(1:nor2)
C      ! on cherche les mboc plus grandes occupations
C      yo(1:nor2)=.false.
C      do k=1,mboc
C!         imaxloc=maxloc(occup1(1:nor2))
C!         ipg=imaxloc(1)
C!         occup1(ipg)=0.d0
C         cc=0.d0
C         do l=1,nor2
C            if(yo(l)) cycle
C            if(yw)print*,'l,occup(l),cc,yo(l)',l,occup(l),cc,yo(l)
C            if(occup(l).ge.cc) then
C               ipg=l
C               cc=occup(l)
C            endif
C         enddo
C         yo(ipg)=.true.
C         if(yw)print*,'ipg',ipg,k,mboc
C         ios2(k)=ios(ipg)
C         is=ios2(k)
C         if(yw)print*,'u2',nbiit(is-1)+1,nbiit(is-1)+nbii(is),k,is
C         u2(nbiit(is-1)+1:nbiit(is-1)+nbii(is),k)=v(1:nbii(is),ipg)
C         occup2(k)=occup(ipg)
C         if(yw)print*,'ios2',ios2(1:nor2)
C         if(yw)print*,'yo',yo(1:nor2)
C      enddo
C      ! on cherche les mbal plus petites occupations
C      if(yw)print*,'nor2',nor2
C      yv(1:nor2)=.false.
C      do k=1,mbal
C!         imaxloc=minloc(occup1(1:nor2))
C!         ipg=imaxloc(1)
C!         occup1(ipg)=2.d0
C         cc=2.d0
C         do l=1,nor2
C            if(yv(l)) cycle
C            is=ios(l)
C            if(all(v(1:nbii(is),l)<1.d-10)) cycle
C            if(occup(l).le.cc) then
C               ipg=l
C               cc=occup(l)
C            endif
C         enddo
C         yv(ipg)=.true.
C         if(yw)print*,'ipg',ipg,k,mboc
C         ios2(nor2-k+1)=ios(ipg)
C         is=ios2(nor2-k+1)
C         u2(nbiit(is-1)+1:nbiit(is-1)+nbii(is),nor2-k+1)=
C     *   v(1:nbii(is),ipg)
C         occup2(nor2-k+1)=occup(ipg)
C         if(yw)print*,'alios2',ios2(1:nor2)
C         if(yw)print*,'yv',yv(1:nor2)
C      enddo
Cc
Cc---------------------------------------------------------
Cc     gaps entre les occupees et les eliminees
Cc     et les eliminees et les virtuelles
Cc---------------------------------------------------------
Cc
C      nelim=nor2-nboc-nbal
C      occumin=2.d0
C      elimin=2.d0
C      almin=2.d0
C      occumax=0.d0
C      elimax=0.d0
C      almax=0.d0
C      k=0
C      !do k=1,nor2
C      do is=1,nsym
C         do i=1,nbii(is)
C         k=k+1
C         !write(76,*)'k,yo(k),yv(k)',k,yo(k),yv(k)
C         if(.not.yo(k)) then
C            if(.not.yv(k)) then
C!              si le vecteur est nul, il a ete projete par orientation
C!              ne pas alors le considerer dans les elimines
C!              (ni occ ni virt)
C               if(all(v(1:nbii(is),k)<1.d-10)) cycle
C               elimin=min(elimin,occup(k))
C               elimax=max(elimax,occup(k))
C            else
C               almin=min(almin,occup(k))
C               almax=max(almax,occup(k))
C            endif
C         else
C            occumin=min(occumin,occup(k))
C            occumax=max(occumax,occup(k))
C         endif
C      enddo
C      enddo
C      namel=' '
C      namel(8:58)=
C     *'...        /  /        ...         /  /         ...'
C      write(76,*)' '
C      write(76,'(70a1)')('-',k=1,70)
C      write(76,*) '   Occupees               Eliminees   '//
C     *'          A-L, Virtuelles'
C      write(6,*)' '
C      write(6,'(70a1)')('-',k=1,70)
C      write(6,*) '   Occupees               Eliminees   '//
C     *'          A-L, Virtuelles'
C      if(nboc.gt.1)write(namel(2:7),'(f6.4)') occumax
C      if(nboc.gt.0)write(namel(12:17),'(f6.4)') occumin
C      if(nelim.eq.1) then
C         write(namel(30:35),'(f6.4)') elimin
C      else if(nelim.gt.1)then
C         write(namel(25:30),'(f6.4)') elimax
C         write(namel(36:41),'(f6.4)') elimin
C      endif
C      if(nbal.gt.1)write(namel(49:55),'(f6.4)') almax
C      if(nbal.gt.0)write(namel(60:66),'(f6.4)') almin
C      write(76,'(a)')trim(namel)
C      write(76,*)' '
C      write(6,'(a)')trim(namel)
C      write(6,*)' '
C      namel(1:51)=' '
C      namel(1:7)=' Gaps :'
C      ideb=11
C      if(nboc.ne.0.and.nelim.ne.0) then
C         write(namel(11:22),'(a,f9.4)')
C     *   'O/E',occumin-elimax
C         ideb=ideb+20
C      endif
C      if(nbal.ne.0.and.nelim.ne.0) then
C         write(namel(ideb:ideb+11),'(a,f9.4)')
C     *   'E/V',Elimin-almax
C         ideb=ideb+20
C      endif
C      if(ideb.eq.11.and.nbal.ne.0.and.nboc.ne.0) then
C         write(namel(11:22),'(a,f9.4)')
C     *   'O/V',occumin-almax
C      endif
C      write(76,'(a)')namel(1:51)
C      write(6,'(a)')namel(1:51)
Cc     *print'(a,f9.4,a,f9.4)',' Gaps :   O/E',occumin-elimax,'   E/V'
Cc     *Elimin-almax
C      ywarn=.false.
C      if(nboc.ne.0.and.nelim.ne.0.and.occumin-elimax.lt.0.3) then
C         write(76,*)'******WARNING******* Small Occ/Elim gap'
C         write(6,*)'******WARNING******* Small Occ/Elim gap'
C         write(89,'(a,f10.4)')
C     *   '******WARNING******* Small Occ/Elim gap',occumin-elimax
C         write(6,'(a,f10.4)')
C     *   '******WARNING******* Small Occ/Elim gap',occumin-elimax
C         ywarn=.true.
C      endif
C      if(nbal.ne.0.and.nelim.ne.0.and.elimin-almax.lt.0.3) then
C         write(76,*)'******WARNING******* Small Elim/virt gap'
C         write(6,*)'******WARNING******* Small Elim/virt gap'
C         write(89,'(a,f10.4)')
C     *   '******WARNING******* Small Elim/virt gap',elimin-almax
C         write(6,'(a,f10.4)')
C     *   '******WARNING******* Small Elim/virt gap',elimin-almax
C         ywarn=.true.
C      endif
C      if(nboc.ne.0.and.nbal.ne.0.and.occumin-almax.lt.0.3) then
C         write(6,*)'******WARNING******* Small Occ/Virt gap'
C         write(76,*)'******WARNING******* Small Occ/Virt gap'
C         write(89,'(a,f10.4)')
C     *   '******WARNING******* Small Occ/Virt gap',occumin-almax
C         write(6,'(a,f10.4)')
C     *   '******WARNING******* Small Occ/Virt gap',occumin-almax
C         ywarn=.true.
C      endif
C      if(ywarn) then
C         print'(a)', 'Corresponding basic data:'
C         print'(i5,a)', idatlist,'  '//trim(aa)
C         print*,' '
C         write(89,'(a)') 'Corresponding basic data:'
C         write(89,'(i5,a)') idatlist,'  '//trim(aa)
C         write(89,*)'============================================='
C      endif
C       !if(iunit5==5) stop
C!
C!------------------------------------------------------------
C! no warning if data are read on OLD_DATA
C!------------------------------------------------------------
C!
C      if(iunit5==91) ywarn=.false.
C!
C!------------------------------------------------------------
C! nb of Lo per symmetry
C!------------------------------------------------------------
C!
C      if(yw)print*,'ios2',ios2(1:nor2)
C      if(yw)call scripto(u2(1:nor2,1:nor2),
C     *nor2,nor2,nor2,nor2,orbi(ii(1:nor2)))
C      nbocs(1:nsym)=0
C      nbals(1:nsym)=0
C      do k=1,mboc
C         nbocs(ios2(k))=nbocs(ios2(k))+1
C      enddo
C      do k=nor2,nor2-mbal+1,-1
C         nbals(ios2(k))=nbals(ios2(k))+1
C      enddo
C      write(76,'(a45,8i3)')
C     *'nombre d''orbitales occupees par symetrie    '
C     *,nbocs(1:nsym)
C      write(76,'(a45,8i3)')
C     *'nombre d''orbitales anti-liantes par symetrie'
C     *,nbals(1:nsym)
C      write(6,'(a45,8i3)')
C     *'nombre d''orbitales occupees par symetrie    '
C     *,nbocs(1:nsym)
C      write(6,'(a45,8i3)')
C     *'nombre d''orbitales anti-liantes par symetrie'
C     *,nbals(1:nsym)
C!
C!------------------------------------------------------------
C! Display if warning
C!------------------------------------------------------------
C!
C      if(ywarn) then
C         namel=' '
C         write(6,form_dolo) 'Display details (Y/N) ?'
C 20      continue
C         read(5,'(a1)') reponse
C          print*,'lect dans genelo'
C         call maj(reponse,1)
C         print*,reponse
C         if(reponse=='Y') then
C            rewind 76
C            do
C               read(76,'(a300)',end=10) namel
C               print'(a)', trim(namel)
C            enddo
C 10         continue
C 30         continue
C            write(6,form_dolo)'change data (Y/N) ?'
C            read(5,'(a1)') reponse
C            call maj(reponse,1)
C            if(reponse=='Y') then
C               print*,'Data canceled'
C               dataOK=.false.
C               return
C            else if(reponse=='N') then
C            else
C               print*,'wrong data: ',reponse
C               goto 30
C            endif
C         else if(reponse=='N') then
C         else
C            print*,'wrong data: ',reponse
C            goto 20
C         endif
C      endif
C!
C!------------------------------------------------------------
C! Write nbocs, nbal on disc
C!------------------------------------------------------------
C!
C 
C      call stoinfo(AA,nsym,nbocs(1:nsym),nbals(1:nsym))
C      if(AA(1:1).eq.'C') icore(1:nsym)=icore(1:nsym)+
C     *nbocs(1:nsym)
C      if(AA(1:1).eq.'G') igel(1:nsym)=igel(1:nsym)+
C     *nbocs(1:nsym)
Cc      print*,'icore',icore(1:nsym)
C      if(ywo)print*,'ii fin',ii(1:iofin)
C      if(ywo)print*,'ii2 fin',ii2(1:iofin)
C      idebs=0
C      call storelo2(AA,ii2(1:nor2),u2(1:nor2,1:mboc),
C     *u2(1:nor2,nor2-mbal+1:nor2),ios2(1:nor2),
C     *occup2(1:mboc),occup2(nor2-mbal+1:nor2),nor2,mboc,mbal)
C      if(yes)print*,'sortie genelo2',norb
C 
C      return
C      end
