      subroutine end_rename(n,iwk,flab,fsym,focvir,yes)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(4) focvir(n)
      character(18) flab(n)
      integer fsym(n)
      DIMENSION iwk(n)
      common/pr/nprint
      logical yes
      character(2) suffix
      yw=.false.
!
!----------------------------------------------------------
! Rename LO's which have same name in the same symmetry and
! category (occ, act, virt)
!----------------------------------------------------------
!
      if(yes) print*,'entree end_rename'
      if(yw) then
         nnn=8
         NN=N/nnn
         print*,'n,nn,nnn',n,nn,nnn
         DO KK=1,NN+1
            N1=nnn*(KK-1)+1
            N2=min(nnn*KK,n)
           print*,'n1,n2',n1,n2
            IF(N2.LT.N1) exit
            WRITE(6,*) ' '
            WRITE(6,1024) (iwk(i),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(1:6),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(7:12),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(13:18),I=N1,N2)
            WRITE(6,1029) ('SY ',fsym(i),I=N1,N2)
            WRITE(6,1026) (focvir(i),I=N1,N2)
            WRITE(6,*) ' '
         enddo
1024     FORMAT(14X,10(3X,I5))
1026     FORMAT(14X,10(5X,a3))
1027     FORMAT(14X,10(f8.4))
1028     FORMAT(14X,10(2X,a6))
1029     FORMAT(14X,10(4X,a3,i1))
1030     FORMAT(14X,10(2X,a3,i3))
      endif
      do i=1,n
         k=1
         do j=i+1,n
            if(fsym(j)/=fsym(i)) exit
            if(focvir(j)(1:1)/=focvir(i)(1:1)) exit
            if(flab(iwk(j))==flab(iwk(i))) then
               k=k+1
               write(suffix(1:1),'(i1)') k/10
               write(suffix(2:2),'(i1)') mod(k,10)
               flab(iwk(j))=trim(flab(iwk(j)))//suffix
            endif
         enddo
         if(k>1) flab(iwk(i))=trim(flab(iwk(i)))//'01'
      enddo
      if(yw) then
         nnn=8
         NN=N/nnn
         DO KK=1,NN+1
            N1=nnn*(KK-1)+1
            N2=min(nnn*KK,n)
            IF(N2.LT.N1) exit
            WRITE(6,*) ' '
            WRITE(6,1024) (iwk(i),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(1:6),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(7:12),I=N1,N2)
            WRITE(6,1028) (flab(iwk(i))(13:18),I=N1,N2)
            WRITE(6,1029) ('SY ',fsym(i),I=N1,N2)
            WRITE(6,1026) (focvir(i),I=N1,N2)
            WRITE(6,*) ' '
         enddo
      endif
      if(yes) print*,'sortie end_rename'
      return
      end
       subroutine lp_rename(n,flab,fsym,focvir,fmult_o,yes)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(4) focvir(n)
      character(18) flab(n)
      integer fsym(n),fmult_o(n)
      common/pr/nprint
      logical yes
      character(2) suffix,LP(2)
      yw=.false.
      LP=(/'LP','VI'/)
!
!----------------------------------------------------------
! Rename LO's which have more orbitals than their multiplicity
!----------------------------------------------------------
!
      if(yes)print*,'entree lp_rename'
      do icas=1,2
!! cancel characters after LP
!         do i=1,n
!            l=len_trim(flab(i))
!            if(index(flab(i)(l-3:l),LP(icas))==0) cycle
!            if(yw) print*,'i,flab(i)',i,flab(i)
!            if(flab(i)(l-3:l-2)==LP(icas)) flab(i)(l-1:l)=' '
!         enddo
! loop i: search LP strings
         do i=1,n
            l=len_trim(flab(i))
            if(index(flab(i)(l-3:l),LP(icas))==0) cycle
            k=1
            kk=1
            if(flab(i)(l-1:l)==LP(icas)) flab(i)=trim(flab(i))//'01'
            l=len_trim(flab(i))
! found one. search others with the same name
! rename if same symmetry and same occupation
            do j=i+1,n
               if(index(flab(j)(l-3:l),LP(icas))==0) cycle
               m=len_trim(flab(j))
               if(flab(j)(m-1:m)==LP(icas)) flab(j)=trim(flab(j))//'01'
               m=len_trim(flab(i))
               if(yw)print'(a,4i4,3a)','coucou1',i,j,
     *         fsym(j),fsym(i),'   ',flab(i),flab(j)
               call flush(6)
               if(fsym(j)/=fsym(i)) cycle
                if(yw)print*,'coucou2'
               if(focvir(j)(1:1)/=focvir(i)(1:1)) cycle
                if(yw)print*,'coucou3'
               if(flab(j)==flab(i)) then
                  k=k+1
                  kk=kk+1
                  write(suffix(1:1),'(i1)') kk/10
                  write(suffix(2:2),'(i1)') kk-(kk/10)*10
                  flab(j)(l-1:l)=suffix
                  if(yw)print*,'coucou4',i,j,flab(i),flab(j)
               endif
            enddo
         enddo
! The number of LP on a center cannot exceed its multiplicity
! of the center
! Re-do preceeding search
! loop i: search LP strings
         do i=1,n
            l=len_trim(flab(i))
            if(index(flab(i)(l-3:l),LP(icas))==0) cycle
! found one. search others with the same name
            k=1
            kk=1
            if(yw)print*,'coucou5',flab(i:n)
            do j=i+1,n
               if(flab(j)==flab(i)) then
                  if(yw)print*,'FLAB',i,flab(i)
                  k=k+1
                  kk=kk+1
                  if(yw)print*,'k,fmult_o(i)',k,fmult_o(i)
                  if(k>fmult_o(i)) then
                     k=1
                     l=len_trim(flab(j))
                     write(suffix(1:1),'(i1)') kk/10
                     write(suffix(2:2),'(i1)') kk-(kk/10)*10
                     flab(j)(l-1:l)=suffix
                  endif
               endif
            enddo
            if(yw)print*,'coucou6',flab(i:n)
            !if(flab(i)(l-1:l)==LP(icas)) flab(i)=trim(flab(i))//'01'
         enddo
         if(yw) then
            do i=1,n
               l=len_trim(flab(i))
               if(index(flab(i)(l-3:l),LP(icas))==0) cycle
               if(yw)print*,'i,flab(i)',i,flab(i)
            enddo
         endif
      enddo
      if(yes) print*,'sortie lp_rename'
       call flush(6)
      return
      end
