      subroutine bond(AA,itest)
      use mod_dolo
      use mod_bond
      use mod_script
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! multatloc(atom): number of equivalent atoms due to the symmetry
! multlo            number of equivalent bonds due to the symmetry
! (multlo(bond)     =max(multatloc(atom),multatloc(atom+1)))
!                  operations
! sig(bond)      : number of sigma on bond
! pi(bond)       : number of pi on bond
! mult = sig + pi: multiplicity of bond
! lp(atom)       : number of lone pairs on atom
! vi(atom)       : number of atomic virtuals on atom
! sy(atom)       : if(/=0): atom is bonded to itself (by symmetry)
!                  with a bond of multiplicity sy(atom)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(dim_datlist) :: AA,bb
      logical del
      character(1000) chain
      character(18) labellp
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character(6) lpn,syn,vin
      character(1000),dimension(115) :: basref=(/(' ',k=1,115)/)
      save basref
      yw=.false.
      if(yes) print*,'entree bond'
      in_progress='BOND'
      rewind 94
      l=len_trim(AA)
      if(l+3>dim_datlist) stop'increase dim_datlist'
      if(AA(l:l).ne.',') AA(l+1:l+1)=','
      AA(l+3:l+3)='/'
      bb=aa
!
!-----------------------
! Read data AA (begins)
!-----------------------
!
      if(yw)print*,'AA',trim(aa)
      call trouve_bas(basref,aa,itest)
      if(itest==1) then
         in_progress=' '
! the AA data gave basref (BOND_ BASREF=...)
         return
      endif
!
!----------------------------------------------------------
! AA can give either "ATOMS=" (atomloc) or "CHAIN=" (chain)
! if atomloc is given, the following other data are necessary:
! n= nomber of atoms
! lp= (n values). lp(k)=nb of double occupations on atom k
! vi= (n values). vi(k)=nb of empty orbitals on atom k
!
! the AA data gave chain (BOND_ CHAIN=...) or atomloc (BOND_ ATOMS=...)
!  but must not give both data:
!
! The first version of the program read "ATOMS=..."
! with kew words n,lp,vi,sig,sy
! The new version translates CHAIN=... to ATOMS=...
! (lpn to lp=n, etc...)
!----------------------------------------------------------
!
      chain=' '
      call namela(AA,CHAIN,'CHAIN')
! if (chain is given) compute nn = nb of atoms in chain
      call trouve_nn(chain,nn)
! overwrite nn, if n is given (BOND_ n=...,CHAIN=...)
      call nameli(AA,nn,'N',4)
!
!----------------------------------
! Once nn is known, Allocations
!----------------------------------
!
      allocate(sig(nn-1),pi(nn-1),lp(nn),mult(nn-1),numat(nn),vi(nn))
      allocate(multatloc(nn),llp(nn-1),ivirt(nn-1),iocc(nn-1))
      allocate(basloc(nn),atomloc(nn),labelsp(nn-1))
      allocate(coorloc(3,nn*nsym),multlo(nn-1),multlp(nn),multvi(nn))
      allocate(sy(nn),multsy(nn))
      allocate(ydelsy(nn),y_real_bond(nn-1),y_real_atom(nn))
      y_real_bond=.true.
      y_real_atom=.true.
