      subroutine alamain(orb,norb)
      !
      !sous programme non termine
      !
      use don
      use bas
      use densch
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8,nfix=500)
      parameter (maxl=100)
      parameter (maxproj=10)
      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
      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*4 atom(100)
c      character*8 orbi(nfix)
c      character*8 base(nfix)
      character*8 label0
      character*4 atom1
      character*300 orb,orb1,orbitales
      dimension yvirt(nfix),ivirt(nfix)
c      common /don/ nl,numina(nfix),numac(nfix),ninac,noac
      dimension numac0(nfix),yac0(nfix)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      common/version/molcas,i_rec,i_at,i_orb,i_coo
c      common/densch/occ(nfix)
      dimension nbii(maxsym),nbiit(0:maxsym),ios(nfix),y(nfix)
      dimension ios2(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)
      dimension ioproj(maxl),jl(nfix)!,nbp(maxsym,100)
      dimension jlocc(nfix),jlvir(nfix)
      character*12 tipoo3(nfix),tipov3(nfix)
      character*12 tipoo(nfix),tipov(nfix),tipo(nfix)
      character*8 progr
      common/prog/progr
      dimension iocd(maxsym),ngelo(maxsym),ngelv(maxsym)
      integer fermi(maxsym),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)
      dimension jdebat(100),jfinat(100),nomat(100)
      character*4 nomat,oo
 
 1000          format(4d18.12)
 
      yw=.true.
      yverif=.false.
      fermi=0
      nvirt=0
      icore=0
      igel=0
      tipoo=' ' ; tipov=' '
      tipoo3=' ' ; tipov3=' '
      if(yw)print*,'entree alamain 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(w1(norb))
      allocate(occup(norb))
      allocate(occup3o(norb))
      allocate(occup3v(norb))
      allocate(occup4o(norb))
      allocate(occup4v(norb))
      allocate(ii(norb))
      allocate(ii2(norb))
      allocate(iprio(norb))
      u=0.d0
      if(yw)print*,'orbi',orbi(1:norb)
      yvirt(1:norb)=.false.
      rewind 93
      call LECNAM('&MMM',namel,93,ierr,1)
      if(ierr.eq.1) stop 'pas de namelist MMM'
c------------------------------------------------------------------
c     lecture des orbitales atomiques orthogonales (OAO)
c------------------------------------------------------------------
      rewind 1
      read(1,'(a)') orb
      do is=1,nsym
         ndims=isym(is)
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         do k=1,ndims
            read(1,'(a)') orb
            read(1,1000) v(1:ndims,k+ndims0)
         enddo
      enddo
      if(yw) then
         print*,' '
         print*,'orbitales locales orthogonales lues'
         do is=1,nsym
            ndims=isym(is)
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            call scripto(v(1:ndims,nd1:nd2),ndims,ndims,ndims,n
     &      dims,orbi(nd1:nd2))
         enddo
      endif
