      program COPIE_ORDRE
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Changement de l'ordre des orbitales dans un fichier 
!     en fonction de l'odre d'un autre fichier
!     fich1 : orbitales a copier dans un autre ordre
!     fich2 : orbitales en sortie
!     fich_ref : donne l'ordre des orbitales (on ne lit que les labels)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      character*80 fich_ref,fich1,fich2,aa
      character*1280 namel
c      character(6),dimension(:),allocatable label1,label_ref
      character*18,allocatable :: label1(:),label_ref(:)
      double precision,dimension(:,:),allocatable :: om1,om2
      dimension isym(8)
      allocatable y(:),occup1(:),occup2(:)
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       COPIE_ORDRE'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '
      nprint=0
      call lecnam('&COP',namel,5,ierr,1)
      call nameli(namel,NPRINT,'NPRINT',4)
      call namela(namel,FICH1,'FICH1')
      call namela(namel,FICH2,'FICH2')
      call namela(namel,FICH_REF,'FICH_REF')
      print'(a)',' FICHIER REFERENCE     '
     *//fich_ref(1:len_trim(fich_ref))
      print'(a)',' FICHIER A REORDONNER  '//fich1(1:len_trim(fich1))
      print*,' '
      open(1,file=fich1,status='old')
      if(fich1.ne.fich2) 
     *open(2,file=fich2,status='unknown')
      open(3,file=fich_ref,status='old')
!
!     on cherche le nombre d'orbitales
!
      norb=0
      nl=0
      do 
         read(1,'(a80)') aa 
         if(aa(3:9).eq.'ORBITAL') norb=norb+1
         if(aa(3:8).eq.'LABELS') exit
         nl=nl+1
      enddo
      allocate(label1(norb),label_ref(norb))
      allocate(y(norb),occup1(norb),occup2(norb))
      norb1=0
      do 
         read(3,'(a80)') aa
         if(aa(3:9).eq.'ORBITAL') norb1=norb1+1
         if(aa(3:8).eq.'LABELS') exit
      enddo
      if(norb.ne.norb1) then
         print*, 'nombre d''orbitales dans fich1    :',norb
         print*, 'nombre d''orbitales dans fich_ref :',norb1
         print*,'les deux nombres doivent etre egaux'
         stop
      endif
      print*,'nombre d''orbitales',norb
!
!     nombre de symetries, nombre d'obitales par symetrie
!      
      rewind 1
      do l=1,nl
         read(1,'(a80)') aa
         if(aa(3:9).eq.'ORBITAL') read(aa,'(9x,2i5)') nsym,isym(nsym)
      enddo
      print*,'nombre d''orbitales par symetrie',isym(1:nsym)
      print*,' '
!
!     occupations du fichier d'entree
!
      rewind 1
      do
         read(1,'(a80)') aa
         if(aa(3:12).eq.'OCCUPATION') then
            ifins=0
            do is=1,nsym
               idebs=ifins+1
               ifins=idebs+isym(is)-1
               read(1,'(4d18.12)') occup1(idebs:ifins)
            enddo
            exit
         endif
      enddo
      if(nprint>1) print*,'occup1',occup1(1:norb)
!
!     labels
!
      read(1,'(a80)') aa
      print*,aa
      ifin=0
      do is=1,nsym
         ll=isym(is)/4
         if(mod(isym(is),4).ne.0) ll=ll+1
         do l=1,ll
            ideb=ifin+1
            ifin=min(ideb+3,sum(isym(1:is)))
            read(1,'(4a18))') (label1(lll),lll=ideb,ifin)
         enddo
      enddo
      print*,'label1'
      print'(4a18)',label1(1:norb)
      rewind(3)
      do k=1,nl
         read(3,'(a)') aa
      enddo
      read(3,'(a)')
      lll=0
      ifin=0
      do is=1,nsym
         ll=isym(is)/4
         if(mod(isym(is),4).ne.0) ll=ll+1
         do l=1,ll
            lll=lll+1
            ideb=ifin+1
            ifin=min(ideb+3,sum(isym(1:is)))
            read(3,'(4a18))') label_ref(ideb:ifin)
         enddo
      enddo
      print*,'label_ref'
      print'(4a18)',label_ref(1:norb)
!
!     boucle sur les symetries
!
      ifins=0
      rewind 1
      read(1,'(a)') AA
      write(2,'(a)') trim(aa)
      do is=1,nsym
         idebs=ifins+1
         ifins=idebs+isym(is)-1
         norbs=isym(is)
         y(1:norbs)=.true.
         allocate (om1(norbs,norbs))
         allocate (om2(norbs,norbs))
         do io=1,norbs
            read(1,'(a)')
            read(1,1000) om1(:,io)
         enddo
         if(nprint>0) then
            print*,'orbitales de depart'
            call script(om1,norbs,norbs,norbs,norbs)
         endif
         ilab=idebs-1
         icop=0
         do ioref=1,norbs
            do io1=1,norbs
c               print'(''labels'',l2,2a8)',y(io1),label_ref(ioref+ilab),
c     *         label1(io1+ilab)
               if(y(io1).and.
     *            label_ref(ioref+ilab)(3:12).eq.label1(io1+ilab)(3:12))
     *            then
                  om2(:,ioref)=om1(:,io1)
                  occup2(ioref+ilab)=occup1(ioref+ilab)
                  if(nprint>0) print*,'ioref,io1',ioref,io1
                  y(io1)=.false.
                  icop=icop+1
                  goto 1
               endif
            enddo
            print*,'label non trouve',label_ref(ioref+ilab)
            stop
 1          continue
         enddo
         if(icop.ne.norbs) then
            print*,'les labels des fichiers fich1 et fich_ref ne'
     *      ,' correspondent pas'
            stop
         endif
         if(nprint>0) then
            print*,'orbitales reordonnees'
            call script(om2,norbs,norbs,norbs,norbs)
         endif
         do io=1,norbs
            write(2,'(''* ORBITAL'',2i5)') is,io
            write(2,1000) om2(:,io)
         enddo
         deallocate (om1)
         deallocate (om2)
      enddo
 1000 format(4d18.12)
!
!     on ecrit les occupations
!
      write(2,'(a)')'* OCCUPATION NUMBERS'
      ifins=0
      do is=1,nsym
         idebs=ifins+1
         ifins=idebs+isym(is)-1
         write(2,'(4d18.12)') occup2(idebs:ifins)
      enddo
!
!     on finit fich2 en ecrivant les labels de fich_ref
!
      rewind 3
      do k=1,nl
         read(3,'(a)')
      enddo
      do
         read(3,'(a80)',end=2) aa
         write(2,'(a80)') aa
      enddo
 2    continue
      end
