      module mod_lirorb
      contains
      subroutine lirorb(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
      subroutine ecriorb(titre,fich,nsym,isym,ifilr,ifilw
     *,ifiloc,ifillab,nolabels,newformat)
c
c---------------------------------------------------
c     ecriture des fichiers ORB en clair de molcas
c     fich : nom du fichier a ecrire
c     norb,nsym,isym = valeurs en entree (a fournir !)
c     ifilr : numero de file ou on lit les orbitales (unformatted)
c---------------------------------------------------
c
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      character(*) fich,titre
      double precision,allocatable,dimension(:,:) :: u
      double precision,allocatable,dimension(:) :: a
      character(18),allocatable,dimension(:) :: aa1
      dimension isym(8)
      integer,intent(in),optional :: ifiloc,ifillab
      logical,intent(in),optional :: nolabels
      character(*),intent(in),optional :: newformat
      character(80) orb
      yw=.false.
c
      if(yw)print*,'entree ecriorb'
      if(yw)print*,'fich',trim(fich)
      call flush(6)
      rewind ifilr
      if(present(ifiloc)) rewind ifiloc
      if(present(ifillab)) rewind ifillab
      open(ifilw,file=fich,status='unknown')
      write(ifilw,'(a)') trim(titre)
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate (u(ndims,ndims))
         !inquire(99,name=orb);print*,'name',orb;stop
         read(ifilr) u
         do io=1,ndims
         write(ifilw,'(a9,2i5)') '* ORBITAL',is,io
         write(ifilw,1000) u(:,io)
         enddo
         deallocate (u)
      enddo
      write(ifilw,'(a)') '* OCCUPATION NUMBERS'
      if(present(ifiloc)) then
         ifilr1=ifiloc
      else
         ifilr1=ifilr
      endif
      do is=1,nsym
         ndims=isym(is)
         if(ndims==0) cycle
         allocate (a(ndims))
         read(ifilr1) a
         if(ndims/=0) write(ifilw,1000) a
         deallocate (a)
      enddo
      if(present(nolabels)) then
         if(nolabels) then
            ylab=.false.
         else
            ylab=.true.
         endif
      else
         ylab=.true.
      endif
      if(ylab) then
         write(ifilw,'(a)') '* LABELS'
         if(present(ifillab)) then
            ifilr1=ifillab
         else
            ifilr1=ifilr
         endif
         do is=1,nsym
            ndims=isym(is)
            if(ndims==0) cycle
            allocate (aa1(ndims))
            read(ifilr1) aa1
            if(ndims/=0) write(ifilw,1001) aa1
            deallocate (aa1)
         enddo
      endif
 1000 format(4d18.12)
 1001 format(4a18)
      if(yw)print*,'sortie ecriorb'
      if(present(newformat)) then
         close(ifilr)
         if(newformat.ne.' ') call neworb(ifilw,nsym)
      endif
      return
      end subroutine
       subroutine lirorb_direct(fich,icas,is,norb,nsym,isym,ifilw,ifilr,
     *orb,occup,label,n)
!
! get norb,nsym,isym,orb,occup,label from a Orb file
! 1st call: initialisation. call with icas=0
! 2nd call: call with icas/=0. fills orb, occup and labels for symmetry is
! ("is" is given as input)
!
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      real(8) orb(n,n),occup(n)
      character(18) label(n)
      character(*) fich
      dimension isym(8)
      logical,save :: exist_labels
      if(icas==0) then
         call lirorb(fich,norb,nsym,isym,ifilw,ifilr,
     *   exist_labels=exist_labels)
         return
      else
         rewind ifilw
         do k=1,is-1
            if(isym(k)/=0) read(ifilw)
         enddo
         if(isym(is)/=0) read(ifilw) orb
         do k=is+1,nsym
            if(isym(k)/=0) read(ifilw)
         enddo
         do k=1,is-1
            if(isym(k)/=0) read(ifilw)
         enddo
         if(isym(is)/=0) read(ifilw) occup
         do k=is+1,nsym
            if(isym(k)/=0) read(ifilw)
         enddo
         label=' '
         if(exist_labels) then
            do k=1,is-1
               if(isym(k)/=0) read(ifilw)
            enddo
            if(isym(is)/=0) read(ifilw) label
         endif
      endif
      return
      end subroutine
       subroutine oldorb(ifilr,ifilw)
      character(80) a
      logical y
!
! On lit les orbitales sur ifilr
! on les reecrit sur ifilw (OUTORB)
! en sautant :
! 1. toutes lignes jusqu'a #ORB, sauf la 1ere apres #INFO
! 2. toutes les lignes commencant par #
!
      l=0
      rewind ifilr
      !
      read(ifilr,'(a)') a
      rewind ifilr
      open(ifilw,file='OUTORB',status='unknown')
      i=0
      y=.false. 
! numero de la ligne '#ORB'
      do
         i=i+1
         read(ifilr,'(a)') a
         !print*,'A0',a
         if(a(1:4)=='#ORB') then
            ligne_orb=i
            exit
         endif
      enddo
      !print*,'ligne_orb',ligne_orb
! Ecriture de l'entete
      rewind ifilr
      do
         read(ifilr,'(a)') a
         if(a(1:5)=='#INFO') then
            read(ifilr,'(a)') a
         !print*,'A1',a
            write(ifilw,'(a)') trim(a)
            exit
         endif
      enddo
! Ecriture a partir de #ORB
      !print*,'ligne_orb',ligne_orb
      rewind ifilr
      do i=1,ligne_orb
         read(ifilr,'(a)',end=3) a
         !print*,'a0',a
      enddo
      do
         read(ifilr,'(a)',end=3) a
         !print*,'a1',a
         if(a(1:1)/='#') write(ifilw,'(a)') trim(a)
      enddo
!      do
!         i=i+1
!         read(ifilr,'(a)',end=3) a
!         if(a(1:4)=='#ONE') y=.true.
!         if(y.or.a(1:1)=='#'.or.(i>3.and.i<7)) then
!            cycle
!         endif
!         write(ifilw,'(a)') trim(a)
!         l=l+1
!      enddo
 3    continue
      close (ifilw)
      return
      end subroutine
      subroutine neworb(ifilr,nsym)
      integer,parameter :: ndim=10000
      character(80) a
      dimension isym(8)
      logical opened
      l=0
      !
      rewind ifilr
      read(ifilr,'(a)') a
      rewind ifilr
      if(a(1:1)=='#') return
      !
!
! read isym
!
      isym=0
      rewind ifilr
      do
         read(ifilr,'(a)',end=1) a
         if(a(1:9)=='* ORBITAL') then
            read(a(10:),*) nsym_bid,isym(nsym_bid)
         endif
      enddo
 1    continue
      !print*,'isym',isym(1:nsym)
!
! insert lines
!
      rewind ifilr
! find available file number
      do ifil=8,99
         inquire(ifil,opened=opened)
         if(.not.opened) exit
      enddo
      open(ifil)
! insert first lines of new format
      write(ifil,'(a)') '#INPORB 1.1'
      write(ifil,'(a)') '#INFO'
      read(ifilr,'(a)',end=1) a
      write(ifil,'(a)') trim(a)
 1000 format(8i8)
      write(ifil,1000) 0,nsym
      write(ifil,1000) isym(1:nsym)
      write(ifil,1000) isym(1:nsym)
      write(ifil,'(a)') '#ORB'
! copy lines, insert #OCC
      do
         read(ifilr,'(a)',end=2) a
         if(a(1:20)=='* OCCUPATION NUMBERS') write(ifil,'(a4)') '#OCC'
         write(ifil,'(a)') trim(a)
      enddo
 2    continue
!
! re-transfer in input file
!
      rewind ifil
      rewind ifilr
      do
         read(ifil,'(a)',end=3) a
         write(ifilr,'(a)') trim(a)
      enddo
 3    continue
      close(ifil,status='delete')
      end subroutine
      end module mod_lirorb
