      subroutine sto5
      use mod_sym
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character*3000 orb,orb1
      character aa
      yw=.false.
      if(yw)print*,'entree sto5'
      open(93,file='BID93',status='unknown')
      open(94,file='BID94',status='unknown')
c
c     traitement des lignes suite
c
      do
         read(5,'(a)',end=10) orb
         if(orb(1:1)=='#') cycle
         if(orb(1:1)=='*') cycle
         long=len_trim(orb)
         if(long==0) cycle
         call majnam(orb,long)
c         print*,'ORB.',orb(1:long)
         call ligne_suite5(orb,long,5)
         long=len_trim(orb)
c         print*,'ORB_',orb(1:long)
         write(93,'(a)') orb(1:long)
      enddo
 10   continue
c
c     Verification de l'existence des lignes FIN
c
      rewind 93
      iio=0
      iif=0
      do
         read(93,'(a)',end=11) orb
         orb=adjustl(orb)
         long=len_trim(orb)
         call majnam(orb,long)
         if(orb(1:4)=='&OAO') iio=iio+1
         if(orb(1:4)=='&ORB') iio=iio+1
         if(orb(1:3)=='FIN') iif=iif+1
      enddo
 11   continue
      ii=iif-iio
      if(ii.ne.0) then
         print*,'le nombre de namelist &orb et &oao n''est pas',
     *   ' egal au nombre de lignes fin'
      endif
c
c     traitement des crochets "[ ]"
c
      rewind 93
      if(yw)print*,'avant stop'
      do
         read(93,'(a)',end=1) orb
         long=len_trim(orb)
c         print*,'ORB+',orb(1:long)
         call suppdb(orb,long)
         long=len_trim(orb)
c         print*,'ORB-',orb(1:long)
         long=len_trim(orb)
         yecr=.true.
         if(index(orb(1:long),'[').ne.0) call croc(orb,yecr)
         if(yecr)write(94,'(a)') orb(1:long)
      enddo
 1    continue
c
c     traitement des accolades "{ }"
c
      rewind 94
      rewind 93
      do
         read(94,'(a)',end=2) orb
         long=len_trim(orb)
         call suppdb(orb,long)
         long=len_trim(orb)
         yecr=.true.
c         print*,'index',index(orb(1:long),'{')
         if(index(orb(1:long),'{').ne.0) then
            call acol(orb,long)
         else
            write(93,'(a)') orb(1:long)
         endif
      enddo
 2    continue
