      module mod_lirorb2
      contains
      subroutine lirorb2(fich,norb,nsym,isym,ifilw,ifilr,fermi,noac,
     *numac,fermi0,noaco,noacv,ifiloc,ifillab,title,exist_labels,
     *newformat,nprint,bidend)

c---------------------------------------------------
c     lecture des fichiers ORB en clair de molcas
c     fich : nom du fichier a lire
c     norb,nsym,isym = valeurs en sortie (pas a fournir !)
c     ifilw : numero de file ou on ecrit les orbitales (unformatted)
c     ifilr : numero de file ou on lit les orb en formatte
c
c     arguments optionnels :
c     en sortie : fermi
c                 noac,numac    actives
c                 noaco,noacv   actives occupees/virtuelles par symetrie
c     en entree
c                 fermi0        alors fermi=fermi0
c                 ifiloc,ifillab numeros des fichiers des occupees et
c                                des labels. Si non donnes, on prend
c                                ifilw
c                 bidend : T: le nom des fichiers ifilw sont fich//'BIDORB1'
c                 et non 'BIDORB'//fich (ce serait mieux que ce soit
c                 toujours comme ca, mais il y a des effets d'histoire...)
c---------------------------------------------------
c
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      character(*) fich
      double precision,allocatable,dimension(:,:) :: u
      double precision,allocatable,dimension(:) :: a
      character(18),allocatable,dimension(:) :: aa1
      character(80) aa
      integer,optional,intent(out) :: noac,numac(17),fermi(8)
      integer,optional,intent(out) :: noaco(8),noacv(8)
      integer,intent(out) :: norb,nsym,isym(8)
      integer,intent(in),optional :: fermi0(8),ifiloc,ifillab,nprint
      integer fermi1(8),noaco1(8),noacv1(8)
      character(*),intent(out),optional :: title
      logical,optional,intent(out) :: exist_labels
      logical,optional,intent(in) :: bidend
      logical :: yopen
      ! pour lirorb :
      ! bidend=donnee provisoire : =T ==> on ecrit les fichiers 
      ! temporaires trim(fich)//'BIDORB au lieu de BIDORB'//fich
      ! mais on garde la 1ere possibilite pour compatibilite avec les
      ! autres programmes
      character(1),optional,intent(out) :: newformat
      logical y_new_format
      yw=.false.
c
      mprint=0
      if(present(nprint)) then
         mprint=nprint
      endif
      inquire(ifilr,opened=yopen)
      if(yopen)print'(a,i2,a)','***lirorb: Warning. File ',ifilr,
     *' was already opened***'
      inquire(file=fich,opened=yopen)
      if(yopen)print'(a,a,a)','***lirorb: Warning. File ',fich,
     *' was already opened***'
      open(ifilr,file=fich,status='old')
! New format?
      read(ifilr,'(a)',end=1) aa
      y_new_format=aa(1:1)=='#'
      if(present(newformat)) newformat=' '
      if(y_new_format) then
         if(present(newformat)) then
            newformat='T'
         endif
