      subroutine datoto(AA)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxatomlp=1000)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character*1280 namel
      character(len_datlist) aa,aa0
      character(100) cond
      character(4) atom1,atom2,a1,a2,para,orth,atomlp(maxatomlp)
     *,atompara
      character(200) bas1,bas2
      character(7) occup
      character(80) baselp(maxatomlp),substract(2)
      character(10) stop,cref,cov
      character(11) label1,labelt(100)
      character label0,cy1
      dimension nov(2),multlp(maxatomlp)
      character(2) cref1,cref2,crefi(10)
      character(3) ccor,suffix
      dimension coor1(3)
      integer ncor=0
      yw=.false.
      yw1=.false.
      if(yes)print*,'entree DATOTO'
      iref=0
      ndif=0
 
 
 
 
 
      rewind 93
      inquire(94,name=cond)
      close(94,status='DELETE')
      open(94,status='new',file=cond)
!      call titre('Groupes de Liaisons#',40)
      ysaut=.true.
!
      rewind 93
         if(yw)print*,'AA ',trim(aa)
!!!!!!!!!!!!!!!!!!!!!!
! Donnees SIGMA_ et PI_
!!!!!!!!!!!!!!!!!!!!!!
!
! Liaisons sigma et pi
         if(aa(1:6)=='SIGMA_'.or.aa(1:3)=='PI_') then
            if(aa(1:6)=='SIGMA_') then
               suffix='.SG'
            else
               suffix='.PI'
            endif
            ypara=index(aa,'PARA')>0
            yorth=index(aa,'ORTH')>0
            print'(/,/,80a1)',('Â§',k=1,80)
            !print'(a,/)',trim(aa)
            print*,'Generated Basic Data'
            !if(aa(1:6)=='SIGMA_')print*,'Liaisons sigma ',trim(aa)
            !if(aa(1:6)=='PI_')print*,'Liaisons pi ',trim(aa)
            yangstrom=index(aa,'ANGSTROM')/=0
            call repl(aa,'ANGSTROM',' ',yrepl)
            l=len_trim(aa)
