      subroutine orb
      use module
      use mod_lirorb
      use mod_script
      use moddi
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !Transformation des orbitales
      ! On va distinguer :
      ! - les orbitales locales en symetrie, ecrites sym par sym, qui
      ! sont sur le fichier LOCORB, file 4. Ce sont les OLSS
      ! - Les Orbitales Locales en Symetrie (OLS). Ce sont les memes,
      ! mais ecrites dans une matrice carree, sans symetrie. On dit
      ! qu'on obtient les OLS a partir des OLSS par disymetrisation.
      ! C'est le programme desymorb qui fait ca.
      ! - Les Orb Locales (OL) sont les orbitales de sortie, donnees
      ! a LOCCI
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension iextr(8)
      double precision,allocatable,dimension(:,:) :: oo,oos,ss,s1,s2
      double precision,allocatable,dimension(:,:) :: ootmp
      integer,allocatable,dimension(:) :: jrot
      logical(1),allocatable,dimension(:) :: y,yyyyy
      character(18),allocatable :: tipo_tmp(:)
      character(20),allocatable :: tipo_int1(:)
      real(8),allocatable :: occup_tmp(:)
      character(18),allocatable :: tipo_gel(:)
      real(8),allocatable :: occup_gel(:)
      double precision,allocatable,dimension(:,:) :: oo_gel
      character(18),allocatable :: tipo_del(:)
      real(8),allocatable :: occup_del(:)
      double precision,allocatable,dimension(:,:) :: oo_del
      dimension nu(8)
      allocatable lb(:)
      dimension yx(3),yy3(3),yz(3)
      dimension yyx(8),yyy(8),yyz(8)
      yw=.false.
! ecrire les int mono dans la base des OL dans l'output
      yintmono=.false.
      allocate (tipotmp(noa))
      allocate (tipo_int1(noa))
      tipo_int1=' '
      allocate(iphas(noa))
      allocate (yyyyy(noa))
      allocate (ootmp(noa,noa),y(norb))
      allocate (occupng(noa))
      allocate(multat(natom0),lb(natom0))
      if(yw) print*,'orbi     ',orbi
      iphas=1
!
! lecture des orbitales desymetrisees de desymorb
! (ce sont les orbitales locales symetriques (OLS))
! + lecture des labels des OA
!
      open(99,form='unformatted',status='old',file='DESYMORB2')
      read(99) ootmp
      read(99) orbi
      read(99)
      read(99)
      read(99) occupng
      read(99) tipotmp
      close(99)
!
! On met a l'abri les orbitales gelees
!
      nn=ngel+ndel+1
      allocate(tipo_gel(nn),occup_gel(nn),oo_gel(noa,nn))
      kk=0
      k1=0
      !print*,'tipotmp',tipotmp
      do is=1,nsym
         do k=1,frozen(is)
            k1=k1+1
            kk=kk+1
            tipo_gel(k1)=tipotmp(kk)
            occup_gel(k1)=occupng(kk)
            oo_gel(:,k1)=ootmp(:,kk)
         enddo
         !print*,'kk1',kk
         kk=kk+isym(is)+delete(is)
         !print*,'kk2',kk
      enddo
      kk=0
      do is=1,nsym
         kk=kk+frozen(is)+isym(is)
         do k=1,delete(is)
            kk=kk+1
            k1=k1+1
            tipo_gel(k1)=tipotmp(kk)
            occup_gel(k1)=occupng(kk)
            oo_gel(:,k1)=ootmp(:,kk)
         enddo
      enddo
!
! On supprime les orbitales gelees
!
      kk=0
      do k=1,noa
         if(tipotmp(k)(1:1)=='G') cycle
         kk=kk+1
         tipotmp(kk)=tipotmp(k)
         occupng(kk)=occupng(k)
         ootmp(:,kk)=ootmp(:,k)
      enddo
      if(ychol) then
         open(88,file='DESYM_LOCCI_ORB',form='unformatted',
     *   status='unknown')
         write(88) ootmp
      endif
