      subroutine ecrocc(nsym,norbs,norbs0,fermi,frozen,itsym,iord
     *,act,inact,delete)
      use molcost
      IMPLICIT REAL*8(A-H,O-Z)
c     PARAMETER (maxorb=1024,maxsym=8)
      PARAMETER (maxorb=2048,maxsym=8)
      logical ylabel
      character*18 tipo1(maxorb),tipo2(maxorb),afr
      common/pr/nprint,mprint(10),filorb,blan40
      character*80 filorb,blan40
      dimension occ(maxorb),norbs(maxsym),orb1(maxorb),orb2(maxorb)
      dimension norbs0(maxsym),iord(maxorb)
      dimension fermi(8),itsym(maxorb),frozen(8),delete(8)
      dimension act(maxsym),inact(maxsym)
      integer fermi,frozen,act,delete
      logical yw
      yw=.false.
      if(ychol) return
c      print*,'entree ecrocc'
c
c     stockage des labels, s'ils existent
c
c      open(81,status='scratch')
      open(81,status='unknown',file='BID81')
      ylabel=.false.
 27   read(80,'(a)',end=28) filorb
      INAM=INDEX(filorb,'LABELS')
      IF(INAM.EQ.0) goto 27
      ylabel=.true.
 29   read(80,'(a)',end=28) filorb
      write(81,'(a)') filorb
      goto 29
 28   continue
      rewind 80
      rewind 81
c
c     lecture des nombres d'occupation
c
      read(80,'(a)',end=26) filorb
      !print*,filorb
 25   read(80,'(a)',end=26) filorb
c      write(6,'(a)') filorb
      INAM=INDEX(filorb,'OCCUPATION NUMBERS')
      IF(INAM.EQ.0) goto 25
      noc=0
      norb=0
      noac=0
      ninac=0
      do k=1,nsym
         noc=noc+fermi(k)
         norb=norb+norbs(k)
         noac=noac+act(k)
         ninac=ninac+inact(k)
      enddo
c      print*,'noc,norb',noc,norb
      if(yw)print*,'fermi',(fermi(k),k=1,nsym)
      if(yw)print*,'norbs',(norbs(k),k=1,nsym)
      if(yw)print*,'norbs0',(norbs0(k),k=1,nsym)
      ifin1=0
      ifin2=0
      ifin0=0
      ifin0=0
      if(yw)print*,'delete',delete
      do is=1,nsym
         nsi=norbs(is)
         nsif=nsi+frozen(is)
         ideb0=ifin0+1
         ifin0=ideb0+nsi-1
         !print*,frozen(is),ideb0,ifin0,delete(is)
         if(nsif.ne.0) read(80,1000)
     *   (fr,k=1,frozen(is)),
     *   (orb1(iord(k)),k=ideb0,ifin0),
     *   (de,k=1,delete(is))
         if(ylabel.and.nsif.ne.0) read(81,1001)
     *   (afr,k=1,frozen(is)),
     *   (tipo1(iord(k)),k=ideb0,ifin0),
     *   (de,k=1,delete(is))
         do k=1,norbs(is)
c         print'(a5,a12)','tipo ',tipo1(k)
         enddo
      enddo
 1000 format(4d18.12)
 1001 format(4a18)
c      print*,'orb1',(orb1(k),k=1,noc)
c      print*,'orb2',(orb2(k),k=1,norb-noc)
 
c       print*,'ninac,noc,noac',ninac,noc,noac
c       print*,'act',act
c ------------------------------------------------------------
 
      !ychol_sv=ychol
      !ychol=.false.
      write(*,*)
      if(ychol) then
         write(*,*)'   ',('-',k=1,20),' orbitals ',
     *                   ('-',k=1,20)
      else
         write(*,*)'   ',('-',k=1,15),' orbital rearrangement ',
     *                   ('-',k=1,15)
      endif
      print*,' '
      !if(.not.ychol)write(*,12)(k,itsym(k),orb1(k),k=1,ninac)
 12    format((1x,4(i4,'(',i1,') #',f7.5,'# ')))
      if(all(act==0)) then
         if(.not.ychol)write(*,12)(k,itsym(k),orb1(k),k=1,noc)
         if(.not.ychol) 
     *   write(*,*)'   ',('-',k=1,15),'          Fermi level         ',
     *                   ('-',k=1,15)
         if(.not.ychol)
     *   write(*,12)(k,itsym(k),orb1(k),k=noc+1,ninac+noac)
      else
         write(*,12)(k,itsym(k),orb1(k),k=1,ninac)
         write(*,*)'   ',('-',k=1,15),'      Begin Active Orbitals   ',
     *                   ('-',k=1,15)
         write(*,12)(k,itsym(k),orb1(k),k=1+ninac,ninac+noac)
         write(*,*)'   ',('-',k=1,15),'        End Active Orbitals   ',
     *                   ('-',k=1,15)
      endif
      write(*,12)(k,itsym(k),orb1(k),k=ninac+noac+1,norb)
      write(*,*)'   ',('-',k=1,62)
      write(*,*)
      !ychol=ychol_sv
      if(.not.ylabel) return
      !ychol_sv=ychol
      !ychol=.false.
      write(*,*)'   ',('-',k=1,15),'------------- labels -----------',
     *                ('-',k=1,15)
      write(*,13)(k,itsym(k),tipo1(k),k=1,ninac)
 
      if(.not.ychol) then
         if(all(act==0)) then
            write(*,13)(k,itsym(k),tipo1(k),k=1+ninac,noc)
            write(*,*)'   ',('-',k=1,15),'        Fermi level         ',
     *                      ('-',k=1,15)
            write(*,13)(k,itsym(k),tipo1(k),k=noc+1,ninac+noac)
         else
            write(*,*)'   ',('-',k=1,15),'    Begin Active Orbitals   ',
     *                      ('-',k=1,15)
            write(*,13)(k,itsym(k),tipo1(k),k=1+ninac,ninac+noac)
            write(*,*)'   ',('-',k=1,15),'      End Active Orbitals   ',
     *                      ('-',k=1,15)
         endif
      endif
      !ychol=ychol_sv
      write(*,13)(k,itsym(k),tipo1(k),k=ninac+noac+1,norb)
      write(*,*)'   ',('-',k=1,62)
      write(*,*)
 13    format((1x,3(i4,'(',i1,') #',a14,'# ')))
 26   continue
      return
      end