!   save INPUT ORBITAL file on LIRORB_BIDORB_form
         if(mprint>0) then
            print*,' '
            print*,'scf orbital file ('//trim(fich)//
     *      ') is in new format'
         endif
         rewind ifilr
         if(present(bidend)) then
            if(bidend) then
               open(ifilw,file=trim(fich)//'BIDORB1',status='replace')
               goto 33
            endif
         endif
         open(ifilw,file='BIDORB'//fich,status='replace')
 33      continue
         do
            read(ifilr,'(a)',end=3) aa
            write(ifilw,'(a)') trim(aa)
         enddo
 3       continue
         close (ifilw)
!   if y_new_format, read nsym as written on file ifilr
         rewind ifilr
         read(ifilr,'(a)') aa
         read(ifilr,'(a)') aa
         read(ifilr,'(a)') aa
         read(ifilr,'(2i8)') ibid,nsym_newformat
!   oldorb
         call oldorb(ifilr,ifilw)
         close(ifilr)
         open(ifilr,file='OUTORB',status='old')
         read(ifilr,'(a)',end=1) aa
      endif
      if(present(bidend)) then
         if(bidend) then
            open(ifilw,file=trim(fich)//'BIDORB',
     *      form='unformatted',status='replace')
            if(present(ifiloc)) open(ifiloc,file=trim(fich)//'BIDOC',
     *      form='unformatted',status='unknown')
            if(present(ifillab)) open(ifillab,file=trim(fich)//'BIDLAB',
     *      form='unformatted',status='unknown')
            goto 34
         endif
      endif
      open(ifilw,file='BIDORB'//fich,
     *form='unformatted',status='replace')
      if(present(ifiloc)) open(ifiloc,file='BIDOC'//fich,
     *form='unformatted',status='unknown')
      if(present(ifillab)) open(ifillab,file='BIDLAB'//fich,
     *form='unformatted',status='unknown')
 34   continue
      isym=0
      nsym=0
c
      if(present(title)) title=aa
      if(yw)print*,trim(aa)
      do
         read(ifilr,'(a)',end=1) aa
         if(yw)print*,trim(aa)
         ii=index(aa,'* ORBITAL')
         if(ii.eq.0) cycle
         read(aa,'(9x,2i5)') nsym,j
         isym(nsym)=isym(nsym)+1
      enddo
 1    continue
      norb=sum(isym(1:nsym))
      if(yw)print*,'nsym',nsym
      if(yw)print*,'norb',norb
      if(yw)print'('' isym'',8i4)',isym(1:nsym)
      if(y_new_format) nsym=nsym_newformat
c
      rewind ifilr
      read(ifilr,*)
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate (u(ndims,ndims))
         do k=1,ndims
            read(ifilr,*)
            read(ifilr,1000) u(:,k)
         enddo
         write(ifilw) u
         deallocate (u)
      enddo
 1000 format(4d18.12)
 1001 format(4a18)
      
      if(yw)print*,'fin de la lecture des orbitales'
c
      rewind ifilr
      if(present(ifiloc)) then
         ifilw1=ifiloc
      else
         ifilw1=ifilw
      endif
      if(present(fermi0)) then
         fermi1(1:nsym)=fermi0(1:nsym)
      endif
      do
         read(ifilr,'(a)') aa
         if(index(aa,'* OCCUPATION').eq.0) cycle
         do is=1,nsym
            if(isym(is)==0) cycle
            allocate (a(isym(is)))
            read(ifilr,1000) a
            write(ifilw1) a
            if(.not.present(fermi0)) then
               fermi1(is)=0
               do k=1,isym(is)
                  if(a(k).gt.1.d0) fermi1(is)=fermi1(is)+1
               enddo
               endif
            deallocate(a)
         enddo
         exit
      enddo
      if(yw)print*,'fin de la lecture des occupations'
c
      rewind ifilr
      if(present(ifillab)) then
         ifilw1=ifillab
      else
         ifilw1=ifilw
      endif
      do
      read(ifilr,'(a)',end=2) aa
         if(yw)print*,trim(aa)
         if(index(aa,'* LABEL').eq.0) cycle
         if(present(noaco)) noaco=0
         if(present(noacv)) noacv=0
         do is=1,nsym
            if(isym(is)==0) cycle
            allocate (aa1(isym(is)))
            read(ifilr,1001) aa1
            if(yw)print*,aa1
            write(ifilw1) aa1
            if(yw)print*,present(noac)
            if(yw)print*,present(noaco)
            if(yw)print*,present(noacv)
            if(yw)print*,present(numac)
            if(present(noac).or.present(noaco).or.present(noacv).or.
     *      present(numac)) then
               noac1=0
               kk=0
               do k=1,fermi1(is)
                  if(aa1(k)(1:1)=='A') then
                     noac1=noac1+1 
                     if(present(noaco)) noaco(is)=noaco(is)+1 
                     if(present(numac)) numac(noac1)=kk
                  endif
               enddo
               do k=1+fermi1(is),isym(is)
                  if(aa1(k)(1:1)=='A') then
                     noac1=noac1+1 
                     if(present(noacv)) noacv(is)=noacv(is)+1 
                     if(present(numac)) numac(noac)=kk
                  endif
               enddo
            endif
            deallocate(aa1)
         enddo
         exit
      enddo
      if(present(fermi)) fermi(1:nsym)=fermi1(1:nsym)
      if(present(noac)) noac=noac1
      if(yw)print*,'fin de la lecture des labels'
      close(ifilr)
      rewind ifilw
      if(present(ifiloc)) rewind ifiloc
      if(present(ifillab)) rewind ifillab
      if(present(exist_labels)) exist_labels=.true.
      return
 2    continue
      inquire(ifilr,name=aa)
      l=len_trim(aa)
      if(aa(l-5:l)=='OUTORB') then
         close(ifilr,status='delete')
      else
         close(ifilr)
      endif
      !print*,'pas de labels dans ',trim(fich)
      if(present(exist_labels)) exist_labels=.false.
      rewind ifilw
      return
      end subroutine
      end module mod_lirorb2
