      subroutine desymorb(deveno)
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(50000) namel
      character(80) prefix,molden,info1,info,orb,mono,mono1,stop
     *,inporb
      character(4) atom(1000),bas,atom1
      allocatable ol(:,:),p(:,:),ol0(:,:),iord(:),lb(:)
      double precision,allocatable,dimension(:,:) :: s
      allocatable work(:,:),work1(:,:)
      character(17) c
      character(8),save,allocatable,dimension(:) :: orbi,orbi2
      character(18),allocatable,dimension(:) :: tipo
      double precision,allocatable,dimension(:) :: occup
      allocatable y(:),nts(:,:),isgn(:,:)
      allocatable isgntr(:),coor(:,:),multat(:)
      double precision,allocatable,dimension(:) :: ajk
      dimension isym(8),isymoa(8),isymt(9)
      logical exist_labels,desymact,opened
      logical::existe_fich
      character(80) aa
      character(7) :: mat1
      dimension itransf(8,8)
      character(20) symm
      character(3) sim(0:7),simtmp
      dimension yopx(3),yopy(3),yopz(3)
      dimension nnt(0:7)
      dimension coordloc(3)
      allocatable yx(:),yy(:),yz(:),ioals(:,:)
      integer,allocatable, dimension(:,:) :: toa,stoa
      character(*) deveno
      yw=.false.
      yw1=.false.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Desymetrisation des orbitales molcas (fichier type INPORB)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      print*,'====================================================='
      print*,' DESYMORB DESYMORB DESYMORB DESYMORB DESYMORB'
      print*,'     Desymetrisation des orbitales de INPORB'
      print*,'====================================================='
      print*,' '
!
!---------------------------------------------------
! Signe des autres symetries (isgn(1:nsym,2:nsym))
!---------------------------------------------------
!
      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/)
!
!
! Lecture des donnees
!
      rewind 93
      call LECNAM('&IJKLOC ',namel,93,ierr,1)
      prefix=' '
!      orb='INPORB'
      info1=' '
      mono1=' '
      info='Info'
      mono='Mono'
      symm='SEWARD'
      nprint=0
      inporb='INPORB'
      desymact=.true.
      stop=' '
      call namela(namel,prefix,'PREFIX')
      call nameli(namel,NPRINT,'NPRINT',4)
      call namela(namel,MONO1,'MONO1')
      call namela(namel,MONO,'MONO')
      call namela(namel,INFO1,'INFO1')
      call namela(namel,INFO,'INFO')
      call namela(namel,STOP,'STOP')
      call namela(namel,INPORB,'INPORB')
      call namell(namel,DESYMACT,'DESYMACT',4)
      call namela(namel,SYMM,'SYMM')
      yw1=nprint>=2
      if(info1==' ') info1=trim(prefix)//trim(info)
      if(mono1==' ') mono1=trim(prefix)//trim(mono)
!
! on lit INPORB pour recuperer les occupations et les labels
!
      print*,
     *'on lit INPORB pour recuperer les occupations et les labels'
      inquire(1,opened=opened)
      if(opened) close(1)
      call lirorb(INPORB,noa,nsym,isym,4,1,ifiloc=8,ifillab=10
     *,exist_labels=exist_labels)
      if(.not.exist_labels.and.deveno=='IJKLOC') then
         call titre('Pas de label dans le fichier d''entree ! #',50)
         stop
      endif
!
! lecture de symm
!
      if(nsym>1) then
         if(symm=='SEWARD') then
            ! symm n'a pas ete trouve. On le cherche dans Info
            open(99,status='old',file=info1)
            call LECNAM('&COST_AO ',namel,99,ierr,0)
            call namela(namel,SYMM,'SYMM')
            if(symm=='SEWARD') then
              ! symm n'a toujours pas ete trouve. On le cherche dans &SEWARD
               rewind 93
               call LECNAM('&SEWARD ',namel,93,ierr,0)
               if(ierr==1) then
                  print*,'symm n''a pas ete trouve '
                  stop
               endif
               do
                  read(93,'(a20)') symm
                  symm=adjustl(symm)
                  call maj(symm,20)
                  if(symm(1:4)=='SYMM') then
                     read(93,'(a20)') symm
                     exit
                  endif
                  if(symm(1:3)=='END') exit
               enddo
            endif
            close(99)
         endif
      else
         symm=' '
      endif
      call maj(symm,len_trim(symm))