!
!---------------------------
! Read data AA (continued)
!---------------------------
!
      atomloc=' '
      call namela(AA,atomloc,'ATOMS')
      if(chain/=' '.and.atomloc(1)/=' ') then
         print*,'''chain'' and ''atoms'' cannot be given'//
     *   'simulteanouly'
         print*,'CHAIN ',trim(chain)
         print*,'atomloc ',atomloc(1:nn)
         return
      endif
      mult=0
      pi=0
      sig=1
      lp=0
      sy=0
      vi=0
      del=.true.
      label1='o'
      orth=' '
      para=' '
      call nameli(AA,LP,'LP',4)
      call nameli(AA,SY,'SY',4)
      call nameli(AA,SIG,'SIG',4)
      call nameli(AA,PI,'PI',4)
      call namell(AA,DEL,'DEL',4)
      call nameli(AA,VI,'VI',4)
      call namela(AA,LABEL1,'LABEL')
      call namela(AA,ORTH,'ORTH')
      call namela(AA,PARA,'PARA')
!
! sig is the number of sigma on each bond. The default is 1,
! except if (orth/=' '). in that case, a pi system is generated. sig=0
      if(orth/=' ') sig=0
!
!
!-----------------------------------------------------------
! interpretation of data
!
! The information consist in a list of nn atoms (atomloc)
!
!-----------------------------------------------------------
!
!
      if(chain/=' ') then
! (interpret CHAIN)
! interpret double and triple bonds
!replace '-' '=' '~' by pi data
         ylp=all(lp==0)
         yvi=all(vi==0)
         ysy=all(sy==0)
         if(all(pi==0)) then
            do k=1,nn-1
               ii1=index(chain,'-')
               ii2=index(chain,'=')
               ii3=index(chain,'~')
               ii4=index(chain,';')
               ii=1000
               if(ii1/=0) ii=ii1
               if(ii2/=0) ii=min(ii2,ii)
               if(ii3/=0) ii=min(ii3,ii)
               if(ii4/=0) ii=min(ii4,ii)
               if(ii==ii1) then
                  pi(k)=0
                  call repl(chain,'-',''',''',yrepl)
               endif
               if(ii==ii2) then
                  pi(k)=1
                  call repl(chain,'=',''',''',yrepl)
               endif
               if(ii==ii3) then
                  pi(k)=2
                  call repl(chain,'~',''',''',yrepl)
               endif
               if(ii==ii4) then
                  pi(k)=0
                  sig(k)=0
                  y_real_bond(k)=.false.
                  call repl(chain,';',''',''',yrepl)
               endif
               if(yw)print*,'CHAIN1 ',trim(chain)
               if(ii==ii2) pi(k)=1
               if(ii==ii3) pi(k)=2
               if(yw)print*,'ii1,ii2,ii3,ii,pi(k)',ii1,ii2,ii3,ii,pi(k)
! replace (LPn) by lp data
               if(yw)print'(a,l1)','ylp1 ',ylp
               if(ylp) then
                  if(yw)print*,'chain(1:ii)',chain(1:ii)
                  jj=index(chain(1:ii),'(LP')
                  if(jj/=0) then
                     if(yw)print*,'ylp=T,k=',k
                     read(chain(jj+3:jj+3),'(i1)') lp(k)
                     chain(jj:)=chain(jj+5:)
                     if(yw)print*,'CHAIN2 ',trim(chain)
                  endif
               endif
! replace (VIn) by lp data
               if(yw)print'(a,l1)','yvi1 ',yvi
               if(yvi) then
                  if(yw)print*,'chain(1:ii)',chain(1:ii)
                  jj=index(chain(1:ii),'(VI')
                  if(jj/=0) then
                     if(yw)print*,'yvi=T,k=',k
                     read(chain(jj+3:jj+3),'(i1)') vi(k)
                     chain(jj:)=chain(jj+5:)
                     if(yw)print*,'CHAIN2 ',trim(chain)
                  endif
               endif
! replace (SYn) by sy data
               if(yw)print'(a,l1)','ysy ',ysy
               if(ysy) then
                  jj=index(chain(1:ii),'(SY')
                  if(jj/=0) then
                     if(yw)print*,'ysy=T,k=',k
                     read(chain(jj+3:jj+3),'(i1)') sy(k)
                     sy(k)=sy(k)
                     ifinstring=index(chain(jj+1:),')')
                     syn=chain(jj:jj+ifinstring)
                     if(yw)print*,'SYN',syn
                     ydelsy(k)=syn(5:5)=='D'
                     chain(jj:)=chain(jj+ifinstring+1:)
                     if(yw)print*,'CHAIN3 ',trim(chain)
                  endif
               endif
            enddo
! replace (LPn) by lp data for last atom
            if(yw)print'(a,l1)','ylp2 ',ylp
            if(ylp) then
               jj=index(chain,'(LP')
               if(jj/=0) then
                  if(yw)print*,'LPF',nn
                  read(chain(jj+3:jj+3),'(i1)') lp(nn)
                  lpn=chain(jj:jj+4)
                  if(yw)print*,'LPNF',lpn
                  call repl(chain,lpn,' ',yrepl)
               endif
            endif
! replace (VIn) by vi data for last atom
            if(yw)print'(a,l1)','yvi2 ',yvi
            if(yvi) then
               jj=index(chain,'(VI')
               if(jj/=0) then
                  if(yw)print*,'LPF',nn
                  read(chain(jj+3:jj+3),'(i1)') vi(nn)
                  vin=chain(jj:jj+4)
                  if(yw)print*,'VINF',vin
                  call repl(chain,vin,' ',yrepl)
               endif
            endif
! replace (SYn) by sy data for last atom
            if(yw)print'(a,l1)','ysy ',ysy
            if(ysy) then
               jj=index(chain,'(SY')
               if(jj/=0) then
                  if(yw)print*,'SYF',nn
                  read(chain(jj+3:jj+3),'(i1)') sy(nn)
                     sy(nn)=sy(nn)
                  ifinstring=index(chain(jj+1:),')')
                  syn=chain(jj:jj+ifinstring)
                  ydelsy(nn)=syn(5:5)=='D'
                  if(yw)print*,'SYNF',syn
                  call repl(chain,trim(syn),' ',yrepl)
               endif
            endif
         endif
         if(yw)print*,'CHAIN has been analysed'
         if(orth/=' ') then
            where(sy/=0) sy=sy-1
         endif
         if(yw)print*,'ydelsy',ydelsy
         if(yw)print*,'LP',lp
         if(yw)print*,'SY',SY
         if(yw)print*,'PI',PI
         l=len_trim(chain)
         chain(8:l+7)=chain(1:l)
         chain(1:7)='ATOMS='''
         do while (index(chain,'-')/=0)
            call repl(chain,'-',''',''',yrepl)
         enddo
         l=len_trim(chain)
         chain(l+1:l+2)=''''
         if(yw) print*,'CHAIN4 ',trim(chain)
         call namela(chain,atomloc,'ATOMS')
         if(yw) then
            do k=1,nn
               print*,'atomloc',atomloc(k)
            enddo
         endif
         do k=1,nn
            do l=k+1,nn
               if(atomloc(k)==atomloc(l)) y_real_atom(l)=.false.
            enddo
         enddo
      endif
      if(any(mult==0)) then
         mult=sig+pi
      endif
      if(yw)print*,'nn',nn
      if(yw)print*,'lp',lp(1:nn)
      if(yw)print*,'sy',sy(1:nn)
      if(yw)print*,'vi',vi(1:nn)
      if(yw)print*,'label1  ',label1
      if(yw)print*,'atomloc  ',atomloc(1:nn)
      if(yw)print*,'sig',sig(1:nn-1)
      if(yw)print*,'pi',pi(1:nn-1)
      if(yw)print*,'mult',mult(1:nn-1)
      if(yw)print'(a,l2)','del',del
 
!
      if(nn==1.and.lp(1)==0.and.vi(1)==0.and.sy(1)==0) then
         print*,'*******************************************'
         print*,'one atom only, no LP, no VI   impossible'
         itest=1
         deallocate(sig,pi,lp,mult,numat,vi,sy,ydelsy)
         deallocate(multatloc,llp,ivirt,iocc)
         deallocate(basloc,atomloc,labelsp)
         deallocate(coorloc,multlo,multlp,multvi,multsy)
         deallocate(y_real_bond,y_real_atom)
         print*,'*******************************************'
         return
      endif
!
! Find basis
!
      ! Default value of the basis is in basref
      call trouve_bas2(basref,nn)
      call namela(AA,BASLOC,'BAS')
      if(any(basloc==' ')) then
         print*,'***************'
         print*,'blank basis set'
         do k=1,nn
            print*,'BAS',k,'  ',trim(basloc(k))
         enddo
         print*,'***************'
         stop
      endif
      ! find atoms
      ntrouv=0
      nmat=0
      numat=0
      coorloc=0.d0
      do k=1,natom
         do l=1,nn
            if(atom(k)==atomloc(l)) then
               numat(l)=k
               ntrouv=ntrouv+1
               coorloc(:,l)=coor(:,k)
               if(ntrouv==nn) goto 1
            endif
         enddo
      enddo
 1    continue
      do l=1,nn
         if(numat(l)==0) then
            print*,'atom ',atomloc(l),' not found'
            itest=1
            return
         endif
      enddo
      if(yw)print*,'numat',numat(1:nn)
      if(yw)print*,'atoms',atom(numat(1:nn))
      ! multiplicity of atoms (due to symmetry)
      if(yw)print*,'nsym',nsym
      if(yw)print*,'sym1',sym1(1:nsym-1)
      call multipat(nsym,sym1,nn,coorloc,multatloc)
      !print*,'multatloc',multatloc(1:nn)
!
!------------------------------------------------
! Correction of sy due to multiplicity of atoms
! sy(atom)       : if(/=0): atom is bonded to itself (by symmetry)
!                  with a bond of multiplicity sy(atom)
!------------------------------------------------
!
      do k=1,nn
         sy(k)=sy(k)*multatloc(k)/2
         !print*,'sy',k,sy(k),multatloc(k)
      enddo
      !print*,'sy',sy
!
!-----------------------
! calculate occupation
!-----------------------
!
      if(yw)print*,'nn',nn
      do k=1,nn-1
         ! multiplicity of bond (due to symmetry)
         multlo(k)=max(multatloc(k),multatloc(k+1))
         llp(k)=lp(k)*multatloc(k)+lp(k+1)*multatloc(k+1)
         iocc(k)=(mult(k))*multlo(k)+llp(k)+sy(k)+sy(k+1)
         ivirt(k)=(mult(k))*multlo(k)+sy(k)+sy(k+1)
         if(yw)print'(a,6i7)','k,multlo,llp,iocc,ivirt,mult',
     *   k,multlo(k),llp(k),iocc(k),ivirt(k),mult(k)
      enddo
      multlp(1:nn)=multatloc(1:nn)
      multsy(1:nn)=multatloc(1:nn)
      if(yw) then
         print'(a,20i4)','multlp',multlp(1:nn)
         print'(a,20i4)','multsy',multsy(1:nn)
      endif
!
!-------------------------------
! generation of basis data
!-------------------------------
!
! Bonds
      if(iunit5==5) then
         print*,' '
         print*,'Bond: Generated Basic Data'
         print*,'********************************************'
      endif
      if(yw) then
         do k=1,nn
            print*,'atomloc,basloc',k,trim(atomloc(k)),trim(basloc(k))
         enddo
      endif
      do k=1,nn-1
         if(yw)print*,' '
         if(yw)print*,'bond number',k,'    atoms  ',atomloc(k:k+1)
         if(yw.and..not.y_real_bond(k))print*,'(not a bond)'
         l1=len_trim(atomloc(k))
         l2=len_trim(atomloc(k+1))
         l=l1+l2
         if(y_real_bond(k))
     *   call faidat('SP',atomloc(k:k+1),basloc(k:k+1),bb,iocc(k)
     *   ,ivirt(k),label1,2,orth,para)
         lb=index(bb,' ')
         labelsp(k)=bb(1:lb-1)
      enddo
      if(yw)print*,'labelsp  ',labelsp(1:nn-1),lb
      !if(yw)print*,'BB',trim(bb)
! Lone pairs
      do nlp=1,nn
         if(.not.y_real_atom(nlp)) cycle
         if(yw)print*,' '
         if(lp(nlp)>0) then
            ! do not generate lone paire if already generated
            ! (ex: bond_ chain='n1(lp1)=c3-c4=c5-c6=c1-n1(lp1)'...
            yexit=.false.
            do nlp1=1,nlp-1
               yexit=(lp(nlp1)>0.and.atomloc(nlp)==atomloc(nlp1))
               !print*,'LP EXIT',nlp,nlp1
               if(yexit) exit
            enddo
            !if(yexit) print*,'LP EXIT   ',atomloc(nlp),nlp
            if(yexit) exit
            ! generate data
            call faidat('LP',atomloc(nlp:nlp),basloc(nlp:nlp),bb,
     *      lp(nlp)*multatloc(nlp),0,label1,1,orth,para)
            lb=index(bb,' ')
            labellp=bb(1:lb-1)
            if(yw)print*,'labellp',labellp,lb
! Substraction
            do k=1,nn-1
               if(.not.y_real_bond(k)) cycle
               if(any(atomloc(k:k+1)==atomloc(nlp))) then
                  bb=' '
                  bb='SUBS '//trim(labelsp(k))//' '//trim(labellp)
                  if(yw)print*,'BB  ',trim(bb)
                  if(iunit5==5)print*,trim(bb)
                  write(94,'(a)') trim(bb)
               endif
            enddo
         endif
      enddo
! Symmetry unvariant bonds
      do nsy=1,nn
         if(.not.y_real_atom(nsy)) cycle
         if(yw)print*,' '
         if(sy(nsy)>0) then
            call faidat('SY',atomloc(nsy:nsy),basloc(nsy:nsy),bb,
     *      sy(nsy),sy(nsy),label1,1,orth,para)
            lb=index(bb,' ')
            labellp=bb(1:lb-1)
            if(yw)print*,'labelsy  ',labellp,lb
! Substraction
            do k=1,nn-1
               if(.not.y_real_bond(k)) cycle
               !print*,k,y_real_bond(k),trim(labelsp(k)),trim(labellp)
               if(any(atomloc(k:k+1)==atomloc(nsy))) then
                  bb=' '
                  bb='SUBS '//trim(labelsp(k))//' '//trim(labellp)
                  if(yw)print*,'BB  ',trim(bb)
                  if(iunit5==5)print*,trim(bb)
                  write(94,'(a)') trim(bb)
               endif
            enddo
         endif
      enddo
! Virtual
      do nv=1,nn
         if(yw)print*,' '
         if(vi(nv)>0) then
            call faidat('VI',atomloc(nv:nv),basloc(nv:nv),bb,
     *      0,vi(nv)*multatloc(nv),label1,1,orth,para)
            lb=index(bb,' ')
            labellp=bb(1:lb-1)
            if(yw)print*,'labellp',labellp,lb
         endif
      enddo
      if(iunit5==5) then
         print*,'********************************************'
         print*,' '
         do
            print*,'Continue/exit? (C/X)?'
            read(5,'(a)') reponse
            call maj(reponse,1)
            if(reponse=='X') then
               if(yes)print*,'sortie bond'
               return
            endif
            if(reponse=='C') exit
            print*,'wrond data'
         enddo
      endif
 
 
!
!-------------------------------------------------------
! delete sigma or pi if already given in preceeding data
!-------------------------------------------------------
!
 
 
! Changement de la partie "del". La nouvelle programmation
! ne marche que pour les donnees generees par bond_
! a etendre a celles generees par sigma_ et pi_
 
      goto 111
      if(del) then
         ydel=.false.
         ndel=0
!         if(iunit5==5) then
!            print*,' '
!            print*,' delete sigma or pi if already given in '//
!     *      'preceeding data'
!         endif
         if(yw)print*,'idatlist',idatlist
         do k=1,idatlist
            if(yw)print*,'datlist',k,trim(datlist(k))
         enddo
         rewind 94
         do
            read(94,'(a)',end=10) bb
            if(yw)print*,'to DELETE ',trim(bb),idatlist
            do k=1,idatlist
               if(trim(bb(2:))==trim(datlist(k)(2:))) then
                  call flodeld(k)
                  ydel=.true.
                  if(yw)print*,'DELETE ',trim(bb)!,k,idatlist
               endif
            enddo
         enddo
 10      continue
         if(yw.and..not.ydel) print*,' No deleted old data'
      endif
      !call wdata
      if(yw)print*,'datlist'
      do k=1,idatlist
         if(yw)print'(i3,2a)',k,'  ',trim(datlist(k))
      enddo
 111  continue
!
!-------------------
! save results
!-------------------
!
      open(99,file='BONDTMP',status='unknown',form='unformatted')
      if(nn==1) then
         write(99) nn,lp(1:nn),vi(1:nn),sy(1:nn)
      else
         write(99) nn,sig(1:nn-1),pi(1:nn-1),lp(1:nn),vi(1:nn),sy(1:nn)
      endif
      if(yes) print*,'sortie bond'
      return
      end
 
 
 
       subroutine bond2(ideb,ifin)
      use mod_dolo
      use mod_bond
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter(lmult=100)
      character(dim_datlist) :: bb
      dimension mmult(1)
      real(8) mult2(lmult)
      logical(1) yrepl,yrepl1
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character(4) a,at1,at2,bt1,bt2
      yw=.false.
      if(yes) print*,'entree bond2'
!
      rewind 99
      read(99) nn
      rewind 99
      if(nn==1) then
         write(99) nn,lp(1:nn),vi(1:nn),sy(1:nn)
      else
         write(99) nn,sig(1:nn-1),pi(1:nn-1),lp(1:nn),vi(1:nn),sy(1:nn)
      endif
      close(99,status='delete')
      if(yw)print*,'sig',sig(1:nn-1)
      if(yw)print*,'pi',pi(1:nn-1)
      if(yw)print*,'lp',lp(1:nn)
      if(yw)print*,'vi',vi(1:nn)
      if(yw)print*,'sy',sy(1:nn)
      if(yw)print*,'ideb,ifin',ideb,ifin
!
!----------------------------
! Treat each bond separately
!----------------------------
!
!
!-------------------------------------------------
! Not for Lone Pairs (LP):
! rename LO's if the bond is more than single
!-------------------------------------------------
!
! iwk: LO's corresponding to the bond
! (seek all LO's of the current data (fdat1),
! not containing string "LP"
      yisrealbond=.false.
      do id=ideb,ifin
         if(yw)print*,' '
         if(yw)print*,'ID',id
         nwk=0
         do k=fnorb,1,-1
            if(fdat1(k)/=id) cycle
            if(fdat1(k)<ideb) cycle
            if(yw)print*,'flab',nwk,flab(k)
            if(yw) print*,'fnat(k)',fnat(k)
            l=len_trim(flab(k))
            if(flab(k)(l-1:l)=='LP') cycle
            ! found SP data. seek 1st atom in SP to get multiplicity
            ! of the bond (multsp1=multlo(i))
            yisrealbond=.true.
            do i=1,nn-1
               at1=atoms_in_LO(k,1)
               at2=atoms_in_LO(k,2)
               bt1=atomloc(i)
               bt2=atomloc(i+1)
               if((at1==bt1.and.at2==bt2).or.
     *         (at1==bt2.and.at2==bt1)) then
                  if(fnat(k)==1) then
                     multsp1=multatloc(i)/2
                  else
                     multsp1=multlo(i)
                  endif
                  if(yw)print*,'atomloc',i,atomloc(i),multsp1
                  exit
               endif
            enddo
            if(fnat(k)==1) then
               if(atoms_in_LO(k,1)==atomloc(nn)) then
                  multsp1=multatloc(nn)/2
               endif
            endif
!            if(sy(1)/=0) then
!               if(atoms_in_LO(k,1)==atomloc(1)) then
!                  multsp1=multatloc(1)
!                  if(fnat(k)==1) multsp1=multsp1/2
!                  if(yw)print*,'atomloc',1,atomloc(1),multsp1
!               endif
!            endif
!            if(sy(nn)/=0) then
!               if(atoms_in_LO(k,1)==atomloc(nn)) then
!                  multsp1=multatloc(nn)
!                  if(fnat(k)==1) multsp1=multsp1/2
!                  if(yw)print*,'atomloc',nn,atomloc(nn),multsp1
!               endif
!            endif
            nwk=nwk+1
            iwk(nwk)=k
         enddo
! if .not.yisrealbond, we have no real bond (with 2 atoms)
! It corresponds to an unique atom with LP or VI
         if(.not.yisrealbond) cycle
         call reor(nwk,iwk)
         if(yw)print*,'iwk',iwk(1:nwk)
         mult=0
         if(nwk<=multsp1*2) then
! Single bond
            do m=1,nwk
               if(yw)print*,'1yrepl',flab(iwk(m))
               if(orth.ne.' ') then
                  call repl(flab(iwk(m)),'.SP','.PI',yrepl)
                  call repl(flab(iwk(m)),'.SY','.PI',yrepl1)
               else
                  call repl(flab(iwk(m)),'.SP','.SG',yrepl)
                  call repl(flab(iwk(m)),'.SY','.SG',yrepl1)
               endif
               if(yw)print*,'2yrepl',yrepl
               if(yrepl.or.yrepl1)ftype(iwk(m))='SIGMA'
            enddo
         else
! the bond is more than single
! find sigma and pi LO's
            if(yw)
     *      call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *      focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *      ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
         ! summ all 1s AO coef of LO's  (in mult)
            if(nwk>lmult) stop' mult too small in bond2'
            do k=1,norb
               if(orbi(k)(5:5)=='1') then
                  do l=1,nwk
                     mult2(l)=mult2(l)+abs(flo(k,iwk(l)))
                  enddo
               endif
            enddo
            if(yw)print'(a,12f8.4)','mult ',mult2(1:nwk)
! Sigma orbitals
            if(yw) print*,'multsp1',multsp1
            do k=1,multsp1*2
               mmult=maxloc(mult2(1:nwk))
               m=mmult(1)
               if(yw)print*,'m,iwk(m)',m,iwk(m)
               call repl(flab(iwk(m)),'.SP','.SG',yrepl)
               call repl(flab(iwk(m)),'.SY','.SG',yrepl1)
               if(yw)print*,'3yrepl',yrepl,yrepl1,flab(iwk(m))
               if(yrepl.or.yrepl1)ftype(iwk(m))='SIGMA'
               mult2(m)=0.d0
            enddo
! pi orbitals
            if(yw) print*,'nwk,multsp1',nwk,multsp1
            if(nwk==multsp1*4) then
            ! double bond
               do k=1,nwk
                  call repl(flab(iwk(k)),'.SP','.PI',yrepl)
                  call repl(flab(iwk(k)),'.SY','.PI',yrepl1)
               if(yw)print*,'4yrepl',yrepl,yrepl1,flab(iwk(k))
                  if(yrepl.or.yrepl1)ftype(iwk(k))='PI'
               enddo
            else
! Triple bond
               a(1:1)='P'
               kk=nsym-1
               if(yw)print*,'more than double bond'
               if(yw)print*,'nwk',nwk
               if(yw) then
                  call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,
     *            orbi,6,
     *            focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *            ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
               endif
            call separe_pi(nwk)
C               do k=1,nwk
C                  if(k==nwk/2+1) kk=nsym-1
C                  l=len_trim(flab(iwk(k)))
C                  if(flab(iwk(k))(l-1:l)=='SP') then
C                     kk=kk+1
C                     write(a(2:4),'(i3)') kk/nsym
C                     a(2:4)=adjustl(a(2:4))
C                     if(yw)print*,'a ',trim(a)
C                     call repl(flab(iwk(k)),'.SP','.'//a,yrepl)
C                     call repl(flab(iwk(k)),'.SY','.'//a,yrepl1)
C                     if(yrepl.or.yrepl1)ftype(iwk(k))='PI'
C                  endif
C               enddo
            endif
            if(yw) then
               call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *         focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *         ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
            endif
         endif
      enddo
!
!----------------------------------------------------
! rename LP's if they are more than one per symmetry
!----------------------------------------------------
!
! iwk: LO's corresponding to the LP's
! (seek all LO's of the current data (fdat1), containing string "LP")
!      goto 111
!      nwk=0
!      yw=.true.
!      if(yw)print*,'ideb,ifin,fnorb',ideb,ifin,fnorb
!      do id=ideb,ifin
!         if(yw)print*,' '
!         if(yw)print*,'ID',id
!         do k=fnorb,1,-1
!            if(fdat1(k)/=id) cycle
!            if(fdat1(k)<ideb) exit
!            l=len_trim(flab(k))
!            if(yw)print*,'flab',nwk,flab(k)
!            if(flab(k)(l-1:l)/='LP') cycle
!            ! found LP data. seek atom in LP
!            do i=1,nn
!               if(atoms_in_LO(k,1)==atomloc(i)) then
!                  multlp1=multlp(i)
!                  if(yw)print*,'atomloc',i,atomloc(i),multlp1
!                  exit
!               endif
!            enddo
!            nwk=nwk+1
!            iwk(nwk)=k
!         enddo
!         if(yw)print*,'LP,iwk',iwk(1:nwk)
!         if(nwk>multlp1) then
!            call reor(nwk,iwk)
!            if(yw)
!     *      call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
!     *      focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
!     *      ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
!            mult=0
!            ! there are more than one LP
!            a(1:1)='L'
!            kk=multlp1-1
!            do k=1,nwk
!               l=len_trim(flab(iwk(k)))
!               kk=kk+1
!               write(a(2:2),'(i1)') kk/multlp1
!               call repl(flab(iwk(k)),'.LP','.'//a,yrepl)
!               if(yrepl)ftype(iwk(m))='LP'
!            enddo
!            if(yw)
!     *      call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
!     *      focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
!     *      ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
!        endif
!      enddo
! 111  continue
      nwk=fnorb
! on calcule la multiplicite de toutes les liaisons
      call mult_o
!Pour les liaisons LP et VI, on les renomme s'il y a plus
! d'orbitales que leur multiplicite
      call lp_rename(nwk,flab,fsym,focvir,fmult_o,yes)
      yw=.false.
!
C!-------------------------------------------------
C! rename VI's if they are more than one
C!-------------------------------------------------
C!
C! iwk: LO's corresponding to the VI's
C! (seek all LO's of the current data (fdat1), containing string "VI")
C      nwk=0
C      do id=ideb,ifin
C         if(yw)print*,' '
C         if(yw)print*,'ID',id
C         do k=fnorb,1,-1
C            if(fdat1(k)/=id) cycle
C            if(fdat1(k)<ideb) exit
C            l=len_trim(flab(k))
C            if(yw)print*,'flab',nwk,flab(k)
C            if(flab(k)(l-1:l)/='VI') cycle
C            ! found VI data. seek atom in VI
C            do i=1,nn
C               if(atoms_in_LO(k,1)==atomloc(i)) then
C                  multvi1=multatloc(i)
C                  if(yw)print*,'atomloc',i,atomloc(i),multvi1
C                  exit
C               endif
C            enddo
C            nwk=nwk+1
C            iwk(nwk)=k
C         enddo
C         if(yw)print*,'vi,iwk',iwk(1:nwk)
C         if(nwk>multvi1) then
C            call reor(nwk,iwk)
C            if(yw)
C     *      call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
C     *      focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
C     *      ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
C            mult=0
C            ! there are more than one vi
C            a(1:1)='V'
C            kk=multvi1-1
C            do k=1,nwk
C               l=len_trim(flab(iwk(k)))
C               kk=kk+1
C               write(a(2:4),'(i3)') kk/multvi1
C               a(2:4)=adjustl(a(2:4))
C               call repl(flab(iwk(k)),'.VI','.'//a,yrepl)
C            enddo
C            if(yw)
C     *      call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
C     *      focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
C     *      ,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
C         endif
C      enddo
      in_progress=' '
      deallocate(sig,pi,lp,mult,numat,vi,sy,ydelsy)
      deallocate(multatloc,llp,ivirt,iocc)
      deallocate(basloc,atomloc,labelsp)
      deallocate(coorloc,multlo,multlp,multvi,multsy)
      deallocate(y_real_bond,y_real_atom)
      if(yes) print*,'sortie bond2'
 
 
 
      return
      end
       subroutine faidat(a,atomloc,basloc,bb,iocc,ivirt,label1,n,
     *orth,para)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! builds a canonic (basic) data line
! a: suffix of the label  (LP SP SG ...)
! atomloc: atom names     ('C' 'H')
! basloc: basis names     ('1s(2) 2p(1)' '1s(1))
! bb (output): basis data line
! iocc,ivirt: number of bonding and anti-bonding orbitals
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      use mod_dolo
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(dim_datlist) :: bb
      character(2) a
      character(4) atomloc(*)
      character(80) basloc(*)
      dimension ireor(2)
      logical(1) yrepl
      character(1) label1
      character(15) orth,para
      yw=.false.
      if(yes)print*,'entree faidat   '
      if(yw) then
         print*,'atomloc',atomloc(1:n)
         print*,'basloc',basloc(1:n)
      endif
      if(iocc==0.and.ivirt==0) return
! Reorder atoms in alphabetic order
      call fsort(atomloc,ireor,n)
! build label
      if(yw)print*,'IREOR',IREOR(1:n)
      bb=label1//'_'//trim(atomloc(ireor(1)))
      if(a=='SP') bb=trim(bb)//trim(atomloc(ireor(2)))
      if(a/='SP') then
         l=index(basloc(ireor(1)),'(')-1
         bb=trim(bb)//'.'//trim(basloc(ireor(1))(2:l))
      endif
      bb=trim(bb)//'.'//a
! build atom and basis
      ll=len_trim(bb)+1
      lb=len_trim(basloc(ireor(1)))
      bb(ll+2:ll+8+lb)=atomloc(ireor(1))//' '//trim(basloc(ireor(1)))
      if(a=='SP') then
         bb=trim(bb)//' :'
         lb=len_trim(basloc(ireor(2)))
         ll=len_trim(bb)
         bb(ll+2:ll+8+lb)=atomloc(ireor(2))//' '//trim(basloc(ireor(2)))
      endif
! build occupations "(occ virt)"
      bb=trim(bb)//' ('
      ll=len_trim(bb)
      write(bb(ll+1:ll+8),'(2i4)') iocc,ivirt
      ll=len_trim(bb)
      bb(ll+1:ll+1)=')'
!      print*,'bb',trim(bb)
      do k=1,3
         call repl(bb,'( ','(',yrepl)
         if(.not.yrepl) exit
      enddo
      l=len_trim(bb)
      call fnormaligo(bb,l)
! add PARA or ORTH data
      if(para/=' ') then
         l=len_trim(bb)
         bb(l+2:)='PARA('//trim(para)//')'
      endif
      if(orth/=' ') then
         l=len_trim(bb)
         bb(l+2:)='ORTH('//trim(orth)//')'
      endif
      !idatlist=idatlist+1
      !datlist(idatlist)=bb
      write(94,'(a)') bb
      if(iunit5==5)print*,trim(bb)
      if(yw)print*,'bb  ',trim(bb)
      if(yes)print*,'sortie faidat   '//trim(a)
      return
      end
       subroutine fsort(atomloc,ireor,n)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(4) atomloc(*)
      dimension ireor(2)
      yw=.false.
      if(yw) print*,'fsort atomes',atomloc(1:n)
      if(n==1) then
         ireor(1)=1
         return
      endif
      ireor=(/1,2/)
      do k=1,4
         if(ichar(atomloc(1)(k:k))<ichar(atomloc(2)(k:k))) exit
         if(ichar(atomloc(1)(k:k))>ichar(atomloc(2)(k:k))) then
            if(yw)print*,'fsort echange'
            ireor=(/2,1/)
            exit
         endif
      enddo
      return
      end
       subroutine trouve_nn(chain,nn)
      use mod_dolo
      character(*) chain
      if(yes) print*,'entree trouve_nn'
      l=len_trim(chain)
      nn=1
      do k=1,l
         if(chain(k:k)=='-') nn=nn+1
         if(chain(k:k)=='=') nn=nn+1
         if(chain(k:k)=='~') nn=nn+1
         if(chain(k:k)==';') nn=nn+1
      enddo
      if(yes) print*,'sortie trouve_nn'
      return
      end
       subroutine trouve_bas(basref,aa,itest)
      use mod_dolo
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(1000) basref(natom)
      character(10000) bas
      character(*) aa
!
!------------------------------------------------------
! input: AA = bond_ data
! if the AA='BOND_ BASREF=', fill basref table
! if not, returns with itest==0
!------------------------------------------------------
!
      yw=.false.
      if(yes) print*,'entree trouve_bas'
      if(yw)print*,'AA  depart ',trim(AA)
      bas=' '
      if(yw)print*,'LAS ',len_trim(bas),i,iold,nbbasref
      if(index(AA,'BASREF')==0) then
         itest=0
         return
      else
         itest=1
      endif
      call namela(aa,BAS,'BASREF')
      if(yw)print*,'BAS depart ',trim(bas)
      iold=1
      nbbasref_old=nbbasref
      do
         i=index(bas,',')-1
         if(i==-1) i=len_trim(bas)
         nbbasref=nbbasref+1
         basref(nbbasref)(:)=bas(iold:i)
         basref(nbbasref)=adjustl(basref(nbbasref))
         bas(iold:i+1)=' '
         if(yw)print*,'LAS ',len_trim(bas),i,iold,nbbasref
         if(yw)print*,'BAS ',trim(bas)
         if(bas==' ') exit
         iold=i+2
      enddo
      do k=nbbasref_old+1,nbbasref
         i=index(basref(k),':')
         if(i==0) then
            print*,'error in data  ',trim(basref(k))
            print*,'missing '':'''
            stop
         endif
         basref(k)(5:)=basref(k)(i+1:)
         basref(k)(1:4)=basref(k)(1:i-1)
      enddo
      print*,'Default Basis Sets'
      do k=1,nbbasref
         do l=1,k-1
            if(basref(k)(1:4)==basref(l)(1:4)) then
               basref(l)=basref(k)
               basref(k)=' '
            endif
         enddo
      enddo
 
      do k=1,nbbasref
         print*,trim(basref(k))
      enddo
 
      if(yes) print*,'sortie trouve_bas'
      return
      end
       subroutine trouve_bas2(basref,nn)
      use mod_dolo
      use mod_bond
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(1000) basref(nbbasref)
      character(4) atoml
      yw=.false.
      if(yes) print*,'entree trouve_bas2'
      if(yw)print*,'entree trouve_bas2',nn
      do k=1,nn
         if(yw)print*,'atomloc',k,' '//atomloc(k)
      enddo
      do k=1,nbbasref
         if(yw)print*,k,trim(basref(k))
      enddo
      do k=1,nn
         atoml=atomloc(k)
         do i=len_trim(atoml),1,-1
            if(ichar(atoml(i:i))>47.and.ichar(atoml(i:i))<58)
     *      atoml(i:4)=' '
         enddo
         do l=1,nbbasref
            if(yw)
     *      print*, k,l,' ',atomloc(k),' ',atoml,' ',trim(basref(l))
            if(atoml==basref(l)(1:4)) then
               basloc(k)=basref(l)(5:)
            endif
         enddo
      enddo
      do k=1,nn
         if(yw)print*,'basloc',k,' ',atomloc(k),' ',trim(basloc(k))
      enddo
      if(yes) print*,'sortie trouve_bas2'
      return
      end
