      program MODIF_FERMI
      use mod_lirorb
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Lit un fichier d'orbitales  (fich1)
!     Deplace des orbitales
!     Le reecrit                  (fich2)
!     
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter (maxsym=8,maxorbcas=16)
      character(10000) namel
      double precision, allocatable,dimension(:,:) :: orb1,orb2
      double precision, allocatable,dimension(:) :: occ1,occ2
      character(18),allocatable,dimension(:) :: tipo1,tipo2
      character(16),allocatable,dimension(:) :: O_V,V_O
      logical,allocatable,dimension(:) :: y1,y2
      dimension isym(maxsym)
      integer fermi1(maxsym),fermi2(maxsym)
      character(80) aa,fich1,fich2
      print*,' '
      print*,'*******************************************************'
      print*,'======================================================='
      print*,'                       MODIF_FERMI'
      print*,'======================================================='
      print*,'*******************************************************'
      print*,' '
      !
      ! Lecture des donnees
      open(10,file='SCH_FERMI',status='old')
      open(11,form='unformatted',status='scratch')
      open(12,form='unformatted',status='scratch')
      open(13,form='unformatted',status='scratch')
      call LECNAM('&FERM ',namel,10,ierr,1)
      call nameli(namel,FERMI1,'FERMI',4)
      !
      call LECNAM('&MODIF_FERMI ',namel,5,ierr,1)
      call namela(namel,FICH1,'FICH1')
      call namela(namel,FICH2,'FICH2')
      !
      ! Lecture de la matrice fich1
      call lirorb(FICH1,norb,nsym,isym,1,2,title=aa,ifiloc=4,
     *ifillab=8)
      print*,'fichier FICH1 : ',trim(aa)
      print'(a,8i4)',' isym  ',isym(1:nsym)
      !
      ! Lecture des labels des orbitales a deplacer
      allocate(o_v(norb))
      allocate(v_o(norb))
      allocate(y1(norb))
      allocate(y2(norb))
      o_v=' '
      v_o=' '
      call namela(namel,O_V,'O_V')
      call namela(namel,V_O,'V_O')
      call maj(o_v,len_trim(o_v))
      call maj(v_o,len_trim(v_o))
      open(9,status='scratch',form='unformatted')
      rewind 1
      rewind 3
      !
      ! Calcul preliminaire du deplacement du niveau de Fermi
      !
      fermi2=fermi1
      do k=1,norb
         if(o_v(k)==' ') exit
         ll=index(o_v(k),';')+1
         read(o_v(k)(ll:ll),'(i1)') is
         fermi2(is)=fermi2(is)-1
      enddo
      do k=1,norb
         if(v_o(k)==' ') exit
         ll=index(v_o(k),';')+1
         read(v_o(k)(ll:ll),'(i1)') is
         fermi2(is)=fermi2(is)+1
      enddo
      print*,' '
      print*,'----------------------'
      print'(a,8i4)',' Ancien  Fermi',fermi1(1:nsym)
      print'(a,8i4)',' Nouveau Fermi',fermi2(1:nsym)
      print*,'----------------------'
      print*,' '
      !
      ! Boucle sur les symetries
      do is=1,nsym
         ndims=isym(is)
         !
         ! Allocations
         allocate(orb1(ndims,ndims))
         allocate(orb2(ndims,ndims))
         allocate(occ1(ndims))
         allocate(occ2(ndims))
         allocate(tipo1(ndims))
         allocate(tipo2(ndims))
         read(1) orb1
         read(4) occ1
         read(8) tipo1
         y1=.false.
         y2=.true.
         no=1
         na=fermi2(is)
         print*,'------------------------------------------'
         print*,' Symetrie',is
         do k=1,norb
            if(v_o(k)==' ') exit
            ii=index(v_o(k),';')
            read(v_o(k)(ii+1:ii+1),'(i1)') is1
            if(is.ne.is1) cycle
            ii=ii+2
            ll=len_trim(v_o(k))
            read(v_o(k)(ii+1:ll),*) n1
            yy=.true.
            n2=0
            print'(2a)','On cherche l''orbitale ',v_o(k)
            print*,'v_o(k)',v_o(k)(1:ii-3)
            print*,' '

            do l=fermi1(is)+1,ndims
               !print*,'tipo',l,trim(tipo1(l))
               if(trim(tipo1(l))==v_o(k)(1:ii-3)) then
                  n2=n2+1
                  if(n2.ne.n1) cycle
                  yy=.false.
                  y1(l)=.true.
                  print'(a,i5)',
     *            'l''orbitale a ete trouvee a la position',l
                  if(v_o(k)(1:1)=='A') then
                     orb2(:,na)=orb1(:,l)
                     occ2(na)=occ1(l)
                     tipo2(na)=tipo1(l)
                     print'(a,i5)',
     *               'elle est transferee en ',na
                     print'(a,i4,a,i4)',' '//
     *               trim(tipo1(l))//' : Virt-->Occ  ',l,' -->',na
                     
                     y2(na)=.false.
                     na=na-1
                  else
                     orb2(:,no)=orb1(:,l)
                     print'(a,i5)',
     *               'elle est transferee en ',no
                     y2(no)=.false.
                     print'(a,i4,a,i4)',' '//
     *               trim(tipo1(l))//' : Virt-->Occ  ',l,' -->',no
                     no=no+1
                  endif
               endif
            enddo
            if(yy) then
               print*,'v_o=',v_o(k),' n''a pas ete trouve'
               stop
            endif
         enddo
         no=ndims
         na=fermi2(is)+1
         do k=1,norb
            if(o_v(k)==' ') exit
            ii=index(o_v(k),';')
            read(o_v(k)(ii+1:ii+1),'(i1)') is1
            if(is.ne.is1) cycle
            ii=ii+2
            ll=len_trim(o_v(k))
            read(o_v(k)(ii+1:ll),*) n1
            yy=.true.
            n2=0