!
! On reordonne occup,tipo et orb en OV
! C'est l'ordre des indices des integrales
!
      allocate (oo_int(noa,norb))
      allocate (occup_int(norb))
      kk2=0
      kk1=0
      do is=1,nsym
         if(is>1)kk1=sum(isym(1:is-1))
         do k=1,fermi(is)
            kk1=kk1+1
            if(tipotmp(kk1)(1:1)=='G') cycle
            kk2=kk2+1
            oo_int(:,kk2)=ootmp(:,kk1)
            tipo_int1(kk2)(1:18)=tipotmp(kk1)
            occup_int(kk2)=occupng(kk1)
         enddo
         kk1=kk1+isym(is)-fermi(is)
      enddo
      kk1=fermi(1)
      do is=1,nsym
         if(is>1)kk1=sum(isym(1:is-1))+fermi(is)
         do k=1+fermi(is),isym(is)
            kk1=kk1+1
            if(tipotmp(kk1)(1:1)=='G') cycle
            kk2=kk2+1
            oo_int(:,kk2)=ootmp(:,kk1)
            tipo_int1(kk2)(1:18)=tipotmp(kk1)
            occup_int(kk2)=occupng(kk1)
         enddo
         kk1=kk1+isym(is)-fermi(is)
      enddo
      if(yw.or.nprint>=1) then
         print*,'orbitales desymetrisees '//
     *   'dans l''ordre des indices des integrales'
         call scriptol(oo_int
     *   ,noa,norb,noa,norb,orbi,(/(k,k=1,noa)/),tipo_int1(:)(1:18)
     *   ,occup_int)
      endif
!
! on rajoute en position 19 et 20 de la chaine tipo le
! numero de l'apparition de la chaine (pour les liaisons
! differentes de meme nom)
!
      call ldmn(nsym,fermi,tipo_int1,norb)
      call ldmn(nsym,virt,tipo_int1(noc+1),norb)
      if(yw) then
         print*,'noc',noc
         print*,'virt',virt
         print*,' '
         print*,'tipo  apres ldmn'
         print*,'norb',norb
         do k=1,norb
            print*,'tipo_int1',k,tipo_int1(k)(1:20)
         enddo
      endif
!
! On reordonne les orbitales en OAV, par classes d'orbitales
!
      deallocate(tipotmp,ootmp,occupng)
      allocate (tipo_l(norb))
      allocate (oo_l(noa,norb))
      allocate (occup_l(norb))
      kk=0
      y=.false.
      tipo_l=' '
! occupees non actives
      ifin=sum(fermi)
      do k=1,ifin
         if(tipo_int1(k)(1:1)=='A') cycle
         if(y(k)) cycle
         call reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *   tipo_int1,occup_int,oo_int,k,fermi,noa,norb,ifin)
      enddo
! occupees actives
      noaco=0
      do k=1,ifin
         if(tipo_int1(k)(1:1)/='A') cycle
         noaco=noaco+1
         numac(noaco)=k
         if(y(k)) cycle
         call reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *   tipo_int1,occup_int,oo_int,k,fermi,noa,norb,ifin)
      enddo
! virtuelles actives
      noacv=0
      ifin=norb
      do k=1+sum(fermi),norb
         if(tipo_int1(k)(1:1)/='A') cycle
         noacv=noacv+1
         numac(noaco+noacv)=k
         if(y(k)) cycle
         call reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *   tipo_int1,occup_int,oo_int,k,fermi,noa,norb,ifin)
      enddo
! virtuelles non actives
      do k=1+sum(fermi),norb
         if(tipo_int1(k)(1:1)=='A') cycle
         if(y(k)) cycle
         call reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *   tipo_int1,occup_int,oo_int,k,fermi,noa,norb,ifin)
      enddo
      noac=noaco+noacv
      ninac=noc-noaco
      nvirt=norb-ninac
      if(yw.or.nprint>=2) print*,'orb non actives traitees'
      if(yw.or.nprint>=2)call scriptol(oo_l
     *,noa,norb,noa,norb,orbi,(/(k,k=1,noa)/),tipo_l
     *,occup_l)
! actives
      allocate(tipo_tmp(norb))
      allocate(occup_tmp(norb))
      y=.false.
      ideb=sum(fermi)-noaco+1
      ifin=sum(fermi)+noacv
      kk=ideb-1
      tipo_tmp(ideb:ifin)=tipo_l(ideb:ifin)
      occup_tmp(ideb:ifin)=occup_l(ideb:ifin)
      allocate(oos(noa,norb))
      oos(:,ideb:ifin)=oo_l(:,ideb:ifin)
      do k=ideb,ifin
         if(y(k)) cycle
         call reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *   tipo_tmp,occup_tmp,oos,k,fermi,noa,norb,ifin)
      enddo
      deallocate(oos,tipo_tmp,occup_tmp)
      if(yw.or.nprint>=2) print*,'orb actives traitees'
      if(yw.or.nprint>=2)call scriptol(oo_l
     *,noa,norb,noa,norb,orbi,(/(k,k=1,noa)/),tipo_l
     *,occup_l)