! transformation de aa en donnee de namelist
            call repl(aa,' ',',ATOM1=''',yrepl)
            call repl(aa,' ',"',BAS1='",yrepl)
            !print*,'aa',trim(aa)
            l=len_trim(aa)
            call repl(aa(1:l),' DMAX',",DMAX",yrepl)
            !print*,'aa',trim(aa)
            call repl(aa(1:l),' LABEL',",LABEL",yrepl)
            l=len_trim(aa)
            i=index(aa,':')
            call repl(aa,' :',"',",yrepl)
            call repl(aa(i+1:l+8)," ","ATOM2='",yrepl)
            call repl(aa(i+1:l+13),' ',"',BAS2='",yrepl)
            l=len_trim(aa)
            i=index(aa,'BAS2')
            j=index(aa(i:l),',')+i-1
            !print*,'aa',trim(aa)
            !print*,'i,j',i,j,aa(1:j)
            aa(j+1:l+1)=aa(j:l)
            aa(j:j)=''''
            l=l+1
!            print*,'aa',trim(aa)
!            i=index(aa,'DMAX')-2
!            call repl(aa(i+1:l+14),' ',"',",yrepl)
!            print*,'aa',trim(aa)
!            i=index(aa,'LABEL')-2
!            if(i/=-2) call repl(aa(i+1:l+14),' ',"',",yrepl)
            !print*,'aa',trim(aa)
            l=len_trim(aa)+1
            aa(l:l)=','
            i=index(aa,' ,')
            do while(i/=0)
               call repl(aa,' ,',",",yrepl)
               i=index(aa,' ,')
            enddo
            i=index(trim(aa),', ')
            do while(i/=0)
               call repl(aa,', ',',',yrepl)
               i=index(trim(aa),', ')
            enddo
            !print*, trim(aa)
! ...puis lecture de cette namelist
            label1=' '
            if(yw) print*,'aa',trim(aa)
            call namela(aa,ATOM1,'ATOM1')
            call namela(aa,ATOM2,'ATOM2')
            call namela(aa,BAS1,'BAS1')
            call namela(aa,BAS2,'BAS2')
            call nameld(aa,dmax,'DMAX',8)
            call namela(aa,LABEL1,'LABEL')
            call maj(label1,11)
            if(yw) then
               print*,'ATOM1 ',atom1
               print*,'ATOM2 ',atom2
               print*,'bas1 ',trim(bas1)
               print*,'bas2 ',trim(bas2)
               print*,'dmax' ,dmax
               print*,'natom,natom1 ',natom,natom1
               do k=1,natom1
                  print*,'k,atom(k) ',k,atom(k)
               enddo
            endif
            l1=len_trim(atom1)
            atom1(l1:l1)=' '
            l1=len_trim(atom2)
            atom2(l1:l1)=' '
            if(yw)print*,'atom1,atom2',atom1,atom2
            if(yw)print*,'yangstrom',yangstrom
! liaisons invariantes par symetrie
            if(atom1==atom2) then
               ext:   do i=1,natom1
                  a1=atom(i)
                  do j=1,i-1
                     if(a1==atom(j)) cycle ext
                  enddo
                  do j=i+1,natom1
                     a2=atom(j)
                     if(a1==a2) then
                        call suppnum(a1)
                        if(a1/=atom1) cycle
                        d=dsqrt((coor(1,i)-coor(1,j))**2
     *                  +(coor(2,i)-coor(2,j))**2
     *                  +(coor(3,i)-coor(3,j))**2)
                        if(yangstrom) d=d*0.529177
                        if(yw) then
                           print*,' '
                           print*,'liaisons invariantes par symetrie'
                           print*,'i,j',i,j
                           print*,'atom1,atom2 ',atom1,atom2
                           print*,'a1,a2 ',a1,a2
                           print*,'mult1(i),mult1(j)',mult1(i),mult1(j)
                           print*,'dist',d
                        endif
                        !print*,'D',d,dmax
                        if(d<dmax) then
                           mult=max(mult1(i),mult1(j))/2
                           write(occup,'(a2,i1,a1,i1,a1)')
     *                     ' (',mult,',',mult,')'
                           namel=' '
                           call failabel0(label1,label0,'    ')
                           namel=label0//'_'
                           l=len_trim(namel)
                           write(namel(l+1:300),'(a)')
     *                     trim(atom(i))//suffix//' '//
     *                     trim(atom(i))//' '//trim(bas1)//
     *                     occup
                           l=len_trim(namel)
                           if(ypara) write(namel(l+2:l+15),'(a)')
     *                     ' PARA(0,'//trim(atom(j))//')'
                            if(yorth) then
                               ! on cherche un 2eme atome lie a i ou j
                               do k=1,natom
                                  if(k==i) cycle
                                  dd=dsqrt((coor(1,i)-coor(1,k))**2
     *                           +(coor(2,i)-coor(2,k))**2
     *                           +(coor(3,i)-coor(3,k))**2)
                                  if(yangstrom) dd=dd*0.529177
                                  yd=dd<dmax
                                  if(yd) exit
                               enddo
                               if(yd)write(namel(l+2:l+44),'(a)')
     *                        ' ORTH(0,'//trim(atom(j))//','//
     *                        trim(atom(k))//')'
                            endif
                           l=len_trim(namel)
                           write(6,'(a,f10.6)') trim(namel)
     *                     //  '         d=',d
                           yrepl=.true.
                           do while(yrepl)
                              call repl(namel,'2P(1)',
     *                        "2PX(1) 2PY(1) 2PZ(1)",yrepl)
                           enddo
                           call suppdmax(namel)
                           write(94,'(a)') trim(namel)
                           if(yw)print*,'DATA ',trim(namel)
                        endif
                     endif
                  enddo
               enddo ext
            endif
! Liaisons qui se correspondent par symetrie
            do i=1,natom
               a1=atom(i)
               call suppnum(a1)
               if(yw)print*,'a1,atom1  ',a1,atom1,atom(i)
               if(a1/=atom1) cycle
               do j=1,natom
                  a2=atom(j)
                  call suppnum(a2)
                  if(yw)print*,'   a2,atom2  ',a2,atom2,atom(j)
                  if(a2/=atom2) cycle
                  if(a1==a2.and.i>=j) cycle
                  call caldist(d,coor(:,i),coor(:,j),coor1,
     *            msym,sym1,yangstrom,idum)
                  if(yw)print*,atom(i),atom(j),' d=',d,aa(1:3)
                  if(yw.and.d<dmax) print*,'Liaison retenue'
                  if(d<dmax) then
! Multiplicite de la liaison
                     mult=max(mult1(i),mult1(j))
                     if(yw) print*,'mult',mult,mult1(i),mult1(j)
! formation du label
                     namel=' '
                     call failabel0(label1,label0,'    ')
                     namel=label0//'_'
                     l=len_trim(namel)
                     write(namel(l+1:len(namel)),'(a)')
     *               trim(atom(i))//trim(atom(j))//suffix
                     lsubs=len_trim(namel)
! Y a-t-il une liaison invariante attachee a deux liaisons qui
! se correspondent par symetrie ?
                     substract=' '
                     isubstract=0
                     if(mult>1) then
                        do k=1,natom1
                           if(k==i.or.k==j) cycle
                           if(atom(i)==atom(k)) then
                              call caldist(d1,coor(:,i),coor(:,k),
     *                        coor1,0,sym1,yangstrom,idum)
                              if(d1<dmax) then
                                 ! i est lie a i (couple i,k)
                                 mult=mult+mult1(i)/2
                                 isubstract=isubstract+1
                                 substract(isubstract)=trim(label0)
     *                           //'_'//trim(atom(k))//suffix
                              endif
                           endif
                           if(atom(j)==atom(k)) then
                              call caldist(d1,coor(:,j),coor(:,k),
     *                        coor1,0,sym1,yangstrom,idum)
                              if(d1<dmax) then
                                 ! j est lie a j (couple j,k)
                                 mult=mult+mult1(j)/2
                                 isubstract=isubstract+1
                                 substract(isubstract)=trim(label0)
     *                           //'_'//trim(atom(k))//suffix
                              endif
                           endif
                        enddo
                     endif
                     write(occup,'(a2,i1,a1,i1,a1)')
     *               ' (',mult,',',mult,')'
! formation du reste de la commande
                     l=len_trim(namel)
                     write(namel(l+1:len(namel)),'(a)')
     *               ' '//trim(atom(i))//' '//trim(bas1)//' : '
     *               //trim(atom(j))//' '//trim(bas2)//occup
                     l2=len_trim(namel)
                     if(ypara)write(namel(l2+2:300),'(a)')
     *               ' PARA('//trim(atom(i))//','//trim(atom(j))//')'
 
                     if(yorth) then
                        ! on cherche un 2eme atome lie a i ou j
                        do k=1,natom
                           if(k==i.or.k==j) cycle
                           dd=dsqrt((coor(1,i)-coor(1,k))**2
     *                     +(coor(2,i)-coor(2,k))**2
     *                     +(coor(3,i)-coor(3,k))**2)
                           if(yangstrom) dd=dd*0.529177
                           yd=dd<dmax
                           if(yd) exit
                        enddo
                        if(.not.yd) then
                           do k=1,natom
                              if(k==i.or.k==j) cycle
                              dd=dsqrt((coor(1,j)-coor(1,k))**2
     *                        +(coor(2,j)-coor(2,k))**2
     *                        +(coor(3,j)-coor(3,k))**2)
                              if(yangstrom) dd=dd*0.529177
                              yd=dd<dmax
                              if(yd) exit
                           enddo
                        endif
                        l=len_trim(namel)
                        if(yd)write(namel(l+2:l+44),'(a)')
     *                  ' ORTH('//trim(atom(i))//','
     *                  //trim(atom(j))//','//
     *                  trim(atom(k))//')'
                     endif
                     write(6,'(a,f10.6)') trim(namel)
     *               //  '         d=',d
                     yrepl=.true.
                     do while(yrepl)
                        call repl(namel,'2P(1)',
     *                  "2PX(1) 2PY(1) 2PZ(1)",yrepl)
                     enddo
                     l=len_trim(namel)
                     call suppdmax(namel)
                     write(94,'(a)') trim(namel)
                     do k=1,isubstract
                        write(94,'(a)')'SUBS'//' '//namel(1:lsubs)//
     *                  ' '//trim(substract(k))
                     enddo
                  endif
               enddo
            enddo
!
!!!!!!!!!!!!!!!!!!!!!!!!!
! Donnee CORE_ ou DIFF_
!!!!!!!!!!!!!!!!!!!!!!!!!
!
         else if(aa(1:5)=='CORE_'.or.aa(1:5)=='DIFF_') then
            if(aa(1:5)=='CORE_') then
               ncor=ncor+1
               write(ccor,'(i3)') ncor
            else
               ndif=ndif+1
               write(ccor,'(i3)') ndif
            endif
            ccor=adjustl(ccor)
            print'(/,/,80a1)',('Â§',k=1,80)
!            print'(a,/)',trim(aa)
            print*,'Generated Basic Data'
            labelt=' '
            call namela(aa,LABELT,'LABEL')
! nouvelle donnee pour label : formes '-:G' interdites :
            if(len_trim(labelt(1))>1) then
               print*,'LABEL ',labelt(1)
               print*,'mauvaise donnee pour label (ancienne mode)'//
     *         '(il faut une lettre seulement. ex LABEL=''G'')'
               stop
            endif
!
            l=len_trim(aa)
!  replace for example  "DIFF_ C3 2PY(2) LABEL='G'"  by
!                       "DIFF_ atom1='C3',bas1='2PY(2)',LABEL='G'"
            call repl(aa," ","ATOM1='",yrepl)
            call repl(aa,' ',"',BAS1='",yrepl)
            call repl(aa,'LABEL',',LABEL',yrepl)
            l=len_trim(aa)+1
            aa(l:l)=''','