c            print'(2a)','On cherche l''orbitale ',o_v(k)
c            print*,'o_v(k)',o_v(k)(1:ii-3)
            do l=1,fermi1(is)
               !print*,'tipo',l,trim(tipo1(l))
               if(trim(tipo1(l))==o_v(k)(1:ii-3)) then
                  n2=n2+1
                       !print*,'trouve',n2,n1,l
                  if(n2.ne.n1) cycle
                  yy=.false.
                  y1(l)=.true.
c                  print'(a,i5)',
c     *            'l''orbitale a ete trouvee a la position',l
                  if(o_v(k)(1:1)=='A') then
                     orb2(:,na)=orb1(:,l)
                     occ2(na)=occ1(l)
                     tipo2(na)=tipo1(l)
c                     print'(a,i5)',
c     *               'elle est transferee en ',na
                     y2(na)=.false.
                     print'(a,i4,a,i4)',' '//
     *               trim(tipo1(l))//' : Occ-->Virt  ',l,' -->',na
                     na=na-1
                  else
                     orb2(:,no)=orb1(:,l)
c                     print'(a,i5)',
c     *               'elle est transferee en ',no
                     y2(no)=.false.
                     print'(a,i4,a,i4)',' '//
     *               trim(tipo1(l))//' : Occ-->Virt  ',l,' -->',no
                     na=na+1
                     no=no-1
                  endif
               endif
            enddo
            if(yy) then
               print*,'o_v=',o_v(k),' n''a pas ete trouve'
               stop
            endif
            !
            ! On recopie les autres orbitales
            !
         enddo
         print*,'------------------------------------------'
         kk2=1
         !print*,'y1',y1
         !print*,'y2',y2
         do k=1,ndims
            if(y1(k)) cycle
            do while(.not.y2(kk2))
               kk2=kk2+1
            enddo
            !print*,k,'-->',kk2
            orb2(:,kk2)=orb1(:,k)
            occ2(kk2)=occ1(k)
            tipo2(kk2)=tipo1(k)
            kk2=kk2+1
         enddo
         !do k=1,ndims
         !   print*,tipo1(k),tipo2(k)
         !enddo
         write(11) orb2
         write(12) occ2
         write(13) tipo2
         deallocate(orb1)
         deallocate(orb2)
         deallocate(occ1)
         deallocate(occ2)
         deallocate(tipo1)
         deallocate(tipo2)
      enddo
      call ecriorb('* Orbitales modif_fermi',
     *fich2,nsym,isym,11,14,ifiloc=12,ifillab=13)
      !
      ! Remplacement du fichier SCH_FERMI
      !
      print*,'ecriture SCH_FERMI'
      rewind 10
      write(10,'(a,8(i4,","))')' &ferm fermi=',fermi2(1:nsym)
      write(10,'(a)') ' / '
      write(10,'(a)') ' (modif_fermi)'
      end