!
! Debut du traitement des symetries, atomes multiples...
!
      call locsym0(lb,yx,yy3,yz,yyx,yyy,yyz)
!
! on repere les atomes qui apparaissent pour la 1ere fois
!
      yyyyy=.true.
      i=0
      do iat=1,natom0
         do k=1,lb(iat)
            i=i+1
            yyyyy(i)=.true.
         enddo
         do m=2,multat(iat)
            do k=1,lb(iat)
               i=i+1
               yyyyy(i)=.false.
            enddo
         enddo
      enddo
!
! Relocalisation (obtention des OL)
! 1. on recherche les orbitales de la meme classe, qu'il faudra
!    recombiner
! 2. Phasorb modifie eventuellement la phase des orbitales (v. dans
!    phasorb)
! 3. recombinaison
      
!
      ideb=1
      if(yw) then
         do k=1,norb
            print*,'tipo_l',k,tipo_l(k)
         enddo
      endif
      ifin=ninac+noac
      y=.false.
      ! icas=1,2 pour occ puis virt
      do icas=1,2
         do k=ideb,ifin
            if(y(k)) cycle
            nn=1
            nu(nn)=k
            y(k)=.true.
            do l=k+1,ifin
               if(y(l)) cycle
               if(tipo_l(k)==tipo_l(l)) then
                  nn=nn+1
!                  if(nn>nsym) then
!                     print*,' '
!                     print*,'*****************************************'
!                     print*,'Attention, orbitale locale',tipo_l(k)
!                     print*,nn,' orbitales equivalentes'
!                     print*,nsym,' symetries'
!                     print*,'il y a plus d''orbitales que de symetries'
!                     if(tipo_l(k)(1:1)=='A') then
!                        print*,'OK pour actives'
!                     else
!                        print*,'nn,nsym',nn,nsym,tipo_l(k),k,l
!                        stop
!                     endif
!                     print*,'*****************************************'
!                  endif
                  nu(nn)=l
                  y(l)=.true.
               else
                  exit
               endif
            enddo
            if(yw) print'(a,8i4)',
     *      '   : OL equivalentes : '//tipo_l(k),nu(1:nn)
            ifaca=1
!            if(tipo_l(k)(1:1)=='A') ifaca=2
            if(nn>nsym*ifaca.or.(nn/=1.and.nn/=2.and.nn/=4.and.nn/=8))
     *      then
               print*,'************************************************'
               print'(a,8i4)',
     *         '   : OL equivalentes : '//tipo_l(k),nu(1:nn)
               print*,' Le nombre d''orbitales equivalentes doit :'
               print*,' - etre inferieur ou egal au nombre de symetries'
               print*,' - avoir les valeurs 1,2,4 ou 8'
               print*,'nsym=',nsym,'   nb orb equiv=',nn
               print*,'************************************************'
               stop
            endif
            call phasorb(oo_l,nu,nn,yyyyy)
            oo_l(:,nu(1:nn))=matmul(oo_l(:,nu(1:nn)),1.d0*
     *      dsym(1:nn,1:nn))/dsqrt(nn*1.d0)
         enddo
         ideb=ninac+noac+1
         ifin=norb
      enddo
!
! On moyenne les occupations sur les orb equivalentes par symetrie
!
      if(ninac.ne.0)
     *call moyocc(ninac,occup_l(1),tipo_l(1))
      if(noac.ne.0)
     *call moyocc(noac,occup_l(ninac+1),tipo_l(ninac+1))
      if(nvirt.ne.0)
     *call moyocc(nvirt,occup_l(norb-nvirt+1),tipo_l(norb-nvirt+1))
!
! Ecriture des orbitales locales
!
      call titre('Orbitales localisees, '//
     *'par blocs d''orbitales equivalentes#'//
     *'(ce sont les orbitales pour LOCCI)#',40)
      if(mprint(1)==0) then
         kfin=norb
         do k=1,norb
            if(tipo_l(k)(1:1)=='T') then
               kfin=k-1
               exit
            endif
         enddo
         call scriptol(oo_l
     *   ,noa,kfin,noa,norb,orbi,(/(k,k=1,kfin)/),tipo_l,occup_l)
      else
         call scriptol(oo_l
     *   ,noa,norb,noa,norb,orbi,(/(k,k=1,norb)/),tipo_l,occup_l)
      endif
      if(ychol) then
         write(88) oo_l
         close(88)
      endif