! replace 2P by 2px 2py 2pz
            yrepl=.true.
            do while(yrepl)
               call repl(aa,'2P(',"2P[X Y Z](",yrepl)
            enddo
! idem replace 3D
            yrepl=.true.
            do while(yrepl)
               call repl(aa,'3D(',"3D[0 1+ 1- 2+ 2-](",yrepl)
            enddo
! read atom1 and bas1
            call namela(aa,ATOM1,'ATOM1')
            call namela(aa,BAS1,'BAS1')
            do k=1,100
               if(labelt(k)==' ') then
                  nlabel=k-1
                  exit
               endif
            enddo
            !print*,atom1
            !print*,bas1
! search atom1 n the list of all atoms of the molecule
            l1=len_trim(atom1)
            ystar=atom1(l1:l1)=='*'
            if(ystar) atom1(l1:l1)=' '
            do i=1,natom
               a1=atom(i)
               if(ystar) then
                  call suppnum(a1)
               endif
               if(a1/=atom1) cycle
               mult=mult1(i)
               if(index(aa,'2P').ne.0) mult=mult*3
               if(aa(1:5)=='DIFF_') then
                  write(occup,'(a4,i1,a1)') ' (0 ',mult,')'
               else
                  write(occup,'(a2,i1,a3)') ' (',mult,' 0)'
               endif
               label0='C'
               if(aa(1:5)=='DIFF_') label0='T'
               do ii=1,nlabel
                  call maj(labelt(ii),11)
                  if(aa(1:5)=='DIFF_') then
                     call failabel0(labelt(ii),label0,'diff')
                  else
                     call failabel0(labelt(ii),label0,'core')
                  endif
                  if(label0/='C') exit
               enddo
               aa0=' '
               if(aa(1:5)=='DIFF_') then
                  write(aa0,'(a)')
     *            label0//'_'//trim(atom(i))//'.DIF_'//trim(ccor)//' '//
     *            trim(atom(i))//' '//trim(bas1)//
     *            occup
               else
                  write(aa0,'(a)')
     *            label0//'_COR.'//trim(atom(i))//'.'//trim(ccor)//' '//
     *            trim(atom(i))//' '//trim(bas1)//
     *            occup
               endif
