      subroutine desymorbOA(nsym,orbi,sim,noa,natom,atom,isymt,coor,
     *yx,yy,yz,ioals)
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension itransf(8,8)
      character(3) sim(0:7)
      character(8) orbi(noa)
C      allocatable icoor(:,:)
      character(1),allocatable :: orbi_suffix(:)
      dimension coor(3,natom),isymt(9)
      integer op
      character(4) atom(1000)
      dimension yx(noa),yy(noa),yz(noa),jcoor(3,8),jcoef(8),kcoef(8)
      integer(8) jcoor
      dimension ioals(noa,noa)
      yw=.false.
!
C      allocate(icoor(3,noa))
      allocate(orbi_suffix(noa))
      itransf(1,:)=(/1, 1, 1, 1, 1, 1, 1, 1/)
      itransf(2,:)=(/1,-1, 1,-1, 1,-1, 1,-1/)
      itransf(3,:)=(/1, 1,-1,-1, 1, 1,-1,-1/)
      itransf(4,:)=(/1,-1,-1, 1, 1,-1,-1, 1/)
      itransf(5,:)=(/1, 1, 1, 1,-1,-1,-1,-1/)
      itransf(6,:)=(/1,-1, 1,-1,-1, 1,-1, 1/)
      itransf(7,:)=(/1, 1,-1,-1,-1,-1, 1, 1/)
      itransf(8,:)=(/1,-1,-1, 1,-1, 1, 1,-1/)
!
!----------------------------------
! Preparations
!----------------------------------
!
!
! Calcul icoor
! icoor(1:3,OA)=coordonnees entieres de l'OA
!
C      do is=1,nsym
C         op=is-1
C         print*,' '
C         do i=isymt(is)+1,isymt(is+1)
C         ! On est dans une boucle sur les OA (indice i)
C         ! On cherche le centre correspondant
C            do k=1,natom
C               if(atom(k)==orbi(i)(1:4)) then
C                  icoor(:,i)=100000000*coor(:,k)
C                  ysx=index(sim(op),'X')/=0
C                  ysy=index(sim(op),'Y')/=0
C                  ysz=index(sim(op),'Z')/=0
C                  if(ysx) icoor(1,i)=-icoor(1,i)
C                  if(ysy) icoor(2,i)=-icoor(2,i)
C                  if(ysz) icoor(3,i)=-icoor(3,i)
C                  exit
C               endif
C            enddo
C            print'(a,i4,1x,a,a,3i12)',
C     *      'Orb',i,orbi(i),'  icoor',icoor(:,i)
C         enddo
C      enddo
!
! distinction des OA de meme nom : ajout d'un suffixe
! (pour bases non minimales)
!
      do is=1,nsym
         orbi_suffix(isymt(is)+1:isymt(is+1))=char(48)
         do i=isymt(is)+1,isymt(is+1)
            do j=isymt(is)+1,i-1
               if(orbi(i)==orbi(j)) then
                  n=ichar(orbi_suffix(j))
                  orbi_suffix(i)=char(n+1)
               endif
            enddo
         enddo
      enddo
      if(yw) then
         do is=1,nsym
            print*,' '
            do k=isymt(is)+1,isymt(is+1)
               print*,'SUFF',k,orbi(k),orbi_suffix(k)
            enddo
         enddo
      endif
!
!------------------------------------------------------
! Decomposition des OA de symetrie en OA locales
!------------------------------------------------------
!
! Boucle sur les OA de symetrie
!
 2000 format(a,20i4)
      do is=1,nsym
         do i=isymt(is)+1,isymt(is+1)
            if(yw)
     *      print*,'*************************** OAS   ',orbi(i),i,is
            ! i est une OAS de symetrie is
            ! on la decompose en OAL
            !
            ! la 1ere OAL a les coordonnees de l'atome correspondant
            ! au nom de l'OAS et 1 pour coef
            do k=1,natom
               if(atom(k)==orbi(i)(1:4)) then
                  jcoor(:,1)=100000000*coor(:,k)
                  exit
               endif
            enddo
            if(yw)print*,'jcoor',jcoor(:,1)
            jcoef(1)=1
            ! generation des autres OAL
            if(yw)print*,'coef(1) (signe du 1er atome)',jcoef(1)
            if(yw)print*,'coord du 1er atome',jcoor(:,1)
            do op=1,nsym-1
               ! nouvelles coordonnees
               if(yw)print*,' '
               if(yw)print2000,'operation de symetrie',op
               ysx=index(sim(op),'X')/=0
               ysy=index(sim(op),'Y')/= 0
               ysz=index(sim(op),'Z')/= 0
               jcoor(:,op+1)=jcoor(:,1)
               if(ysx) jcoor(1,op+1)=-jcoor(1,1)
               if(ysy) jcoor(2,op+1)=-jcoor(2,1)
               if(ysz) jcoor(3,op+1)=-jcoor(3,1)
               ! nouveau coef
               jcoef(op+1)=itransf(is,op+1)
               if(yw)print2000,
     *         'signe apres transf par itransf',jcoef(op+1)
               if(ysx.and.yx(i)) jcoef(op+1)=-jcoef(op+1)
               if(ysy.and.yy(i)) jcoef(op+1)=-jcoef(op+1)
               if(ysz.and.yz(i)) jcoef(op+1)=-jcoef(op+1)
               if(yw)print'(a,i4,3i12)',
     *         'signe du a la geometrie, coordonnees'
     *         ,jcoef(op+1),jcoor(:,op+1)
            enddo
!
! Regroupement des coefs dans un liste de coordonnees toutes
! differentes
!
!
            kk=1
            ! 1er coef recopie
            kcoef(1)=jcoef(1)
            do k1=2,nsym
               ymeme=.false.
               do k2=1,k1-1
                  if(all(jcoor(:,k1)==jcoor(:,k2))) then
                     ! ces coordonnees ont deja ete utilisees
                     if(jcoef(k1)/=jcoef(k2)) kcoef(kk)=0
                     ymeme=.true.
                  endif
               enddo
               if(.not.ymeme) then
                  ! les coordonnees sont nouvelles
                  kk=kk+1
                  kcoef(kk)=jcoef(k1)
               endif
            enddo
            if(yw)print*,'kcoef',kcoef(1:kk)
!
!------------------------------------------
! mise des coefs dans la matrice de passage
!------------------------------------------
!
            n=0
            ! boucle sur les coefs non nuls
            ioal=0
            do op=1,kk
               n=n+1
               ! on cherche une OAL de meme nom
               ! ioal : rang de l'OAL de meme nom que l'OAS
               kbid1=ioal
               do kbid=kbid1+1,noa
                  ioal=ioal+1
!              print*,'ioal   ',orbi(ioal)//orbi_suffix(ioal),ioal
!     *        i,'   ',orbi(i)//orbi_suffix(i)
                  if(orbi(ioal)//orbi_suffix(ioal)==
     *            orbi(i)//orbi_suffix(i)) then
                     if(yw)print*,'trouve',ioal
                     ioals(i,ioal)=kcoef(op)
                     exit
                  endif
               enddo
            enddo
            ioals(i,:)=ioals(i,:)*n
         enddo
      enddo
      if(yw)call mscript(ioals)
      return
      end
      
