      subroutine bb(AA,itest)
      use mod_dolo
      use mod_bond
      use mod_script
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(dim_datlist) :: AA
      logical del
      character(1000) chain
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character(1000),dimension(115) :: basref=(/(' ',k=1,115)/)
      save basref
      character(4) atom_before,atom_after,atom_curr
      dimension coor_after(3),coor_before(3),coor1(3)
      real(8),allocatable :: v(:)
      yw=.true.
      allocate(v(norb))
      if(yes) print*,'entree bb'
      in_progress='BB'
      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)='/'
!
!-----------------------
! 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 (BB_ BASREF=...)
         return
      endif
!
! read chain
!
      chain=' '
      call namela(AA,CHAIN,'CHAIN')
!
! compute nn = nb or atoms in chain
!
      call trouve_nn(chain,nn)
!
! (interpret CHAIN)
! interpret double and triple bonds
!replace '-' '=' '~' by pi data
 
!----------------------------------
! Once nn is known, Allocations
!----------------------------------
!
      allocate(sig(nn-1),pi(nn-1),lp(nn),vi(nn))
      allocate(basloc(nn),atomloc(nn))
! basis sets or the atoms
      call trouve_bas2(basref,nn)
      call namela(AA,BASLOC,'BAS')
      if(any(basloc==' ')) then
         print*,'***************'
         print*,'blank basis set'
         do kk=1,nn
            print*,'BAS',kk,'  ',trim(basloc(kk))
         enddo
         print*,'***************'
         stop
      endif
      do kk=1,nn
         print*,'BASLOC',kk,trim(basloc(kk))
         call extendbas(basloc(kk))
         print*,'basloc',kk,trim(basloc(kk))
      enddo
      do k=1,norb
         call maj(orbi(k),80)
      enddo
 
      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(yw)print*,'ii1,ii2,ii3,ii',ii1,ii2,ii3,ii
!  look for atom before bond
         do l=ii-1,1,-1
            jj=ii
            !print*,chain(l:l)
            if(chain(l:l)==''''.or.l==1) then
               if(l>1)atom_before=chain(l+1:jj-1)
               if(l==1)atom_before=chain(l:jj-1)
               exit
            endif
            if(chain(l:l)=='(') jj=l
         enddo
         if(yw)print*,'atom_before ',atom_before
!  look for atom after bond
         do l=ii+1,len_trim(chain)+1
            jj=ii
            if(chain(l:l)=='-'.or.chain(l:l)=='='.or.chain(l:l)=='~'.or.
     *      chain(l:l)==';'.or.chain(l:l)=='('.or.l==len_trim(chain)+1)
     *      then
               atom_after=chain(jj+1:l-1)
               exit
            endif
         enddo
         if(yw)print*,'atom_after ',atom_after
! build pairs of bonded atoms (smallest interatomic distances)
!   keep atom_before, search image of atom_after closest to atom_before
         print*,'natom',natom,natom1
         do ia=1,natom
            if(atom(ia)==atom_before) then
               coor_before=coor(:,ia)
               exit
            endif
         enddo
         print*,'sym1',sym1
         yangstrom=.true.
         do ia=1,natom
            if(atom(ia)==atom_after) then
               coor_after=coor(:,ia)
               call caldist(d,coor_after,coor_before,coor1,
     *         msym,sym1,yangstrom,is)
               exit
            endif
         enddo
         print*,'coor_after ',coor_after
         print*,'coor_before',coor_before
         print*,'coor1      ',coor1
         print*,'is',is
! bond vector
         coor1=coor_after-coor_before
         coor1=coor1/sqrt(dot_product(coor1,coor1))
         print*,'vector      ',coor1
         ll=0
! put coefs on MO
!   sigma bond
!     loop on orbi, labels of AO's
         v=0.d0
         do js=1,nsym
            nn=0
            do l=1,isym(js)
               ll=ll+1
               !print*,'orbi',js,l,orbi(ll)
!     loop on basis set of atom_before, and atom_after
               atom_curr=atom_before
               aa=basloc(k)
               do icas=1,-1,-2
                  do
                     lb=index(aa,'(')
                     !print*,'AA ',trim(aa)
                     read(aa(lb+1:lb+1),'(i1)') n
                     !print*,'n',n
                        !print*,'orbi',js,l,ll,orbi(ll)
                  print*,'orbj',atom_curr//aa(1:lb-1),trim(orbi(ll))
                     if(orbi(ll)==atom_curr//aa(1:lb-1)) then
                        nn=nn+1
                        print*,'n,nn',n,nn
                        if(nn==n) then
                           print*,'ORBI',js,l,nn,orbi(ll)
                           if(index(orbi(ll),'1S')>0) then
                              v(ll)=1.d0
                           else if(index(orbi(ll),'2PX')>0) then
                              v(ll)=coor1(1)*icas
                           else if(index(orbi(ll),'2PY')>0) then
                              v(ll)=coor1(2)*icas
                           else if(index(orbi(ll),'2PZ')>0) then
                              v(ll)=coor1(3)*icas
                           endif
                           nn=0
                        endif
                     endif
                     aa(1:lb+2)=' '
                     aa=adjustl(aa)
                     if(aa==' ') exit
                  enddo
                  atom_curr=atom_after
                  aa=basloc(k+1)
               enddo
            enddo
         enddo
         do kk=1,norb
            print'(a,f8.4)',orbi(kk),v(kk)
         enddo
         





         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)
      enddo
      stop
      do
 
 
 
 
 
 
 
 
 
 
         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*,'chain(1:ii)',chain(1:ii)
         lp(k)=0
         jj=index(chain(1:ii),'(LP')
         if(jj/=0) then
            if(yw)print*,'lp,k=',k
            read(chain(jj+3:jj+3),'(i1)') lp(k)
            chain(jj:)=chain(jj+5:)
            if(yw)print*,'CHAIN2 ',trim(chain)
         endif
! replace (VIn) by lp data
         if(yw)print*,'chain(1:ii)',chain(1:ii)
         vi(k)=0
         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
      enddo
! Read atom in chain
 
      if(yw)print*,'LP',lp
      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
      mult=sig+pi
      if(yw)print*,'nn',nn
      if(yw)print*,'lp',lp(1:nn)
      if(yw)print*,'vi',vi(1:nn)
      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)
!
! End analysing chain
!
      stop
      return
      end
 
       subroutine extendbas(bas)
      character(80) bas
      character n
      logical(1) yrepl
      i=index(bas,'2P(')
      if(i>0) then
         n=bas(i+3:i+3)
         call repl(bas,'2P('//n,'2PX('//n//') '//'2PY('//n//') '//
     *   '2PZ('//n,yrepl)
      endif
      i=index(bas,'3D(')
      if(i>0) then
         n=bas(i+3:i+3)
         call repl(bas,'3D('//n,'3D0('//n//') '//'3D1-('//n//') '//
     *   '3D1+('//n//') '//'3D2-('//n//') '//'3D2-('//n,yrepl)
      endif
      return
      end
      