c
c     traitement des donnees multiples pour p,d,f...
c     dans les donnees oao
c
      rewind 94
      rewind 93
      yoao=.false.
      do
         read(93,'(a)',end=3) orb
         long=len_trim(orb)
         yoao=yoao.or.index(orb(1:long),'&OAO').ne.0
         if(orb(1:3).eq.'FIN') yoao=.false.
         if(.not.yoao) then
            write(94,'(a)') orb(1:long)
            cycle
         endif
         yreplt=.false.
         orb1=orb
         call repl(orb1,'2P(','2PX(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+1)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'2P(','2PY(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+1)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'2P(','2PZ(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+1)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'3D(','3D0(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+1)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'3D(','3D1+(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'3D(','3D1-(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'3D(','3D2+(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'3D(','3D2-(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F0(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+1)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F1+(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F1-(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F2+(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F2-(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F3+(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         orb1=orb
         call repl(orb1,'4F(','4F3-(',yrepl)
         if(yrepl)write(94,'(a)') orb1(1:long+2)
         yreplt=yreplt.or.yrepl
         if(.not.yreplt) write(94,'(a)') orb(1:long)
      enddo
 3    continue
c
c     traitement des donnees multiples pour p,d,f...
c     dans les donnees orb
c
      rewind 94
      rewind 93
      yorb=.false.
      do
         read(94,'(a)',end=33) orb
         long=len_trim(orb)
         yorb=yorb.or.index(orb(1:long),'&ORB').ne.0
         if(orb(1:3).eq.'FIN') yorb=.false.
         if(.not.yorb) then
            write(93,'(a)') orb(1:long)
            cycle
         endif
         orb1=orb
         i=index(orb1,'2P(')
         k=0
         do while(i/=0)
            k=k+1
            aa=orb1(i+3:i+3)
            call repl(orb1,'2P('//aa//')',
     *      '2PX('//aa//') 2PY('//aa//') 2PZ('//aa//')',yrepl)
            i=index(orb1,'2P(')
         enddo
         write(93,'(a)') orb1(1:long+15*k)
      enddo
 33   continue
!      rewind 94
!      rewind 93
!      do
!         read(94,'(a)',end=4) orb
!         long=len_trim(orb)
!         write(93,'(a)') orb(1:long)
!      enddo
 4    continue
c
c     Lecture des operations de symetrie, generation des 
c     atomes en symetrie 
c     1. s'il y a des donnees PARA ou ORTH
c     2. s'il y a des donnees automatiques
c
      rewind 93
      call lecnam('&ORB ',orb,93,ierr,0)
      do
         read(93,'(a3000)') orb
         call fnormaligo(orb,l)
         if(orb(1:3)=='FIN') exit
         if(index(orb,'PARA(').ne.0.or.index(orb,'ORTH(').ne.0) then
            ycallsymetrie=.true.
            print*,'ycallsymetrie a T'
            exit
         endif
         if(orb(1:5)=='CORE_'.or.orb(1:6)=='SIGMA_'.or.orb(1:3)=='PI_'
     *   .or.orb(1:6)=='LONEP_'.or.orb(1:5)=='MULT_'
     *   .or.orb(1:6)=='PICYC_'.or.orb(1:4)=='LPP_') then
            ycallsymetrie=.true.
            ydatoto=.true.
            print*,'ydatoto a T'
            print*,'ycallsymetrie a T'
            exit
         endif
      enddo

      rewind 93
      close(94,status='delete')
      return
      end
       subroutine croc(orb,yecr)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      integer,dimension(:),allocatable :: icro1,icro2,ibl1,ibl2
      character orb*300
      character*300 orb1
      character*300 c1,c2
      yw=.false.
      if(yw)print*,'entree croc'
      long=len_trim(orb)
c      print*,'O1.',orb(1:long)
      yrepl=.true.
      do while(yrepl)
         call repl(orb,'[ ','[',yrepl)
         long=len_trim(orb)
         if(yw)print*,'O2.',orb(1:long)
         call repl(orb,' ]',']',yrepl)
         long=len_trim(orb)
         if(yw)print*,'O3.',orb(1:long)
      enddo
      orb1(1:long)=orb(1:long)
      ncro=0
      long=len_trim(orb)
      ich=0
c-----------------------------------------
c     on compte les [
c-----------------------------------------
      do k=1,21
         ichv=ich
         ich=index(orb(1+ich:long),'[')+ich
c         print*,'ich',ich,k
c         if(ich.ne.0)print'(a)',
c     *   '12345678901234567890123456789012345678901234567890'
c         if(ich.ne.0)print'(a)',orb(1:long)
         if(ich-ichv.eq.0) goto 1
         ncro=ncro+1
      enddo
      stop 'ncro'
 1    continue
c-----------------------------------------
c     verif : on compte les ]
c-----------------------------------------
      ncro2=0
      ich=0
      do k=1,21
         ichv=ich
         ich=index(orb(1+ich:long),']')+ich
         if(ich-ichv.eq.0) goto 3
         ncro2=ncro2+1
      enddo
 3    continue
      if(ncro.ne.ncro2) then
         print*,'[...] en nombre inegal,  ligne'
         print*,orb(1:long)
         stop
      endif
      if(ncro.eq.0) goto 10
      if(ncro.ne.0) then
c         print'(a)',
c     *   '12345678901234567890123456789012345678901234567890'
c         print'(a)',orb(1:long)
c         print*,'ncro',ncro
      endif
c-----------------------------------------
c     on note les places des [ ]
c-----------------------------------------
      allocate (icro1(ncro))
      allocate (icro2(ncro))
      ich=0
      icro1=0   ;   icro2=0
      do k=1,ncro
         ichv=ich
         ich=index(orb(1+ich:long),'[')+ich
         if(ich-ichv.eq.0) exit
         icro1(k)=ich
         ich=index(orb(1+ich:long),']')+ich
         icro2(k)=ich
         if(ich-ichv.eq.0) exit
      enddo
      if(any(icro1(1:ncro).eq.0).or.
     *   any(icro2(1:ncro).eq.0).or.
     *   any(icro2(1:ncro)-icro1(1:ncro).le.0)) then
         print*,'erreur dans les "[" "]" '
         print*,orb
         stop
      endif
      if(ncro.ne.0) then
      if(yw)print*,'icro1',icro1(1:ncro)
      if(yw)print*,'icro2',icro2(1:ncro)
      endif
c-----------------------------------------
c     on compte les donnees dans [ ]
c-----------------------------------------
      nbl=0
      do k=icro1(1)+1,icro2(1)-1
         if(orb(k:k).eq.' '.and.orb(k-1:k-1).ne.' ')nbl=nbl+1
      enddo
      if(yw)print*,'nbl',nbl
c     verif pour les autres icor
      do ic=2,ncro
         nbl2=0
         do k=icro1(ic)+1,icro2(ic)-1
            if(orb(k:k).eq.' '.and.orb(k-1:k-1).ne.' ')nbl2=nbl2+1
         enddo
c         print*,'nbl2',nbl2
         if(nbl.ne.nbl2) then
            print*,'erreur dans le nombre de donnees dans le [  ]'
            print'(a)',
     *      ' 12345678901234567890123456789012345678901234567890'
            print*,orb(1:long)
            stop
         endif
      enddo
      ndon=nbl+1
      if(nbl.ne.0.and.yw) print*,'ndon',ndon
c-----------------------------------------
c     on remplace
c-----------------------------------------
      allocate (ibl1(ncro))
      allocate (ibl2(ncro))
      ibl1(1:ncro)=icro1(1:ncro)+1
      do jbl=1,ndon
         long=len_trim(orb)
         orb1=orb
         if(yw)print*,'ORB1.',orb1(1:long)
         do ic=1,ncro
            ii1=index(orb(ibl1(ic):long),' ')
            ii2=index(orb(ibl1(ic):long),']')
            if(ii1==0) ii1=ii2+1
            ibl2(ic)=min(ii1,ii2)-2+ibl1(ic)
            if(yw)
     *      print*,'jbl,ic,ibl1(ic),ibl2(ic)',jbl,ic,ibl1(ic),ibl2(ic)
            c1=orb(icro1(ic):icro2(ic))
            l1=len_trim(c1)
            if(yw)print*,'c1 ',c1(1:l1)
            c2=orb(ibl1(ic):ibl2(ic))
            l2=ibl2(ic)-ibl1(ic)+1
            if(yw)print*,'c2 ',c2(1:l2)
            long1=len_trim(orb1)
            if(yw)print*,'orb1.',orb1(1:long1)
            if(yw)print*,'c1(1:l1),c2(1:l2)',c1(1:l1),'|',c2(1:l2)
            call repl(orb1,c1(1:l1),c2(1:l2),yrepl)
            long2=len_trim(orb1)
            if(yw)print*,'orb2.',orb1(1:long2)
         enddo
         if(yw)print*,'orb2.',orb1(1:long2)
         ibl1(1:ncro)=ibl2(1:ncro)+2
         write(94,'(a)') orb1(1:long2)
         yecr=.false.
      enddo
         
      deallocate (ibl1)
      deallocate (ibl2)
      deallocate (icro1)
      deallocate (icro2)
 10   continue
      return
      end


         
 

         
 
       subroutine acol(orb1,long)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character*(*) orb1
      character*3000 r,orb
      character*10 num
      character*5 ii(20)
      character*4 rr
      yw=.false.
      orb=' '
      r=' '
      orb(1:long)=orb1(1:long)
 1    continue
      l=index(orb(1:long),'{')+1
      if(yw)print*,'multi6 ',orb(1:long)
      if(l.ne.1) then
         m=index(orb(1:long),'}')-1
         if(index(orb(l:m),' ').ne.0) then
            print*,'il y a un blanc dans les acollades {}'
            print*,'il faut des , ou des -'
            print*,orb(1:long)
            stop
         endif
c        on cherche les limites de la chaine
         l0=1
         do k=l-2,1,-1
            if(orb(k:k).eq.' ') then
               l0=k+1
               exit
            endif
         enddo
         do k=m+2,long
            if(orb(k:k).eq.' ') then
               m0=k-1
               exit
            endif
         enddo
         if(yw)print*,'l0,m0',l0,m0
         n=index(orb(l:m),',')+l-1
         if(yw)print*,'l,m,n',l,m,n
c
c         xxx xxx{x x x x}xxxx xx ...
c             |   |     |    |
c             l0  l     m    m0
c
         if(n.eq.l-1) then
c           la donnee multiple est avec un "-"
            if(yw)print*,'multi6 avec "-"'
            n=index(orb(l:m),'-')
            orb(l+n-1:l+n-1)=' '
            if(yw)print*,orb(l:m)
            if(yw)print*,orb(l+n-1:l+n-1)
            read(orb(l:m),*) i,j
            r=' '
            ifin=0
            do k=i,j
               ideb=ifin+1
               rr=' '
               write(rr,'(i4)') k
               rr=adjustl(rr)
               lrr=len_trim(rr)
               ifin=ideb+l+m0-l0-m-2+lrr
               r(ideb:ifin)=orb(l0:l-2)//rr(1:lrr)//orb(m+2:m0)
               if(yw)print*,'r(ideb:ifin)',r(ideb:ifin)
               if(yw)print*,'ooo',orb(l0:l-2),'  ',orb(m+2:m0)
            enddo
            call repl(orb,orb(l0:m0),r(1:ifin),yrepl)
         else
c           la donnee multiple est avec des ","
            if(yw)print*,'multi6 avec ","'
            nb=1
            do
               nn=index(orb(l:m),',')
               if(nn.eq.0) exit
               orb(l+nn-1:l+nn-1)=' '
               nb=nb+1
            enddo
            if(yw)print*,orb(l:m)
            if(yw)print*,'nb',nb
            ii=' '
            read(orb(l:m),*) ii(1:nb)(:)
            r=' '
            ifin=0
            do k=1,nb
               ii(k)=adjustl(ii(k))
               ideb=ifin+1
               lrr=len_trim(ii(k))
               if(yw)print*,'ii(k)',ii(k),lrr
               ifin=ideb+l+m0-l0-m-2+lrr
               write(r(ideb:ifin),'(a)') 
     *         orb(l0:l-2)//ii(k)(1:lrr)//orb(m+2:m0)
               if(yw)print*,'r(ideb:ifin)',r(ideb:ifin)
               if(yw)print*,'ooo',orb(l0:l-2),'  ',orb(m+2:m0)
            enddo
            call repl(orb,orb(l0:m0),r(1:ifin),yrepl)
         endif
      endif
c     il y a encore des acollades ?
      long=len_trim(orb)
      if(index(orb(1:long),'{').ne.0) goto 1
c     coupure des lignes trop longues
      long=len_trim(orb)
      if(yw) print*,'long',long
      if(yw)print*,'ORB FIN MULTI6 ',orb(1:long)
      do
         if(long.le.70) then
            write(93,'(a)') orb(1:long)
            exit
         else
            do k=70,1,-1
               if(orb(k:k).eq.' ') then
                  write(93,'(a)') orb(1:k)//'&'
                  orb(1:k)=' '
                  orb=adjustl(orb)
                  long=len_trim(orb)
                  exit
               endif
            enddo
         endif
      enddo
      return
      end
       subroutine ligne_suite5(orb,long,ifil)
!     maxl est la dimension de orb dans le programme appelant
      character(*) orb
      character(300) orb1
!      print*,'long',long
      maxl=len(orb)
      if(orb(long:long).eq.'&') then
         do
            read(ifil,'(a)') orb1
            orb1=adjustl(orb1)
            long1=len_trim(orb1)
            if(long1.gt.200.or.long+long1-1.gt.maxl) then
               print*,'ligne trop longue'
               write(6,'(a80)') orb(1:long)
               stop
            endif
            orb(long:long+long1-1)=orb1(1:long1)
            long=long+long1-1
            if(orb1(long1:long1).ne.'&') exit
         enddo
      endif
      return
      end