!
! ouvertures
!
      open(2,file=INFO1,status='old')
      if(nsym==1) symm=' '
!
! On recupere les orbitales a desymetriser dans ol0
! (elles viennent de INPORB)
!
      allocate(ol0(noa,noa))
      allocate(p(noa,noa))
      allocate(iord(noa))
      allocate(yx(noa))
      allocate(yy(noa))
      allocate(yz(noa))
      allocate(toa(noa,nsym-1))
      allocate(stoa(noa,nsym-1))
      allocate (ioals(noa,noa))
      allocate (work(noa,noa))
      allocate (work1(noa,noa))
      allocate(y(noa))
      ioals(:,:)=0
      ol0=0.d0
      rewind 4
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         read(4) ol0(ideb:ifin,ideb:ifin)
      enddo
      rewind 4
!
! on recupere les occupations et les labels des OL a partir de INPORB
!
      allocate(tipo(noa))
      allocate(occup(noa))
      rewind 8
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         read(8) occup(ideb:ifin)
      enddo
      ifin=0
      tipo=' '
      rewind 10
      do k=1,nsym
         if(isym(k)==0) cycle
         ideb=ifin+1
         ifin=ifin+isym(k)
         if(exist_labels) then
            read(10) tipo(ideb:ifin)
         else
            do l=ideb,ifin
               write(tipo(l)(1:5),'(a3,i2)') 'sym',k
            enddo
         endif
      enddo
      if(yw) then
         print*,'tipo'
         do k=1,noa
            print*,k,tipo(k)
         enddo
      endif
      close(1)
      close(10,status='delete')
      close(8,status='delete')
      close(4,status='delete')
      if(.not.desymact) call ren_act(tipo,noa)
!
! on recupere orbi (labels des OA) sur INFO
!
      rewind 2
      call LECNAM('&COST_AO',namel,2,ierr,0)
      if(ierr==1) stop'erreur dans desymorb en lisant cost_ao'
      call nameli(namel,noa,'NORB',4)
      call nameli(namel,NSYM,'NSYM',4)
      call nameli(namel,ISYMOA,'ISYM',4)
      allocate(orbi(noa))
      allocate(orbi2(noa))
      call namela(namel,ORBI,'LABEL')
      call nameli(namel,NATOM,'NATOM',4)
      call namela(namel,ATOM,'ATOM')
      print*,'natom',natom
      allocate(coor(3,natom))
      allocate(multat(natom))
      call nameld(namel,COOR,'COOR',8)
      if(yw)print*,'natom',natom
      do k=1,noa
         call maj(orbi(k),8)
      enddo
      if(yw)print*,'orbi lu dans &COST_AO'
      if(yw)print*, orbi
      print*, ' '
      do is=1,nsym+1
         isymt(is)=sum(isymoa(1:is-1))
      enddo
