subroutine sym0
Use lewis_module
use mod_script
IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
double precision,allocatable,dimension(:,:) :: coors
logical ynouveau
character(2) shell(8)
character(2) end_AO
nums=(/'1','2','3','4','5','6','7','8'/)
!
! Mise des valeurs avec symetrie dans natom0, atom0, coord0...
!
natom0=natom
allocate(coord0(3,natom0))
do k=1,natom0
   atom0(k)=atom(k)(1:4)
enddo
do k=1,norb
   label0(k)=label(k)(1:8)
enddo
coord0=coord
!      if(nsym==1) then
!         return
!      endif
!
! Nombre d'atomes si on n'avait pas de symetrie
!
call symmsim(symm_sew,sim,nsym)
natom=0
allocate(coors(3,nsym))
open(99,form='unformatted')
print*,' '
print*,'Atomes en symetrie (coordonnees en angstrom)'
print*,' '
do i=1,natom0
   nat=1
   coors(:,1)=coord(:,i)
   natom=natom+1
   write(99) coord0(:,i),atom0(i)//'_1',1
   write(6,'(a,3f10.6,4x,a)') 'coord0',coord0(:,i)*0.529177249,atom0(i)
! On genere tous les symetriques de l'atome i
   do j=2,nsym
      coors(:,j)=coord(:,i)
      if(index(sim(j),'X')/=0) coors(1,j)=-coors(1,j)
      if(index(sim(j),'Y')/=0) coors(2,j)=-coors(2,j)
      if(index(sim(j),'Z')/=0) coors(3,j)=-coors(3,j)
   enddo
! on compte combien de symetriques de i sont differents
   do j=2,nsym
      ynouveau=.true.
      do k=1,j-1
         dx=coors(1,j)-coors(1,k)
         dy=coors(2,j)-coors(2,k)
         dz=coors(3,j)-coors(3,k)
         d=SQRT(dx**2+dy**2+dz**2)
         if(d<1.d-8) then
            ynouveau=.false.
            exit
         endif
      enddo
      if(ynouveau) then
         natom=natom+1
         nat=nat+1
         write(99) coors(:,j),atom0(i)//'_'//nums(nat),j
               !write(6,*) coors(:,j),atom0(i)//'_'//nums(nat)
      endif
   enddo
enddo
print*,' '
print*,'nb d''atomes apres generation des at symetriques',natom
rewind 99
!
! Atomes sans symetrie et leurs coordonnees
! Symetrie par laquelle est genere l'atome (atomsym)
!
deallocate(atom,coord)
allocate(atom(natom))
allocate(atomsym(natom))
allocate(coord(3,natom))
do i=1,natom
   read(99) coord(:,i),atom(i),atomsym(i)