c------------------------------------------------------------------
c     lecture de la matrice de recouvrement
c------------------------------------------------------------------
      rewind 8
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         read(8) nbid
         read(8) s(1:ndims,1:ndims)
         read(8)
         if(yw)print*,'mats',nbid
          if(yw)call scripto
     *   (s(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi(nd1:nd2))
      enddo
c------------------------------------------------------------------
c     on met les liaisons sur 94
      open(94,status='unknown',file='BID94')
      rewind 93
      print*,'coucou'
      call LECNAM('&MMM ',namel,93,ierr,0)
      nl=0
      do
         read(93,'(a)') orb
         long=len_trim(orb)
         call maj(orb,long)
         write(94,'(a)') orb(1:long)
         if(orb(1:3).eq.'FIN') exit
         nl=nl+1
      enddo
c------------------------------------------------------------------
c     p,d,f multiples
c------------------------------------------------------------------
      open(98,status='unknown',file='BID98')
      rewind 94
      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
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=.true.
c
c-----------------------------------------------------------
c     lecture des orbitales
c-----------------------------------------------------------
c
      ioc=0
      ial=0
      iocref=0
      ialref=0
      ioref=0
      rewind 98
      if(yw)print*,'nombre de liaisons',nl
      do il=1,nl
         print*,' '
         print*,' '
         print*,
     *   '*-----------------------------------------------------------*'
         print'(a25,i3)','            Liaison  ',il
         iodeb=1
         tipo(il)=' '
         read(98,'(a)') orb
         long=len_trim(orb)
         call suppdb(orb,long)
         orb=adjustl(orb)
         if(yw)print*,orb(1:long)
c
c        label
c
         ll=index(orb,' ')-1
         if(yw)print*,'ll',ll
         tipo(il)(1:ll)=orb(1:ll)
         if(yw)print'(2a)','tipo ',tipo(il)(1:ll)
c
c        nombre d'atomes de la liaison
c        noms de ces atomes (nomat)
c
         orb1=orb
         natoml=1
         jdebat(1)=ll+2
         jfinat(1)=index(orb(jdebat(1):long),' ')+jdebat(1)-2
         print*,'jdebat,jfinat',jdebat(natoml),jfinat(natoml)
         nomat(1)=' '
         longat=jfinat(1)-jdebat(1)+1
         nomat(natoml)(1:longat)=orb(jdebat(1):jfinat(1))
         print*,'nomat',nomat(natoml)
         do
            i=index(orb1(1:long),':')
            print*,'i',i
            if(i.ne.0) then
               natoml=natoml+1
               nomat(natoml)=' '
               orb1(i:i)=';'
               jdebat(natoml)=i+2
               jfinat(natoml)=index(orb(jdebat(natoml):long),' ')
     *         +jdebat(natoml)-2
               print*,'jdebat,jfinat',jdebat(natoml),jfinat(natoml)
               longat=jfinat(1)-jdebat(1)+1
               nomat(natoml)
     *         (1:longat)=orb(jdebat(natoml):jfinat(natoml))
               print*,'nomat',nomat(natoml)
            else
               exit
            endif
         enddo
         print*,'natoml',natoml
 
c
c        on efface les noms des atomes et le label
c
         orb1(1:ll)=' '
         do iatoml=1,natoml
            orb1(jdebat(iatoml):jfinat(iatoml))=' '
         enddo
         print*,'orb1 ',orb1(1:long)
         call suppdb(orb1,long)
         orb1=adjustl(orb1)
         long=len_trim(orb1)
         print*,'orb1 ',orb1(1:long)
c
c        occupation
c
         do k=long,1,-1
            if(orb1(k:k).eq.')') ifin=k
            if(orb1(k:k).eq.'(') then
               ideb=k
               exit
            endif
         enddo
         print*,orb1(ideb+1:ifin-1)
         read(orb1(ideb+1:ifin-1),*) oc
         print*,'oc',oc
c
c        boucle sur les atomes de la liaison
c
         print*,'nomat',nomat(1:natoml)
         idebo=1
         do iatoml=1,natoml
c           boucle sur les orbitales de l'atome
            do
c              calcul des bornes
               idebpar=index(orb1(idebo:long),'(')+idebo-1
               ifinpar=index(orb1(idebo:long),')')+idebo-1
               print*,'idebo,idebpar,ifinpar',idebo,idebpar,ifinpar
               ifino=idebpar-1
               longo=ifino-idebo+1
               idebc=ifinpar+2
               ifinc=index(orb1(idebc:long),' ')+idebc-2
               print*,'idebo,ifino,longo',idebo,ifino,longo
               print*,'idebc,ifinc',idebc,ifinc
c              label de l'orbitale
               oo=' '
               oo(1:longo)=orb1(idebo:ifino)
               print*,'oo ',oo(1:longo)
c              numero du label dans la base (a lire dans les () )
               read(orb1(idebpar+1:ifinpar-1),*) ilab
c              coefficient
               read(orb1(idebc:ifinc),*) c
               idebo=ifinc+2
c              label complet a rechercher
               label0=nomat(iatoml)//oo(1:longo)
               print*,'label0',label0,c
c              on recherche l'orbitale dans la base
               icompt=0
               i=0
               do i1=1,nsym
                  do i2=1,isym(i1)
                     i=i+1
                     if(base(i).eq.label0) then
                        icompt=icompt+1
                        if(icompt.eq.ilab) then
                           icompt=0
                           u(i,il)=c
                           print*,'trouve en ',i,il
                           i=i+isym(i1)-i2
                           goto 1
                           exit
                        endif
                     endif
                  enddo
 1                continue
               enddo
c              orbitale suivante
               idebo=ifinc+2
c               if(orb1(idebo:idebo).eq.'(') exit
               if(orb1(idebo:idebo).eq.'('.or.orb1(idebo:idebo).eq.';')
     *         then
                  idebo=idebo+2
                  exit
               endif
            enddo
         enddo
 
      enddo
      call scripto(u(1:norb,1:nl),norb,nl,norb,nl,base)
 
 
 
         stop
      do il=1,nl
 
 
 
 
 
 
 
 
 
c---------------------------------------------------------
c        DEBUT DE LA BOUCLE SUR LES ATOMES DE LA LIAISON
c---------------------------------------------------------
c        lecture du nom de l'atome
         nbii(1:nsym)=0
         nbiit(0)=0
         v=0.d0
         iii=0
         idebat=ll+2
 4       continue
         longat=index(orb(idebat:long),' ')-1
         ifinat=idebat+longat-1
         ideb=idebat+longat+1
c        idebat,ifinat : debut et fin du nom de l'atome
c        ideb : debut de la base
         if(ywo)print*,'longat,ideb,idebat,ifinat',
     *   longat,ideb,idebat,ifinat
         atom1='    '
         atom1(1:longat)=orb(idebat:ifinat)
         print*,'atome  ','==== ',atom1(1:longat),' ===='
c        lecture des orbitales de l'atome
c        stockage de toutes les orbitales de la liaison dans ii
         idebo=ifinat+2
         ifino=index(orb(1:long),':')-2
         ifin=ifino
         orb(ifino+2:ifino+2)=' '
         if(ywo)print*,'idebo,ifino',idebo,ifino
         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
         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---------------------------------------------------------
      enddo
c
c-----------------------------------------------------------
c-----------------------------------------------------------
c
      return
      end
 