!               endif
               write(94,'(a)') trim(aa0)
               write(6,'(a)') trim(aa0)
            enddo
!
!----------------------------------------------------
! rename LP's if they are more than one per symmetry
!----------------------------------------------------
!
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Donnee MULT_
!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!         else if(aa(1:5)=='MULT_') THEN
!            call fnormaligo(aa,l)
!! suppression des blancs
!            yrepl=.true.
!            do while (yrepl)
!               call repl(aa(7:l),', ',',',yrepl)
!            enddo
!            print'(/,/,80a1)',('Â§',k=1,80)
!            print'(a,/)',trim(aa)
!            print*,'Generated Basic Data'
!! transform data in namelist and read
!            baselp=' '
!            cond=' '
!            labelt=' '
!            call namela(aa,baselp,'BAS')
!            call namela(aa,cond,'COND')
!            call namela(aa,LABELT,'LABEL')
!            do k=1,100
!               if(labelt(k)==' ') then
!                  nlabel=k-1
!                  exit
!               endif
!            enddo
!            if(aa(1:9)=='MULT_PARA'.and.cond/=' ') then
!               print*,'pas de cond pour MULT_PARA'
!               stop
!            endif
!            i=index(aa,'ATOM=')
!            call repl(aa,'=','=''',yrepl)
!            kv=1
!            if(yw)print*,'kv',kv,trim(aa)
!            do
!               kv=kv+1
!               call repl(aa(i:300),',','''#''',yrepl)
!               if(yw)print*,'kv',kv,trim(aa)
!               if(.not.yrepl) exit
!            enddo
!            l=len_trim(aa)
!            yrepl=.true.
!            do while(yrepl)
!               call repl(aa(i:l),'#',',',yrepl)
!            enddo
!            aa(l:l)=' '
!            if(yw)print*,'kv',kv,trim(aa)
!            atomlp=' '
!            call namela(aa,atomlp,'ATOM')
!            natomlp=0
!            do
!               natomlp=natomlp+1
!               if(atomlp(natomlp)==' ') exit
!            enddo
!            natomlp=natomlp-1
!            if(yw)print*,'atomlp ',atomlp(1:natomlp)
!! multiplicite
!            do i=1,natomlp
!               do j=1,natom1
!                  if(atom(j)==atomlp(i)) then
!                     multlp(i)=mult1(j)
!                     exit
!                  endif
!               enddo
!            enddo
!! bonds
!            do k=1,natomlp
!               if(baselp(k)==' ') then
!                  print*,'pas de base pour l''atome',atomlp(k)
!                  stop
!               endif
!            enddo
!            do k=1,natomlp-1
!               if(aa(1:9)=='MULT_PARA') then
!                  cond='PARA('//trim(atomlp(k))//','//trim(atomlp(k+1))
!     *            //')'
!               endif
!               mul=max(multlp(k),multlp(k+1))
!               nov=mul
!               if(nov(1)>9) then
!                  write(cov(1:2),'(i2)') nov(1)
!                  write(cov(3:3),'(i1)') nov(2)
!               else
!                  write(cov,'(i1,1x,i1)') nov
!               endif
!               label0='O'
!               do i=1,nlabel
!                  call maj(labelt(i),11)
!                  call failabel0(labelt(i),label0,atomlp(k),atomlp(k+1)
!                  if(label0/='O') exit
!               enddo
!               write(6,'(a)')label0//'_'//trim(atomlp(k))//
!     *         trim(atomlp(k+1))//
!     *         ' '//trim(atomlp(k))//' '//trim(baselp(k))//' : '//
!     *         ' '//trim(atomlp(k+1))//' '//trim(baselp(k+1))//' ('//
!     *         trim(cov)//')'//' '//trim(cond)
!               write(94,'(a)')label0//'_'//trim(atomlp(k))//
!     *         trim(atomlp(k+1))//
!     *         ' '//trim(atomlp(k))//' '//trim(baselp(k))//' : '//
!     *         ' '//trim(atomlp(k+1))//' '//trim(baselp(k+1))//' ('//
!     *         trim(cov)//')'//' '//trim(cond)
!            enddo
!
!!!!!!!!!!!!!!!!!!!!!!!!!
! Donnee PICYC_
!!!!!!!!!!!!!!!!!!!!!!!!!
!
         else if(aa(1:6)=='PICYC_') THEN
            yrepl=.true.
            do while(yrepl)
               call repl(aa,'2P(1)','2PX(1) 2PY(1) 2PZ(1)',yrepl)
            enddo
            call fnormaligo(aa,l)
            print'(/,/,80a1)',('Â§',k=1,80)
            print'(a,/)',trim(aa)
            print*,'Generated Basic Data'
            labelt=' '
            call namela(aa,labelt,'LABEL')
            do k=1,4
               if(labelt(k)==' ') then
                  nlabel=k-1
                  exit
               endif
            enddo
! transform data into namelist
            yrepl=.true.
            n=0
            do while(yrepl)
               call repl(aa,'-',''',''',yrepl)
               n=n+1
            enddo
            call repl(aa,' ','&',yrepl)
            call repl(aa,' ',''', ',yrepl)
            call repl(aa,'&',' ATOM=''',yrepl)
            call namela(aa,atomlp,'ATOM')
            call namela(aa,baselp,'BAS')
! case PICYC_ORTH
            bas1=' '
            if(aa(1:10)=='PICYC_ORTH') then
               write(bas1,'(a)')' ORTH('//trim(atomlp(1))//','//
     *         trim(atomlp(2))//','//trim(atomlp(3))//')'
            endif
 
 
! Multiplicity of the cycle
            ! nombre de centres
            nc=0
            do k=1,n
               do kk=1,natom
                  if(atom(kk)==atomlp(k)) then
                     nc=nc+mult1(kk)
                     exit
                  endif
               enddo
            enddo
            print*,'nc',nc
            ! nombre de centres
            if(mod(nc,6).ne.0) then
               print*,'erreur sur la donnee picyc, le nb'//
     *         ' de centres n''est pa sun multiple de 6'
               stop
            endif
            ncyc=nc/6
            ! Ecriture des donnees
            iref=iref+2
            write(cref1,'(i2)') iref-1
            write(cref2,'(i2)') iref
            cref1=adjustl(cref1)
            cref2=adjustl(cref2)
            do iecr=1,3
               write(cy1,'(i1)') iecr
               label0='O'
               do i=1,nlabel
                  call maj(labelt(i),11)
                  call failabel0(labelt(i),label0,atomlp(1),atomlp(2))
                  if(label0/='O') exit
               enddo
               aa0=' '
               write(aa0,'(a)')label0//'_cyc.'//
     *         trim(atomlp(1))//'.'//cy1
               l=len_trim(aa0)
               do k=1,n
                  write(aa0(l+2:300),'(a)') trim(atomlp(k))//
     *            ' '//trim(baselp(k))//' : '
                  l2=len_trim(aa0)
                  if(l2>75) then
                     aa0(l+2:300)=' '
                     write(6,'(a)') trim(aa0)//' &'
                     write(94,'(a)') trim(aa0)//' &'
                     aa0=' '
                     write(aa0,'(a)') trim(atomlp(k))//
     *               ' '//trim(baselp(k))//' : '
                     l2=len_trim(aa0)
                  endif
                  l=l2
               enddo
               aa0(l:l+1)=' &'
               write(6,'(a)') trim(aa0)
               write(94,'(a)') trim(aa0)
               aa0=' '
               if(iecr==1) then
                  write(6,'(a,i1,a,i1,a)')
     *            '(',ncyc*3,',',ncyc*3,') proj 10'//trim(cref2)
     *            //trim(bas1)
                  write(94,'(a,i1,a,i1,a)')
     *            '(',ncyc*3,',',ncyc*3,') proj 10'//trim(cref2)
     *            //trim(bas1)
               else if(iecr==2) then
                  write(6,'(a,i1,a,i1,a)')
     *            '(',ncyc*2,',',ncyc*2,') ref 10'//trim(cref2)
     *            //' proj 10'//trim(cref1)
     *            //trim(bas1)
                  write(94,'(a,i1,a,i1,a)')
     *            '(',ncyc*2,',',ncyc*2,') ref 10'//trim(cref2)
     *            //' proj 10'//trim(cref1)
     *            //trim(bas1)
               else if(iecr==3) then
                  write(6,'(a,i1,a,i1,a)')
     *            '(',ncyc,',',ncyc,') ref 10'//trim(cref1)//trim(bas1)
                  write(94,'(a,i1,a,i1,a)')
     *            '(',ncyc,',',ncyc,') ref 10'//trim(cref1)//trim(bas1)
               endif
            enddo
!
!!!!!!!!!!!!!!!!!!!!!!!!!
! Donnee LPP_
!!!!!!!!!!!!!!!!!!!!!!!!!
!
         else if(aa(1:4)=='LPP_') THEN
            l=len_trim(aa)
            if(aa(l:l)/=',') aa(l+1:l+1)=','
            yrepl=.true.
            do while(yrepl)
               call repl(aa,'2P(1)','2PX(1) 2PY(1) 2PZ(1)',yrepl)
            enddo
            call fnormaligo(aa,l)
            print'(/,/,80a1)',('Â§',k=1,80)
            print'(a,/)',trim(aa)
            print*,'Generated Basic Data'
            labelt=' '
            call namela(aa,labelt,'LABEL')
            do k=1,4
               if(labelt(k)==' ') then
                  nlabel=k-1
                  exit
               endif
            enddo
! Read data as a namelist
            call namela(aa,atomlp,'ATOM')
            call namela(aa,baselp,'BAS')
            call nameli(aa,n,'NORB',4)
            if(n>10) THEN
               print*,'donnee LPP_ : NORB ne peut etre > 10'
               stop
            endif
! Multiplicity of the atom
            do kk=1,natom
               if(atom(kk)==atomlp(1)) then
                  mul=mult1(kk)
                  exit
               endif
            enddo
! Write data
            do k=1,n-1
               iref=iref+1
               write(crefi(k),'(i2)') iref
               crefi(k)=adjustl(crefi(k))
            enddo
            do iecr=1,n
               write(cy1,'(i1)') iecr
               label0='O'
               do i=1,nlabel
                  call maj(labelt(i),11)
                  call failabel0(labelt(i),label0,atomlp(1),atomlp(2))
                  if(label0/='O') exit
               enddo
               aa0=' '
               write(aa0,'(a)')label0//'_LPP.'//
     *         trim(atomlp(1))//'.'//cy1
               l=len_trim(aa0)
               write(aa0(l+2:300),'(a)') trim(atomlp(1))
     *         //' '//trim(baselp(1))
               l=len_trim(aa0)
               if(n==1) then
                  write(aa0(l+2:300),'(a,i1,a)')
     *            '(',mul,' 0)'
               else
                  if(iecr==1) then
                     write(aa0(l+2:300),'(a,i1,a)')
     *               '(',mul,' 0) ref 10'//trim(crefi(1))
                  else if (iecr==n) then
                     write(aa0(l+2:300),'(a,i1,a)')
     *               '(',mul*n,' 0) proj 10'//trim(crefi(n-1))
                  else
                     write(aa0(l+2:300),'(a,i1,a)')
     *               '(',mul*iecr,' 0) ref 10'//trim(crefi(iecr))
     *               //' proj 10'//trim(crefi(iecr-1))
                  endif
               endif
               write(6,'(a)') trim(aa0)
               write(94,'(a)') trim(aa0)
            enddo
!
!!!!!!!!!!!!!!!!!!!!!!!!!
! Donnee LONEP_
!!!!!!!!!!!!!!!!!!!!!!!!!
!
         else if(aa(1:6)=='LONEP_') THEN
            yrepl=.true.
            do while(yrepl)
               call repl(aa,'2P(1)','2PX(1) 2PY(1) 2PZ(1)',yrepl)
            enddo
            call fnormaligo(aa,l)
            print'(/,/,80a1)',('Â§',k=1,80)
            print'(a,/)',trim(aa)
            print*,'Generated Basic Data'
            labelt=' '
            call namela(aa,labelt,'LABEL')
            do k=1,4
               if(labelt(k)==' ') then
                  nlabel=k-1
                  exit
               endif
            enddo
! transform data into namelist
            call nameli(aa,natomlp,'NATOM',4)
            if(yw)print*,'natomlp',natomlp
            call repl(aa,'NATOM=','&&&&&&',yrepl)
            i=index(aa,'ATOM=')
            call repl(aa,'=','=''',yrepl)
            kv=0
            if(yw)print*,'kv',kv,trim(aa)
            do
               kv=kv+1
               if(kv<natomlp) then
                  call repl(aa(i:l+8),',','''#''',yrepl)
                  if(yw)print*,'kv',kv,trim(aa)
               else
                  call repl(aa(i:l+8),',','''#',yrepl)
                  if(yw)print*,'kv',kv,trim(aa)
                  exit
               endif
            enddo
            l=len_trim(aa)
            do k=1,3
               call repl(aa(i:l),'#',',',yrepl)
            enddo
            call repl(aa,'&&&&&&','NATOM=',yrepl)
            aa(l+2:l+2)='/'
            if(yw)print*,'kv',kv,trim(aa)
! read namelist
            baselp=' '
            atomlp=' '
            cond=' '
            atompara=' '
            call nameli(aa,natomlp,'NATOM',4)
        print*,'COND',cond
            call namela(aa,COND,'COND')
            if(aa(1:10)=='LONEP_PARA') call namela(aa,atompara,'LPDIR')
            !print*,'atompara',atompara
            if(aa(1:10)=='LONEP_PARA'.and.cond/=' ') then
               print*,'pas de cond pour LONEPPARA_'
               stop
            endif
            if(aa(1:10)=='LONEP_PARA'.and.atompara==' ') then
               print*,'donner para=''atome d''orientation du'//
     *         ' doublet'' pour LONEP_PARA'
               stop
            endif
            call namela(aa,atomlp,'ATOM')
            call namela(aa,baselp,'BAS')
            if(baselp(2)==' ') then
               baselp(2)=baselp(1)
               baselp(3)=baselp(1)
            endif
            if(yw)print*,'atomlp',atomlp(1:4)
            if(yw)print*,'baselp',baselp(1:4)
! multiple bonds
            do k1=1,natom1
               if(atom(k1)==atomlp(1)) exit
            enddo
            k2=0
            k3=0
            k4=0
            if(natomlp>1) then
               do k2=1,natom1
                  if(atom(k2)==atomlp(2)) exit
               enddo
               mult12=max(mult1(k1),mult1(k2))
               if(natomlp>2) then
                  do k3=1,natom1
                     if(atom(k3)==atomlp(3)) exit
                  enddo
                  mult13=max(mult1(k1),mult1(k3))
                  if(natomlp>3) then
                     do k4=1,natom1
                        if(atom(k4)==atomlp(4)) exit
                     enddo
                     mult14=max(mult1(k1),mult1(k4))
                  endif
               endif
            endif
            if(any((/k1,k2,k3,k4/)==natom1+1)) then
               nov(1:1)=maxloc((/k1,k2,k3,k4/))
               print*,'donnee LP, atome non trouve '
     *         ,atomlp(nov(1))
               print*,atom((/k1,k2,k3,k4/))
               stop
            endif
 
            multd=mult1(k1)
            if(yw)print*,'multd',multd
            iref=iref+1
            cref=' '
            if(iref<10)write(cref(1:1),'(i1)') iref
            if(iref>=10)write(cref(1:2),'(i2)') iref
! liaison 1-2
            if(natomlp>1) then
               if(aa(1:10)=='LONEP_PARA') then
                  cond='PARA('//trim(atomlp(1))//','//trim(atomlp(2))
     *            //')'
               endif
               nov(1)=mult12+multd
               nov(2)=mult12
               if(nov(1)>9) then
                  write(cov(1:2),'(i2)') nov(1)
                  write(cov(3:3),'(i1)') nov(2)
               else
                  write(cov,'(i1,1x,i1)') nov
               endif
               label0='O'
               do i=1,nlabel
                  call maj(labelt(i),11)
                  call failabel0(labelt(i),label0,atomlp(1),atomlp(2))
                  if(label0/='O') exit
               enddo
               write(6,'(a)')label0//'_lp'//trim(atomlp(1))//
     *         trim(atomlp(2))//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' : '//
     *         ' '//trim(atomlp(2))//' '//trim(baselp(2))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
               write(94,'(a)')label0//'_lp'//trim(atomlp(1))//
     *         trim(atomlp(2))//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' : '//
     *         ' '//trim(atomlp(2))//' '//trim(baselp(2))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
            endif
! liaison 1-3
            if(natomlp>2) then
               if(aa(1:10)=='LONEP_PARA') then
                  cond='PARA('//trim(atomlp(1))//','//trim(atomlp(3))
     *            //')'
               endif
               nov(1)=mult13+multd
               nov(2)=mult13
               if(nov(1)>9) then
                  write(cov(1:2),'(i2)') nov(1)
                  write(cov(3:3),'(i1)') nov(2)
               else
                  write(cov,'(i1,1x,i1)') nov
               endif
               label0='O'
               do i=1,nlabel
                  call maj(labelt(i),11)
                  call failabel0(labelt(i),label0,atomlp(1),atomlp(3))
                  if(label0/='O') exit
               enddo
               if(atomlp(2)/=atomlp(3))
     *         write(6,'(a)')label0//'_lp'//trim(atomlp(3))//
     *         trim(atomlp(1))//
     *         ' '//trim(atomlp(3))//' '//trim(baselp(3))//' : '//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
               if(atomlp(2)/=atomlp(3))
     *         write(94,'(a)')label0//'_lp'//trim(atomlp(3))//
     *         trim(atomlp(1))//
     *         ' '//trim(atomlp(3))//' '//trim(baselp(3))//' : '//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
            endif
! liaison 1-4
            if(natomlp>3) then
               if(aa(1:10)=='LONEP_PARA') then
                  cond='PARA('//trim(atomlp(1))//','//trim(atomlp(4))
     *            //')'
               endif
               nov(1)=mult14+multd
               nov(2)=mult14
               if(nov(1)>9) then
                  write(cov(1:2),'(i2)') nov(1)
                  write(cov(3:3),'(i1)') nov(2)
               else
                  write(cov,'(i1,1x,i1)') nov
               endif
               label0='O'
               do i=1,nlabel
                  call maj(labelt(i),11)
                  call failabel0(labelt(i),label0,atomlp(1),atomlp(2))
                  if(label0/='O') exit
               enddo
               if(atomlp(4)/=atomlp(3).and.atomlp(4)/=atomlp(4))
     *         write(6,'(a)')label0//'_lp'//trim(atomlp(4))//
     *         trim(atomlp(1))//
     *         ' '//trim(atomlp(4))//' '//trim(baselp(4))//' : '//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
               if(atomlp(4)/=atomlp(3).and.atomlp(4)/=atomlp(2))
     *         write(94,'(a)')label0//'_lp'//trim(atomlp(4))//
     *         trim(atomlp(1))//
     *         ' '//trim(atomlp(4))//' '//trim(baselp(4))//' : '//
     *         ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *         trim(cov)//') proj 10'//trim(cref)//' '//trim(cond)
            endif
! doublet
            if(aa(1:10)=='LONEP_PARA') then
               cond='PARA('//trim(atomlp(1))//','//trim(atompara)
     *         //')'
            endif
            write(cov,'(i1,1x,i1)')multd,0
               label0='O'
            do i=1,nlabel
               call maj(labelt(i),11)
               call failabel0(labelt(i),label0,atomlp(1),'    ')
               if(label0/='O') exit
            enddo
            write(6,'(a)')label0//'_lp'//trim(atomlp(1))//
     *      ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *      trim(cov)//') ref 10'//trim(cref)//' '//trim(cond)
            write(cov,'(i1,1x,i1)')multd,0
            write(94,'(a)')label0//'_lp'//trim(atomlp(1))//
     *      ' '//trim(atomlp(1))//' '//trim(baselp(1))//' ('//
     *      trim(cov)//') ref 10'//trim(cref)//' '//trim(cond)
         else
            write(94,'(a)') trim(aa0)
            if(yw)write(6,'(a)') trim(aa0)
         endif
      print'(80a1)',('§',k=1,80)
      print*,' '
      rewind 93
      rewind(94)
      if(yw1)print*,'genere par datoto :'
      do
         read(94,'(a300)',end=2) aa0
         write(93,'(a)') trim(aa0)
         if(yw1) print'(a)',trim(aa0)
      enddo
 2    continue
      rewind 93
      if(yes)print*,'sortie DATOTO'
      return
      end
       subroutine suppdmax(namel)
      character(*) namel
      logical yw
      yw=.false.
      l=len_trim(namel)
      if(yw)print*,'namel  ',trim(namel)
      i=index(namel,'DMAX')
      if(i==0) return
      j=index(namel(i:l),' ')+i-1
      if(yw)print*,'dmax  ',namel(i:j-1)
      namel(i:j-1)=' '
      return
      end
 
       subroutine caldist(d,coor3,coor2,coor1,msym,sym1,yangstrom,
     *i_coor_bonne)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8)
      character(40) sym
      dimension coor1(3),coor2(3),coor3(3)
      character(3) sym1(7)
      yw=.false.
      coor1=coor3
      if(yw)print*,'msym',msym
      if(yw)print*,'sym1',sym1(1:msym)
      d=dsqrt((coor1(1)-coor2(1))**2
     *+(coor1(2)-coor2(2))**2
     *+(coor1(3)-coor2(3))**2)
      if(yw)print*,'coor1',coor1
      if(yw)print*,'coor2',coor2
      i_coor_bonne=0
      do is=1,msym
         coor1=coor3
         if(index(sym1(is),'X')/=0) then
            coor1(1)=-coor1(1)
         endif
         if(index(sym1(is),'Y')/=0) then
            coor1(2)=-coor1(2)
         endif
         if(index(sym1(is),'Z')/=0) then
            coor1(3)=-coor1(3)
         endif
         if(yw)print*,'coor1',coor1
         if(yw)print*,'coor2',coor2
         d1=dsqrt((coor1(1)-coor2(1))**2
     *   +(coor1(2)-coor2(2))**2
     *   +(coor1(3)-coor2(3))**2)
         if(yw)print*,'d,d1',d,d1
         if(d1<d) i_coor_bonne=is
         d=min(d,d1)
      enddo
      if(yw)print*,'i_coor_bonne',i_coor_bonne
      coor1=coor3
      if(i_coor_bonne==0) then
         if(yangstrom) d=d*0.529177
         i_coor_bonne=1
         return
      endif
      if(yw)print*,'coor1',coor1
      if(index(sym1(i_coor_bonne),'X')/=0) then
         coor1(1)=-coor1(1)
      endif
      if(index(sym1(i_coor_bonne),'Y')/=0) then
         coor1(2)=-coor1(2)
      endif
      if(index(sym1(i_coor_bonne),'Z')/=0) then
         coor1(3)=-coor1(3)
      endif
         if(yw)print*,'coor1',coor1
      if(yangstrom) d=d*0.529177
      return
      end
 
 