!
! on lit la matrice de recouvrement entre OA desymetrisees
! verif d'orthogonalite des OL
!
      allocate(ss(noa,noa))
      allocate(oos(noa,noa))
      open(99,form='unformatted',status='old',file='DESYMORB2')
      read(99)
      read(99)
      read(99)
      read(99) ss(:,:)
      print*,'orb.f avant ss=matmul'
      print*,'norb=',norb,'  noa=',noa
cNADIA
c 1) Le calcul de work plante 
c Correction 1 (n'est plus utilisee)
c -> decomposer en  3 etapes et remplace matmul
c par un calcul avec un boucle - C=AB c(i,j)=Somme_sur_k(a(i,k)*b(k,j))
!     allocate(s1(noa,noa))
!     allocate(s2(noa,noa))
!     s1(:,:)=transpose(oo_l(:,:))
!     s2(:,:)=matmul(ss(:,:),oo_l(:,:))
!     do i=1,norb
!        do j=1,norb
!           do k=1,norb
!              ss(i,j)=ss(i,j)+s1(i,k)*s2(k,j)
!           enddo
!        enddo
!     enddo
c Correction 2 :
c solution -> compiler avec -heap-arrays

c 2) Pourquoi s est dimensionne a norb mais alloue a noa ? 
! Test en changeant
!     ss(1:noa,1:noa)=matmul(transpose(oo_l),matmul(ss,oo_l))

      ss(1:norb,1:norb)=matmul(transpose(oo_l),matmul(ss,oo_l))
cNADIA
      ssmaxij=0.d0
      ssmaxii=0.d0
      do i=1,norb
         do j=1,i-1
            ssmaxij=max(ssmaxij,abs(ss(i,j)))
         enddo
         ssmaxii=max(ssmaxii,abs(ss(i,i)-1.d0))
      enddo
      print*,'defaut d''orthogonalite max',ssmaxij
      print*,'defaut de normalisation max',ssmaxii
      print*,'verif d''orthogonalite terminee'
      print*,' '
      rewind 99
      read(99) oos
      read(99)
      read(99)
      read(99) ss
      close(99)
      
!
! Equivalences entre OL par les operations de symetrie
!
      allocate (itsyml(norb,nsym-1),princl(norb,nop))
      call locsym(oo_l,lb,yx,yy3,yz,yyx,yyy,yyz)
!
! Ecriture des orbitales (OL) sur un fichier de type ORB
!
      open(25,file='BID_ECRIORB',status='unknown',form='unformatted')
      write(25) oo_gel(:,1:ngel),oo_l,oo_gel(:,1+ngel:ngel+ndel)
      if(yw) print*,'occup_l',occup_l
      write(25) occup_gel(1:ngel),occup_l,occup_gel(1+ngel:ngel+ndel)
C      tipong(:)(13:18)=' '
      write(25) tipo_gel(1:ngel),tipo_l,tipo_gel(1+ngel:ngel+ndel)
      nu(1)=noa
      call ecriorb('* orbitales relocalisees par ijkloc','ORB_IJKLOC',
     *1,nu,25,29)
      close(25)
      close(29)
      call ecrocc_ijkloc
      !deallocate(occupng)
!
! Matrice de passage entre OL_l et OL_int
!
      if(yw) then
         print*,'oo_int'
         call mscript(oo_int)
         print*,'oo_l'
         call mscript(oo_l)
      endif
      oos(1:norb,1:norb)=
     *matmul(transpose(oo_int(:,1:norb)),matmul(ss,oo_l))
      if(yw)print*,'Matrice de passage entre OLS et OL'
      if(yw)call mscript(oos(1:norb,1:norb))