enddo
close(99,STATUS='DELETE')
print*,' '
print*,'coordonnees des atomes sans symetrie (angstrom)'
call mscript(COORD*0.529177249)
print*,'labels des atomes sans symetrie'
print'(10(5x,10a8,/))',atom
print'(a)','Symetrie par laquelle est genere chaque atome'
print'(20i3)',atomsym
!
! Multiplicite des atomes
!
call multat0
!!
!! Appartenance des atomes aux differentes zones de symetrie
!!
!!  1. Les atomes en donnee sont dans la zone 1
!      do i=1,natom
!         if(
!
! Base des atomes
!
     !do k=1,norb
     !   print*,'label',k,label(k)
     !enddo
     !do k=1,norb
     !   print*,'label0',k,label0(k)
     !enddo
allocate(nshell(natom0,8))
norbsh=0
nshell=0
do ishell=1,8
   do i=1,natom0
      nshell(i,ishell)=0
      do k=1,norb
         if(label0(k)(1:5)==atom0(i)//nums(ishell)) then
            norbsh=norbsh+1
            nshell(i,ishell)=nshell(i,ishell)+1
         endif
      enddo
   enddo
         !print*,'norbsh',norbsh
   if(norbsh==norb) then
      maxsh=ishell
      exit
   endif
enddo
do ishell=2,8
   nshell(:,ishell)=nshell(:,ishell)/(ishell*2-1)
enddo
do iat=1,natom0
   nshell(iat,:)=nshell(iat,:)/liste_multat2(iat)
enddo
print*,' '
print*, &
'bases des atomes (nb de couches S, P, D... pour chaque atome)'
do k=1,natom0
   print'(a,i4,a,8i3)', &
   'Atome',k,'('//atom0(k)//')  : ',nshell(k,:)
enddo
!
! Generation de label sans symetrie
!
norbs=0
shell=(/'1S','2P','3D','4F','5G','6H','7I','8J'/)
!   boucle sur les atomes en symetrie (liste courte)
do i=1,natom0
!   boucle sur la multiplicite de l'atome i
   do j=1,liste_multat2(i)
!   boucle sur le nb max de couches de tous les atomes
      do k=1,maxsh


!   boucle boucle sur le nb d'orb par couche (1 pour S, 3 pour P...)
         do m=1-k,k-1
            if(k==1) then
               end_ao=' '
            else if(k==2) then
               if(m==-1) then
                  end_ao(1:1)='X'
               else if(m==0) then
                  end_ao(1:1)='Y'
               else if(m==1) then
                  end_ao(1:1)='Z'
               endif
            else
               write(end_ao(1:1),'(i1)') abs(m)
               if(m==0) end_ao(2:2)=' '
               if(m<0) end_ao(2:2)='-'
               if(m>0) end_ao(2:2)='+'
            endif
!   boucle sur le nb de gaussiennes contractees de la couche k
            do l=1,nshell(i,k)
               norbs=norbs+1
               label(norbs)=atom0(i)//'_'//nums(j)//shell(k) &
               //end_AO
            enddo
         enddo
      enddo
   enddo
enddo
!      do k=1,norb
!         print*,k,label(k),label0(k)
!      enddo
!
! Matrice de passage sym/non sym
!
allocate(pass(norb,norb))
pass=0.d0
allocate(itsym(norb))
! symetries des labels label0
l=0
do is=1,nsym
   do k=1,isym(is)
      l=l+1
      itsym(l)=is
   enddo
enddo
call calpass
!
! Normalisation de pass
!
do i=1,norb
   anor=0.d0
   do j=1,norb
      anor=anor+pass(j,i)*pass(j,i)
   enddo
   anor=dsqrt(anor)
   pass(:,i)=pass(:,i)/anor
enddo
print*,' '
if(norb<=20) then
   print*,'Matrice de passage OA/OAsym'
   call mscript_lab(pass,label,label0,norb,norb)
endif
if(nprint>=3)print*,' '
if(nprint>=3)print*,'Matrice de passage OA/OAsym'
if(nprint>=3)call mscript_lab(pass,label,label0,norb,norb)

end
 function numat(at)
Use lewis_module
use mod_script
character(4) at
do i=1,natom0
   if(atom0(i)==at) then
      numat=i
      return
   endif
enddo
end

 subroutine multat0
Use lewis_module
use mod_script
allocate(liste_multat1(natom0))
allocate(liste_multat2(natom0))
liste_multat1(1)=atom(1)(1:4)
liste_multat2(1)=1
k=1
do i=2,natom
   if(atom(i)(1:4)==atom(i-1)(1:4)) then
      liste_multat2(k)=liste_multat2(k)+1
   else
      k=k+1
      liste_multat1(k)=atom(i)(1:4)
      liste_multat2(k)=1
   endif
enddo
print*,' '
print*,'multiplicite des atomes'
do k=1,natom0,5
   do l=0,3
      if(k+l>natom0) goto 3
      write(6,'(a,i2,9x)',advance='no')liste_multat1(k+l),liste_multat2(k+l)
   enddo
   if(k+4>natom0) goto 3
   write(6,'(a,i2)') liste_multat1(k+4),liste_multat2(k+4)
enddo
3 continue
!do k=1,natom0
!   print*,liste_multat1(k),liste_multat2(k)
!enddo
end
 subroutine calpass
Use lewis_module
use mod_script
IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
character(10) lab
character(1) c
double precision,allocatable,dimension(:,:) :: coors
logical,allocatable :: y(:)
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/)
allocate(y(norb))
allocate(coors(3,nsym))
! Boucle sur les labels en symetrie (label0)
l0=0
do is0=1,nsym
   y=.false.
   do k=1,isym(is0)
      l0=l0+1
!   le label (label0) s'ecrit "ATOM"//"BASE" (2 fois 4 caracteres)
      iat=numat(label0(l0)(1:4))
!   iat est le numero de l'atome du label (dans la liste courte)
      read(label0(l0)(5:5),'(i1)') ishell
!   ishell vaut 1 si l'orbitale est S, 2 si P, etc...
!   multiplicite de la base
      mulbas=nshell(iat,ishell)

!
! On genere les labels sans symetries equivalents a l0
!
!   boucle sur les operations de symetrie
      inouveau=0
      do is=1,nsym
!   image de l'atome iat par is
         coors(:,is)=coord0(:,iat)
         if(index(sim(is),'X')/=0) coors(1,is)=-coors(1,is)
         if(index(sim(is),'Y')/=0) coors(2,is)=-coors(2,is)
         if(index(sim(is),'Z')/=0) coors(3,is)=-coors(3,is)
! on compte combien de symetriques de iat sont differents
         ynouveau=.true.
         do ks=1,is-1
            dx=coors(1,is)-coors(1,ks)
            dy=coors(2,is)-coors(2,ks)
            dz=coors(3,is)-coors(3,ks)
            d=SQRT(dx**2+dy**2+dz**2)
            if(d<1.d-8) then
               ynouveau=.false.
               exit
            endif
         enddo
         if(ynouveau) then
            inouveau=inouveau+1
            lab=label0(l0)(1:4)//'_'//nums(inouveau)// &
            label0(l0)(5:8)
!                  print'(i5,2x,a,2x,a,2i2)',l0,label0(l0),lab
!     *            ,is0,is
! signe du a la transformation
            yx=index(sim(is),'X')/=0
            yy=index(sim(is),'Y')/=0
            yz=index(sim(is),'Z')/=0
            call isgnoa(label0(l0)(5:8),yx,yy,yz,isgnt)
! signe du a la symetrie de la transformation
            isgns=itransf(is,is0)
!                 print'(a,2i4,2x,a,2i2,1X,a,2i4)'
!    *            ,'label equiv a',l,l1,label0(l),is,isi,sim(isi)
!    *            ,isgnt,isgns
! on cherche lab dans la liste des labels
            l1=0
            do
               l1=l1+1
               if(l1>norb) exit
               if(lab/=label(l1)) cycle
               if(y(l1)) cycle
               y(l1)=.true.
               pass(l1,l0)=1.d0*isgns*isgnt
         !print'(a,2i5,2x,a,i3)','STO',l0,l1,label(l1),mulbas
               l1=l1+mulbas*(2*ishell-1)-1
            enddo
         endif
      enddo
   enddo
enddo
      !print*,'pass'
      !call mscript(pass)
end