!
! Ecriture des OL a desymetriser
!
      yw1=.false.
      if(yw1)print*,'orbitales locales lues (INPORB), a desymetriser'
      if(yw1)call scriptol(ol0,noa,noa,noa,noa,orbi
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
!
! Lecture de la matrice de recouvrement entre OA
!
      allocate(s(noa,noa))
      open(14,file=mono1,status='old',form='unformatted')

      s=0.d0
!   Au lieu d'appeler lis on ecrit la partie qui aurait du y etre faite
!     call lis(14,s,'SYM  ',noa)
!     subroutine lis(ifil0,s,symtot,norb)
!
! Recouvrement ou Hmono ?
!
!     ifil>0  =>  on lit la mat de recouvrement
         mat1='OVERLAP'
      if(yw)print*,'mat1',mat1
!
!     lecture de la matrice de recouvrement ou de la matrice Hmono
!
! if(symtot=='SYM') then
       rewind 14
! le read plante
       read(14) aa
       ii=0
       do while (ii==0)
          read(14) aa
          read(14)
          read(14)
          if(yw)print*,'aa',aa
          if(yw)print*,'bb',trim(mat1)//' MATRIX (SYM)'
          ii=index(aa,trim(mat1)//' MATRIX (SYM)')
       enddo
       backspace (14)
       backspace (14)
       read(14) nn,nsym,isym(1:nsym)
       if(yw)print*,'nn,nsym',nn,nsym
       allocate (ajk(nn))
       read(14) ajk
       ij=0
       do is=1,nsym
          do i=1,isym(is)
             i1=i+sum(isym(1:is-1))
             do j=1,i
                j1=j+sum(isym(1:is-1))
                ij=ij+1
                s(i1,j1)=ajk(ij)
                s(j1,i1)=ajk(ij)
             enddo
          enddo
       enddo
       deallocate (ajk)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      print*,'Lecture de la file 14 : LiS'
      if(yw)print*,'matrice de recouvrement entre OA'
      if(yw)call mscript(s)
      close(14)
c--------------------------------------------------
c     Une derniere orthogonalisation par projection
c--------------------------------------------------
      do is=1,nsym
         prodmax=0.d0
         anormax=0.d0
         ideb=isymt(is)+1
         ifin=isymt(is+1)
         do i=ideb,ifin
            do j=ideb,i-1
               prod=dot_product(
     *         ol0(ideb:ifin,i),matmul(s(ideb:ifin,ideb:ifin)
     *         ,ol0(ideb:ifin,j)))
               ol0(ideb:ifin,i)=ol0(ideb:ifin,i)-prod*ol0(ideb:ifin,j)
               prodmax=max(prodmax,abs(prod))
            enddo
            anorm=dot_product(ol0(ideb:ifin,i),
     *      matmul(s(ideb:ifin,ideb:ifin)
     *      ,ol0(ideb:ifin,i)))
            anormax=max(abs(anorm-1.d0),anormax)
            anorm=sqrt(anorm)
            ol0(ideb:ifin,i)=ol0(ideb:ifin,i)/anorm
         enddo
         print'(a,i2,a,D20.12)','OL lues (INPORB) : sym',is,
     *   ' ,(norme-1) maxi',anormax
         print'(a,i2,a,D20.12)','OL lues (INPORB) : sym',is,
     *   ' ,prod scal maxi',prodmax
      enddo
      print*,' '
      print*,'To improve orthonormality, the LO''s are now'//
     *' Reorthonormalised by projection'
      print*,' '
!     do is=1,nsym
!        ideb=isymt(is)+1
!        ifin=isymt(is+1)
!        p(ideb:ifin,ideb:ifin)=
!    *   matmul(transpose(ol0(ideb:ifin,ideb:ifin)),matmul(
!    *   s(ideb:ifin,ideb:ifin),ol0(ideb:ifin,ideb:ifin)))
!        do k=ideb,ifin
!           p(k,k)=0.d0
!        enddo
!         if(ifin>=ideb)
!     *   print*,'is',is,'  maxval',maxval(abs(p(ideb:ifin,ideb:ifin))),
!     *   maxloc(abs(p(ideb:ifin,ideb:ifin)))
!      enddo
      
!
! Orthogonalite de l'ancienne matrice d'OL
!
      if(yw) then
         p(:,:)=matmul(transpose(ol0),matmul(s,ol0))
         print*,'verif orthogonalite ol0'
         call mscript(p(:,:))
      endif
      
!
!
! Calcul de sim(1:nsym)
! sim='E',donnees symm de seward, produit des symm
!
!
      call symmsim(symm,sim,nsym)
      print*,' '
      print*,'operations de symetrie'
      print'(8a4)',sim(0:nsym-1)
      print*,' '
      allocate(nts(noa,nsym),isgn(noa,nsym))
!
!-----------------------------------------------------------
! signes dus aux transformations des OA x, y, xy ... sous
! l'effet des operations de symetrie
!-----------------------------------------------------------
!
      do is=1,nsym
         do i=isymt(is)+1,isymt(is+1)
            yx(i)=orbi(i)(5:8)=='2PX '.or.orbi(i)(7:8)=='1+'
     *      .or.orbi(i)(7:8)=='2-'.or.orbi(i)(7:8)=='3+'
     *      .or.orbi(i)(7:8)=='4-'.or.orbi(i)(7:8)=='5+'
     *      .or.orbi(i)(7:8)=='6-'
            yy(i)=orbi(i)(5:8)=='2PY '.or.orbi(i)(8:8)=='-'
            yz(i)=orbi(i)(5:8)=='2PZ '
            if(index('DGI',orbi(i)(6:6))/=0) then
               yz(i)=yz(i).or.orbi(i)(7:7)=='1'
     *         .or.orbi(i)(7:7)=='3'.or.orbi(i)(7:7)=='5'
            else if(index('FH',orbi(i)(6:6))/=0) then
               yz(i)=yz(i).or.orbi(i)(7:7)=='0'
     *         .or.orbi(i)(7:7)=='2'.or.orbi(i)(7:7)=='4'
            endif
         enddo
      enddo
      if(yw) then
         do is=1,nsym
            print*,' '
            do i=isymt(is)+1,isymt(is+1)
               print'(a,3l2,8a)','yx,yy,yz   '//orbi(i)//'   ',
     *         yx(i),yy(i),yz(i),'       ',sim(1:nsym-1)
            enddo
         enddo
      endif
!
!---------------------------------------------------------
! Matrice de passage entiere entre OA de sysmetrie et OA desymetrisees
!---------------------------------------------------------
!
      call desymorbOA(nsym,orbi,sim,noa,natom,atom,isymt,coor,
     *yx,yy,yz,ioals)
!
!-----------------------------------------
! matrice de passage
!-----------------------------------------
!
      p=0.d0
      do i=1,noa
         do j=1,noa
            if(ioals(i,j)==0) cycle
            if(ioals(i,j)>0) then
               p(i,j)=1.d0/dsqrt(1.d0*ioals(i,j))
            else
               p(i,j)=-1.d0/dsqrt(-1.d0*ioals(i,j))
            endif
         enddo
      enddo
      if(yw) print*,'Matrice de passage'//
     *' entre OA de sysmetrie et OA desymetrisees'
      if(yw)call mscript(p(:,:))
      open(14,file='bid14',form='unformatted',status='unknown')
      write(14) p
      allocate(ol(noa,noa))
      ol(:,:)=matmul(transpose(p(:,:)),ol0(:,:))
      if(nprint>1)print*,'OL desymetrisees, avec signes'
      if(nprint>1)call scriptol(ol(:,:),noa,noa,noa,noa,orbi
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
!
!------------------------------------------------------
! Matrice de recouvrement entre OA desymetrisees
!------------------------------------------------------
!
      s(:,:)=matmul(transpose(p(:,:)),matmul(s(:,:),p(:,:)))
      ! normalisation
!      do k=1,noa
!         fac=dsqrt(1.d0/s(k,k))
!         s(:,k)=s(:,k)*fac
!         s(k,:)=s(k,:)*fac
!      enddo
      if(yw)print*,'Matrice de recouvrement entre OA desymetrisees'
      if(yw)call mscript(s)
      write(14) s
!
!------------------------------------------------------
! Orthogonalite de la nouvelle matrice d'OM
!------------------------------------------------------
!
      work=matmul(transpose(ol(:,:)),matmul(s(:,:),ol(:,:)))
!      if(yw) then
      if(yw)print*,'verif orthogonalite ol'
      if(yw)call mscript(work)
!      do k=1,noa
!         print'(a,i7,F12.8)','norme**2',k,work(k,k)
!      enddo
!      endif
      ssmaxij=0.d0
      ssmaxii=0.d0
      print*,'verif orthogonalite orbitales desymorb '
      do i=1,noa
         do j=1,i-1
            ssmaxij=max(ssmaxij,abs(work(i,j)))
         enddo
         ssmaxii=max(ssmaxii,abs(work(i,i)-1.d0))
      enddo
      b=1.d-15
      if(ssmaxij>b.or.yw1) print*,'defaut d''orthogonalite max',ssmaxij
      if(ssmaxii>b.or.yw1) print*,'defaut de normalisation max',ssmaxii
      
!
! Multiplicite des atomes
!
      call multipat(coor,symm,natom,multat)
!
! rearrangement des OA atome par atome
!
      n=0
      nt=0
      print*,'natom',natom
      do iat=1,natom
!         do iat1=1,iat-1
!            if(atom(iat)==atom(iat1)) goto 1
!         enddo
         do k=1,noa
            if(orbi(k)(1:4)==atom(iat)) then
               nt=nt+1
               iord(nt)=k
            endif
         enddo
! 1       continue
      enddo
      ol(:,:)=ol(iord(:),:)
      p(:,:)=p(iord(:),iord(:))
      s(:,:)=s(iord(:),iord(:))
      orbi=orbi(iord)
      if(yw)print*,'OL desymetrisees apres rearrangement des OA'
      if(yw)call scriptol(ol,noa,noa,noa,noa,orbi
     *,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
!
! longueur de la base de chaque atome
!
      allocate(lb(natom))
      do iat=1,natom
         lb(iat)=0
         do k=1,noa
            if(orbi(k)(1:4)==atom(iat)) then
               lb(iat)=lb(iat)+1
            else
               if(lb(iat)/=0) exit
            endif
         enddo
         lb(iat)=lb(iat)/multat(iat)
      enddo
      print*,'************************************'
      print*,'  Longueur de la base des atomes'
      print*,'atome       longueur    multiplicite'
      do iat=1,natom
         print'(1x,a4,2i12)',atom(iat),lb(iat),multat(iat)
      enddo
      print*,'************************************'
      
!
! rearrangement des OA pour chaque atome
!
      incr=0
      y=.false.
      do iat=1,natom
!         do iat1=1,iat-1
!            if(atom(iat)==atom(iat1)) goto 2
!         enddo
         if(yw)print*,'multat(iat)*lb(iat)',multat(iat),lb(iat)
         nnt=1
         do i=incr+1,incr+multat(iat)*lb(iat)
            if(yw)print*,'Zone de permutation',
     *      incr+1,incr+multat(iat)*lb(iat)
            if(yw)print*, 'atomes concernes  ',orbi(i)(1:4)
            if(yw) then
               print*,'OA de la zone :'
               do k=incr+1,incr+multat(iat)*lb(iat)
                  print*,k,'    ',orbi(k)
               enddo
            endif
            if(y(i)) cycle
            y(incr+nnt(0))=.true.
            iord(incr+nnt(0))=i
            if(yw) print*,'L''OA',i,' (',orbi(i),') est'
     *      //' transferee en',incr+nnt(0)
            nnt(0)=nnt(0)+1
            nbeq=0
            do j=incr+1,incr+multat(iat)*lb(iat)
               if(orbi(i)==orbi(j)) nbeq=nbeq+1
            enddo
            nbeq=nbeq/multat(iat)
            if(yw)print*,'nb d''atomes equivalents ds la zone',nbeq
            mbeq=1
            do j=incr+1,incr+multat(iat)*lb(iat)
               if(j==i) cycle
               if(orbi(i)==orbi(j)) then
                  mbeq=mbeq+1
                  mbeq1=(mbeq-1)/nbeq
                  !if(yw)print*,orbi(i),orbi(j),mbeq,mbeq1
                  iord(incr+mbeq1*lb(iat)+nnt(mbeq1))=j
                  if(yw) print*,'l''OA',j,' (',orbi(j),') est'
     *            //' transferee en',incr+mbeq1*lb(iat)+nnt(mbeq1)
                  !if(yw)print*,'ORBI3'
!     *            ,incr+mbeq1*lb(iat)+nnt(mbeq1),'  ',orbi(j)
!                  if(yw)print*,'ORBI3',incr,mbeq1,lb(iat),nnt(mbeq1)
                  y(j)=.true.
                  nnt(mbeq1)=nnt(mbeq1)+1
               endif
            enddo
         enddo
         incr=incr+multat(iat)*lb(iat)
! 2       continue
      enddo
      if(yw)print*,'iord',iord
      ol(:,:)=ol(iord(:),:)
      p(:,:)=p(iord(:),iord(:))
      s(:,:)=s(iord(:),iord(:))
      orbi=orbi(iord)
      if(yw) then
         do k=1,noa
            print*,k,orbi(k)
         enddo
      endif
      
      
      
!
! Ecritures
!
      if(yw1.or.stop=='DESYMORB') then
         print*,' '
         print*,'Orbitales desymorb  (ordonnees par symetrie)'
         call scriptol(ol,noa,noa,noa,noa,orbi
     *   ,(/(k,k=1,noa)/),tipo(:)(1:12),occup)
      endif
      open(4,form='unformatted',status='unknown',file='bid4')
      write(4) ol(:,:)
      write(4) occup
      write(4) tipo
      isym(1)=noa
      call ecriorb('* Orbitales desymorb','DESYMORB',1,isym,4,8)
      close(4,status='delete')
      close(8)
      if(yw)print*,'DESYMORB2'
      open(4,form='unformatted',status='unknown',file='DESYMORB2')
      write(4) ol(:,:)
      write(4) orbi
C!
C! Lecture de la matrice de recouvrement entre OA
C!
C      open(14,file=mono1,status='old',form='unformatted')
C      s=0.d0
C      call lis(14,s,'SYM  ',noa)
C      if(yw)print*,'matrice de recouvrement entre OA'
C      if(yw)call mscript(s)
C!
C! Orthogonalite de l'ancienne matrice d'OM
C!
C      p=matmul(transpose(ol0),matmul(s,ol0))
C      if(yw)print*,'verif orthogonalite ol0'
C      if(yw)call mscript(p)
      
!
! passage de l'ordre en symetrie a l'ordre sans symetrie
!
! matrice de passage entre avant et apres disymetrisation
! ol0 : avant (par blocs) ; ol : apres
! P=mat de passage : ol0=P*ol => P=ol0*ol**(-1) => P**(-1)=ol*ol0**(-1)
! or ol0(t)*S*ol0=I => ol0(t)*S=ol0**(-1) =>
! P**(-1)=ol*ol0(t)*S or P**(-1)=P(t)  d'ou P
!
C      p=transpose(matmul(ol,matmul(transpose(ol0),s)))
C      ! normalisation
C      do k=1,noa
C         anorm=sum(p(:,k)*p(:,k))
C         p(:,k)=p(:,k)/dsqrt(anorm)
C      enddo
C      if(yw)print*,
C     *'matrice de passage entre avant et apres disymetrisation'
C      !if(yw)call mscript(p)
C      if(yw)call scriptol(p,noa,noa,noa,noa,orbi
C     *,(/(k,k=1,noa)/),orbi(:)//'    ',(/(0.d0,k=1,noa)/))
C      rewind 14
C      read(14) p
      write(4) p(:,:)
C!
! Matrice de recouvrement entre OA desymetrisees
C!
C      s=matmul(transpose(p),matmul(s,p))
C      ! normalisation
C      do k=1,noa
C         fac=dsqrt(1.d0/s(k,k))
C         s(:,k)=s(:,k)*fac
C         s(k,:)=s(k,:)*fac
C      enddo
      if(yw)print*,'Matrice de recouvrement entre OA desymetrisees'
C      read(14) s
      close(14,status='delete')
      if(yw)call mscript(s)
      write(4) s(:,:)
      write(4) occup
      write(4) tipo
      write(4) sim
      write(4) multat
      close(4)
!
! Orthogonalite de la nouvelle matrice d'OM
!
      work(:,:)=matmul(transpose(ol(:,:)),matmul(s(:,:),ol(:,:)))
!      if(yw) then
      if(yw)print*,'verif orthogonalite ol'
      if(yw)call mscript(work(:,:))
!      do k=1,noa
!         print'(a,i7,F12.8)','norme**2',k,work(k,k)
!      enddo
!      endif
      ssmaxij=0.d0
      ssmaxii=0.d0
      print*,'verif orthogonalite orbitales desymorb '
      do i=1,noa
         do j=1,i-1
            ssmaxij=max(ssmaxij,abs(work(i,j)))
         enddo
         ssmaxii=max(ssmaxii,abs(work(i,i)-1.d0))
      enddo
      b=1.d-15
      if(ssmaxij>b.or.yw1) print*,'defaut d''orthogonalite max',ssmaxij
      if(ssmaxii>b.or.yw1) print*,'defaut de normalisation max',ssmaxii
      close(2)
      close(4)
      close(14)
      deallocate(ol0,tipo,occup,orbi,orbi2,coor,multat,nts,isgn,y,
     *ol,s,p,work,work1)
      print*,'verif d''orthogonalite terminee'
      print*,'====================================================='
      print*,' Fin desymorb Fin desymorb Fin desymorb Fin desymorb'
      print*,'====================================================='
      print*,' '
      call maj(stop,80)
      if(stop=='DESYMORB') stop
      end
      
C       subroutine prod_sym(sim1,sim2,sim3)
C      character(3) sim1,sim2,sim3
C      character(6) c
C      logical yw
C      yw=.false.
C      c=trim(sim1)//trim(sim2)
C      nx=0
C      ny=0
C      nz=0
C      n=0
C      l=len_trim(c)
C      do k=1,l
C         if(index(c(k:k),'X')/=0) nx=nx+1
C         if(index(c(k:k),'Y')/=0) ny=ny+1
C         if(index(c(k:k),'Z')/=0) nz=nz+1
C      enddo
C      sim3=' '
C      if(nx==1) then
C         n=n+1
C         sim3(n:n)='X'
C      endif
C      if(ny==1) then
C         n=n+1
C         sim3(n:n)='Y'
C      endif
C      if(nz==1) then
C         n=n+1
C         sim3(n:n)='Z'
C      endif
C      if(yw)print'(a,8a4)','sim1,sim2,sim3 ',sim1,sim2,sim3
C      return
C      end
       subroutine quelleop(iop,coordloc,nsym,sim)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension coordloc(3)
      character(3) sim(0:7)
      yw=.false.
      ! on cherche une operation de symetrie (rot, s/plan...)
      ! qui modifie ! coordloc
      do ks=2,nsym
         kk=index(sim(ks-1),'X')
         if(yw)print*,'kkx',kk
         if(kk==0) cycle
         ! Alors on change x en -x dans l'operation
         if(abs(coordloc(1))>1.d-8) then
            !la coordonnee etait non nulle, l'atome est vraiment nouveau
            iop=ks-1
            return
         endif
      enddo
      do ks=2,nsym
         kk=index(sim(ks-1),'Y')
         if(yw)print*,'kky',kk
         if(kk==0) cycle
         ! Alors on change y en -y dans l'operation
         if(abs(coordloc(2))>1.d-8) then
            !la coordonnee etait non nulle, l'atome est vraiment nouveau
            iop=ks-1
            return
         endif
      enddo
      do ks=2,nsym
         kk=index(sim(ks-1),'Z')
         if(yw)print*,'kkz',kk
         if(kk==0) cycle
         ! Alors on change z en -z dans l'operation
         if(abs(coordloc(3))>1.d-8) then
            !la coordonnee etait non nulle, l'atome est vraiment nouveau
            iop=ks-1
            return
         endif
      enddo
      iop=0
      return
      end
       subroutine numsim(n,sim,simtmp)
      character(3) sim(0:7),simtmp
      do k=1,7
         if(sim(k)/=simtmp) cycle
         n=k
      enddo
      end
C       subroutine symmsim(symm,sim,nsym)
C      character(20) symm
C      character(3) sim(0:7)
C      symm=adjustl(symm)
C      long=20
C      call suppdb(symm,long)
C      l=index(symm,' ')
C      sim(0)='E'
C      if(nsym==2) then
C         sim(1)=symm(1:l-1)
C      else if (nsym==4) then
C         sim(1)=symm(1:l-1)
C         sim(2)=symm(l+1:l+4)
C         call prod_sym(sim(1),sim(2),sim(3))
C      else if (nsym==8) then
C         sim(1)=symm(1:l-1)
C         symm(l:l)='&'
C         l1=index(symm,' ')
C         sim(2)=symm(l+1:l1-1)
C         symm(l1:l1)='&'
C         l2=index(symm,' ')
C         sim(4)=symm(l1+1:l2-1)
C         call prod_sym(sim(1),sim(2),sim(3))
C         call prod_sym(sim(1),sim(4),sim(5))
C         call prod_sym(sim(2),sim(4),sim(6))
C         call prod_sym(sim(2),sim(5),sim(7))
C         symm(l:l)=' '
C         symm(l1:l1)=' '
C      endif
C      return
C      end
      
      
