      subroutine verif
      use mod_sym
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(300) aa
      character(4) atom
      character(4),allocatable :: at(:)
      character(7),allocatable :: bas(:,:)
      character(20),allocatable :: proj(:)
      character(7) oa(1000)
      allocatable nbas(:),oa_at(:),natoml(:)
      integer,allocatable,dimension(:) :: occ,a_l,liaisonm,ref
      dimension iproj(20)
      yw1=.false.
      yw2=.true.
      call titre('Recherche des erreurs#',40)
      maxoa=1000
      open(81,file='BID94',status='old')
      open(82,file='ATOM2',status='unknown')
      open(83,file='NATOML',status='unknown')
      open(84,file='OCC',status='unknown')
      open(85,file='PROJ',status='unknown')
      open(86,file='REF',status='unknown')
!
! Liste des atomes, avec redondance
!
!   on ecrit sur 2 : 
!   atom=nom de l'atome trouve. Chaque atome est trouve en general
!   plusieurs fois
!   noa=nb d'OA donnees pour atom (/= du nb d'OA cumulees dans toutes
!   les liaisons
!   iocc,ia_l=occupees, anti-liantes de la liaison ou l'atome apparait
!   liaison=ligne du fichier 2 ou atom apparait
!   oa=OA de atom
!
!   natoml=nb d'atomes de la liaison (de la ligne)
!
      natom=0
      liaison=0
      do
!        1er atome
         read(81,'(a300)',end=1) aa
         liaison=liaison+1
         natoml1=1
         if(yw1)print*,'lu  ',trim(aa)
         i=index(aa,' ')
         aa(1:i)=' '
         aa=adjustl(aa)
         i=index(aa,' ')
         atom=' '
         atom=aa(1:i-1)
         natom=natom+1
!        on recherche la partie occupation
         call ch_occ(aa,iocc,ia_l)
!        on recherche les OA de atom
         call ch_oa(aa,noa,oa)
         write(82,'(a4,3i4,1000a8)') 
     *   atom,noa,liaison,liaison,oa(1:noa)
!        autres atomes
         i=index(aa,':')
         do while(i/=0)
            aa(1:i)=' '
            aa=adjustl(aa)
            i=index(aa,' ')
            atom=' '
            atom=aa(1:i-1)
!           on recherche les OA de atom
            call ch_oa(aa,noa,oa)
            write(82,'(a4,3i4,1000a8)') atom,noa,liaison,0,
     *      oa(1:noa)
            natoml1=natoml1+1
            natom=natom+1
            i=index(aa,':')
         enddo
         if(yw1)print*,'en fin de traitement',trim(aa)
         write(83,*) natoml1
         write(84,*) iocc,ia_l
!
!        projections et references, correction de occ et a_l
!
         i=index(aa,' PROJ ')
         if(i/=0) then
            l=len_trim(aa)
            j=i+6
            ll=index(aa(j:l),' ')
            if(ll==0) then
               ll=l
            else
               ll=ll+j-1
            endif
            write(85,'(a)') aa(j:ll)
         else
            write(85,'(a)') ' '
         endif
         i=index(aa,' REF ')
         if(i/=0) then
            l=len_trim(aa)
            j=i+5
            read(aa(j:l),*) i
         endif
         write(86,*) i
      enddo
 1    continue
      allocate(natoml(liaison),occ(liaison),a_l(liaison))
      allocate(ref(liaison),proj(liaison))
      rewind 83
      rewind 84
      rewind 85
      rewind 86
      do k=1,liaison
         read(83,*) natoml(k)
         read(84,*) occ(k),a_l(k)
         read(85,'(a)') proj(k)
         read(86,*) ref(k)
      enddo
      close(83,status='delete')
      close(84,status='delete')
      close(85,status='delete')
      close(86,status='delete')
!     correction de occ et a_l
      do k=1,liaison
         iproj=0
         n=0
         if(proj(k)/=' ') then
            i=index(proj(k),',')
            n=1
            do while(i/=0)
               n=n+1
               proj(k)(i:i)=' '
               i=index(proj(k),',')
            enddo
         read(proj(k),*) iproj(1:n)
         endif
!        on recherche les ref correspondantes
         do i=1,n
            do j=1,liaison
               if(iproj(i)==ref(j)) then
                  occ(k)=occ(k)-occ(j)
                  a_l(k)=a_l(k)-a_l(j)
               endif
            enddo
         enddo
      enddo
!
! On a note tous les atomes qui appariassent dans les liaisons.
! Chacun apparait en general plusieurs fois
! cette liste est la "liste redondante"
!
! On va maintenant faire une "liste courte", 
! ou chaque atome apparait une
! seule fois, avec TOUTES ses OA
!
      allocate(at(natom),bas(maxoa,natom),nbas(natom),oa_at(natom))
      allocate(liaisonm(natom))
      oa_at=0.d0
      rewind(82)
      i=0