!
! Matrice de passage ecrite en entiers
!
      allocate(ipass(nsym,norb))
      allocate(ipass_sgn(nsym,norb))
      allocate (npass(norb))
      ipass=0
      do k=1,norb
         ll=0
         do l=1,norb
            if(dabs(oos(k,l))>1.d-1) then
               ll=ll+1
               if(ll>nsym.and.tipo_int1(k)(1:1)/='A') then
                  print*,' Matrice de passage ecrite en entiers'
                  print*,' erreur'
                  print*,k,tipo_int1(k)
                  print'(10f8.4)',oos(k,1:norb)
                  stop
               endif
               call flush(6)
               ipass(ll,k)=l
               if(oos(k,l)>0.d0) then
                  ipass_sgn(ll,k)=1
               else
                  ipass_sgn(ll,k)=-1
               endif
            endif
         enddo
         npass(k)=ll
      enddo
      if(yw) then
         print*,'mat de passage entiere'
         do k=1,norb
            print'(a,i5,a,20i4)','OA',k,' =combinaison des OL :',
     *      ipass(1:npass(k),k)*ipass_sgn(1:npass(k),k)
         enddo
      endif
      allocate (tipo_int(norb))
      do k=1,norb
         tipo_int(k)=tipo_int1(k)(1:18)
      enddo
      deallocate(tipo_int1)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Calcul de iord
      ! iord permet de passer de l'ordre "orb par sym" a "orb occ puis
      ! virt"
      ! (iord agit dans l'espace des orb non gelees)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      
      ii=0
      do is=1,nsym
         do k=1,norb
            if(itsym(k)==is) then
               ii=ii+1
               iord(ii)=k
            endif
         enddo
      enddo
      if(yw)print*,'iord',iord
!
! Lecture de Hmono
!
      allocate (hmono(norb,norb))
      deallocate(ss)
      deallocate (oo_l)
      allocate(ss(norb,norb))
      allocate(oo(norb,norb))
      oo=oos(1:norb,1:norb)
      deallocate(oos)
      if(ycl.and..not.ychol) then
         ss=0.d0
         rewind(26)
         do
            read(26,*) i,j,k,l,a
            if(i==0) exit
            if(k==0) then
               ss(i,j)=a
               ss(j,i)=a
            endif
         enddo
         if(yw)print*,'Hmono lu'
         if(yw)call mscript(ss)
      else
         call lis(-2,ss,'SYM  ',norb)
         if(yw)print*,'Hmono lu'
         if(yw)call mscript(ss)
         ss(iord,iord)=ss
      endif
      if(yw)print*,'Hmono lu reordonne ov'
      if(yw)call mscript(ss)
!
! Hmono en local
!
      if (yintmono) yw=.true.
      if(yw)print*,'Hmono en local'
      if(yw)hmono=matmul(transpose(oo),matmul(ss,oo))
      if(yw)call mscript(hmono)
!
! Hmono en local, calcul en 2 temps
!
      oo=0.d0
      do i=1,norb
         do j=1,norb
            do k=1,npass(j)
               oo(i,ipass(k,j))=oo(i,ipass(k,j))+ss(i,j)*ipass_sgn(k,j)
     *         /dsqrt(1.d0*npass(j)*npass(i))
            enddo
         enddo
      enddo
      hmono=0.d0
      do i=1,norb
         do j=1,norb
            do k=1,npass(i)
               hmono(ipass(k,i),j)=hmono(ipass(k,i),j)
     *         +oo(i,j)*ipass_sgn(k,i)
            enddo
         enddo
      enddo
      if(yw)print*,'Hmono en local en 2 temps'
      if(yw)call mscript(hmono)
      return
      stop
      end
       subroutine moyocc(ngel,occupng,tipotmp)
      character(18) tipotmp(ngel)
      double precision occupng(ngel)
      k=1
      n=1
 1    continue
      do l=k+1,ngel
         if(tipotmp(k)==tipotmp(l)) then
            n=n+1
         else
            occupng(k:k+n-1)=sum(occupng(k:k+n-1))/n
            n=1
            k=l
            goto 1
         endif
      enddo
      return
      end
       subroutine phasorb(oo,nu,nn,yyyyy)
      use module
      use mod_script
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !oo contient les nn orbitales equivalentes dont on va prendre nn
      !combinaisons lineaires
      !Ces orbitales sont "locales symetriques, les combinaisons seront
      !purement locales
      ! nn vaut 1,2,4 ou 8
      ! Pour que la recombinaison marche, il faut que les phases des oo
      ! avant transformation soient telles que, sur les LIGNES de oo a
      ! grands coefficients on ait :
      ! - soit tous les signes egaux
      ! - soit autant de "-" que de "+"
      ! Un probleme survient, pour nn=4 ou nn=8, si les phases des oo
      ! avant transformation ne sont pas bonnes
      !
      ! Si nsym==nn (4 ou 8), on va faire le produit scalaire de chaque
      ! OM, en ne considerant que les OA qui apparaissent pour la 1ere
      ! fois (le prosuit scalaire des OM totales serait nul !) Les OA
      ! qui apparaissent pour la 1ere fois sont donnees par yyyyy.
      ! Ce produit scalaire doit etre positif, sinon, on
      ! inverse la phase.
      ! Si nsym===8 et nn=4, il faut aller chercher les symetries qui
      ! contiennent des gros coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension oo(noa,noa),nu(nn),dp(8),m(1),yyyyy(noa)
!      dimension mu(4)
      yw=.false.
      if(nn<2) return
      !
      if(yw)print*,'entree phasorb'
      if(yw)print*,'nu',nu
      if(yw)print*,'nsym,nn',nsym,nn
      if(nu(1)==1) then
         if(yw)print*,'orbitales equivalentes dont on va prendre les '
     *   , 'combinaisons lineaires'
         if(yw)call mscript(oo)
      endif
      !
      ! Examen des phases
      ! Changement eventuel des signes de l'orbitale
      !
      if(yw) then
         print'(a,8i5)','orbitales',nu(1:nn)
         write(75,*)'isymng',isymng,'$'
         call scril
!         write(75,*)'mu',mu,'$'
!         call scril
         do k=1,noa
            if(yyyyy(k)) print'(i4,8f8.4)',k,oo(k,nu(1:nn))
         enddo
      endif
      do is=2,nn
         ! produit scalaire
         dd=0.d0
         do k=1,noa
            if(yyyyy(k)) dd=dd+oo(k,nu(1))*oo(k,nu(is))
         enddo
         if(yw)write(75,*)'prod scalaire entre 1 et',is,'dd=',dd,'$'
         if(yw)call scril
         if(dd<0) then
            oo(:,nu(is))=-oo(:,nu(is))
            iphas(nu(is))=-1
            if(nprint>0) print*,'Changement de phase  orb',nu(is)
         endif
      enddo
!      endif
      if(yw)print*,'sortie phasorb'
      if(yw)call mscript(oo(:,nu))
      return
      end
       subroutine reor(n,it)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      dimension it(n)
      do 1 i=1,n-1
      do 2 j=i+1,n
      if(it(j).ge.it(i)) goto 2
      ii=it(i)
      it(i)=it(j)
      it(j)=ii
 2    continue
 1    continue
      return
      end
       subroutine reor_int_l(y,kk,tipo_l,occup_l,oo_l,
     *tipo_int1,occup_int,oo_int,k,fermi,noa,norb,ifin)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) :: tipo_int1(norb)
      character(18) :: tipo_l(norb)
      real(8) :: occup_l(norb),occup_int(norb)
      real(8) :: oo_l(noa,norb),oo_int(noa,norb)
      dimension  y(norb)
      integer fermi(8)
      y(k)=.true.
      kk=kk+1
      tipo_l(kk)=tipo_int1(k)(1:18)
      occup_l(kk)=occup_int(k)
      oo_l(:,kk)=oo_int(:,k)
      do l=k+1,ifin
         if(tipo_int1(k)==tipo_int1(l)) then
            y(l)=.true.
            kk=kk+1
            tipo_l(kk)=tipo_int1(l)(1:18)
            occup_l(kk)=occup_int(l)
            oo_l(:,kk)=oo_int(:,l)
         endif
      enddo
      return
      end
       subroutine ldmn(nsym,n,tipotmp,noa)
      integer n(8)
      character(*) tipotmp(noa)
      
      !print*,'entree ldmn'
      isf=0
      do is=1,nsym
         isd=isf+1
         isf=isd+n(is)-1
         !print*,'isd,isf',isd,isf
         do k=isd,isf
            do l=isd,k-1
               !print*,'ldmn',k,l,tipotmp(k)(1:12),tipotmp(l)(1:12)
               if(tipotmp(k)(1:12)==tipotmp(l)(1:12)) then
                  !print*,'ajout'
                  tipotmp(k)(19:19)='.'
                  if(len_trim(tipotmp(k))<=20) then
                     tipotmp(k)(20:20)='1'
                  else
                     read(tipotmp(l)(20:20),'(i1)') ii
                     write(tipotmp(k)(20:20),'(i1)') ii+1
                  endif
               endif
            enddo
         enddo
      enddo
      return
      end