! on lit les atomes sur la liste redondante
      yw2=nprint>0
      if(yw2)print*,'-------------------------------------------------'
      ext: do k=1,natom
         read(82,'(a4,3i4,1000a8)') atom,nbas(k),liaison,lec,
     *   bas(1:nbas(k),k)
         if(lec/=0.and.yw2)print'(a7,i4)','liaison',lec
         if(yw2)print'(2a)',
     *   'atom   nbas  iocc  ia_l liaison natoml rapport   OA'
         iocc=occ(liaison)
         ia_l=a_l(liaison)
         liaisonm(k)=liaison
         ydejaatom=.false.
! on regarde si cet atome a deja ete lu
         do l=1,i
            if(at(l)==atom) then
! l'atome k a deja ete lu en position l
               ydejaatom=.true.
!              on ajoute les oa de k a celles de l
               if(yw1)print*,'nouveau',k,nbas(k),bas(1:nbas(k),k)
               if(yw1)print*,'vieux  ',l,nbas(l),bas(1:nbas(l),l)
               do io1=1,nbas(k)
                  y=.false.
                  do io2=1,nbas(l)
                     if(bas(io1,k)==bas(io2,l)) then
                        y=.true.
                        exit
                     endif
                  enddo
                  if(.not.y) then
                     nbas(l)=nbas(l)+1
                     bas(nbas(l),l)=bas(io1,k)
                  endif
                  if(yw1)print*,'Vieux  ',l,nbas(l),bas(1:nbas(l),l)
               enddo
               oa_at(l)=oa_at(l)+1.d0*(iocc+ia_l)/natoml(liaison)
               exit
            endif
         enddo
         if(.not.ydejaatom) then
            i=i+1
            if(yw1)print*,'atome nouveau  ',atom,i
            at(i)=atom
            nbas(i)=nbas(k)
            bas(1:nbas(i),i)=bas(1:nbas(k),k)
            oa_at(i)=1.d0*(iocc+ia_l)/natoml(liaison)
         endif
         if(yw2)write(6,'(a4,5i6,f12.4,2x,1000a8)')
     *   atom,nbas(l),iocc,ia_l,liaison,natoml(liaison),
     *   oa_at(l),
     *   bas(1:nbas(l),l)
         if(yw2)print*,'-----------------------------------------------'
      enddo ext
      natomr=natom
      natom=i
      print*,'***********************************************'
      print*,'verifier : "dim base"=nb d''OA de l''atome "atom"'
      print*,'verifier : "multiplicite" : multiplicite de "atom"'
      print*,'           due aux tranformations de symetrie'
      print*,'***********************************************'
      print*,'    atom   dim base  multiplicite'
      do k=1,natom
         liaison=liaisonm(k)
         amult=oa_at(k)/nbas(k)
         print'(i4,2x,a4,i8,f10.4)',
     *   k,at(k),nbas(k),amult
         mul=int(amult+0.0001)
         if(abs(1.d0*mul-amult)>1.d-2) then
            print*,'Attention, valeur non entiere de la multiplicite!!!'
         endif
      enddo
      stop
      end
       subroutine ch_oa(aa,noa,oa)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(*) aa
      character(7) oa(1000)
      yw=.false.
      if(yw)print*,'entree ch_oa  ',trim(aa)
!     fin du string des OA
      i=index(aa,':')
      if(i==0) i=index(aa,' (')
      if(yw)print*,'fin OA ',i
!     1ere oa
      i1=index(aa,' ')
      i2=index(aa,') ')
      oa(1)=aa(i1+1:i2)
      noa=1
      aa(i2:i2)='#'
!     autres oa
      i1=i2+1
      i2=index(aa,') ')
!     i2>i, on a depasse la fin du string des OA
      if(i2>i) i2=0
      do while(i2/=0)
         noa=noa+1
         oa(noa)=aa(i1+1:i2)
         aa(i2:i2)='#'
         i1=i2+1
         i2=index(aa,') ')
!        i2>i, on a depasse la fin du string des OA
         if(i2>i) exit
      enddo
      if(yw)print*,'sortie ch_oa  ',oa(1:noa)
      return
      end
       subroutine ch_occ(aa,iocc,ia_l)
      implicit real*8 (a-h,o-x,z),logical*1(y)
      character(*) aa
      yw=.false.
      l=len_trim(aa)
      i=index(aa,' (')
      read(aa(i+2:l-1),*) iocc,ia_l
      if(yw)print*,'iocc,ia_l',iocc,ia_l
      return
      end
