      subroutine fin
      use mod_dolo
      use mod_lirorb
      use mod_script
      implicit real(8)(a-h,o-x,z),logical(1)(y)
      common/pr/nprint
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      integer,allocatable :: iord(:),itsym(:)
      integer frozen(maxsym),delete(maxsym)
      character(80) lo80
      logical OK
      character(300) namel
!     call titre('End of Program#',40)
      allocate(iord(norb))
      allocate(itsym(norb))
!
!----------------------------------------------------------------------
! do not complete if the number of LO's does not fit the number of AO's
!----------------------------------------------------------------------
!
      call displaywarnings(ok)
      dataok=ok
      if(.not.OK) return
      ifilpr_sv=ifilpr
      ifilpr=6
      call occupations
      ifilpr=ifilpr_sv
      if(.not.occupok) then
         call titre('the number of LO''s does not fit the number '//
     *   'of AO''s#Look at occupations#No output files'//
     *   ' generated#',70)
         dataok=.false.
         return
      endif
!
!------------------------------------
! compute number of occ, act and virt
!------------------------------------
!
      call count_occ
      do is=1,nsym
         itsym(isymt(is-1)+1:isymt(is))=is
      enddo
!
!--------------------------------------------------------
!     tranfer virtual unused AO's to LO's
!--------------------------------------------------------
!
      l=0
      do k=fnorb+1,norb
            do
               l=l+1
               if(yvirt(l)) then
                  flo(l,k)=1.d0
                  exit
               endif
            enddo
            flab(k)='T_'//trim(orbi(l)(1:4))//'.'//trim(orbi(l)(5:8))
            fsym(k)=itsym(l)
            focvir(k)='VIRT'
            focc(k)=0.d0
      enddo
!
!--------------------------------------------------------
!     Symmetry of "T_" LO's add AO's to LO's
!--------------------------------------------------------
!
      ifin=fnorb
      do is=1,nsym
         ideb=ifin+1
         ifin=ifin+isym(is)-fnoc(is)-fnac(is)-fnal(is)
         fsym(ideb:ifin)=is
      enddo
!      print*,'fnorb',fnorb,norb
!      print'(a,50i2)','fsym',fsym(1:fnorb)
!      print'(a,50i2)','fsym',fsym(1:norb)
!      print*,'isym',isym(1:nsym)
!      print*,'fnoc',fnoc(1:nsym)
!      print*,'fnac',fnac(1:nsym)
!      print*,'fnal',fnal(1:nsym)
!
!--------------------------------------------------------
!      Orbitals with prefix "P_":
!      change P_ to O_
!      change prefix to ".PI"
!--------------------------------------------------------
!
       call prefixofP_orb(flab,norb)
!
!--------------------------------------------------------
!     reorder LO's
!--------------------------------------------------------
!
      kk=0
      iord=0
!      do k=1,norb
!         print*,'LO',k,flab(k),fsym(k),focvir(k)
!      enddo
      do is=1,nsym
         call cherchelo(is,'OCC ','G',kk,iord)
         call cherchelo(is,'OCC ','C',kk,iord)
         call cherchelo(is,'OCC ','O',kk,iord)
         call cherchelo(is,'ACTO','A',kk,iord)
         call cherchelo(is,'ACTV','A',kk,iord)
         call cherchelo(is,'VIRT','O',kk,iord)
         call cherchelo(is,'VIRT','T',kk,iord)
         call cherchelo(is,'VIRT','G',kk,iord)
      enddo
      fsym(1:norb)=fsym(iord(1:norb))
      focc(1:norb)=focc(iord(1:norb))
      deallocate(work2)
      allocate(work2(norb,norb))
      do k1=1,norb
         do k=1,norb
            work2(k,k1)=flo(k,iord(k1))
         enddo
      enddo
      flo(1:norb,1:norb)=work2
      flab(1:norb)=flab(iord(1:norb))
      fdat1(1:norb)=fdat1(iord(1:norb))
      focvir(1:norb)=focvir(iord(1:norb))
      atoms_in_LO(1:norb,:)=atoms_in_LO(iord(1:norb),:)
      fnat(1:norb)=fnat(iord(1:norb))
      nwk=norb
      iwk=(/(k,k=1,nwk)/)
      frozen=0
      delete=0
      do is=1,nsym
         print*,'SYM',is
         do k=isymt(is-1)+1,isymt(is-1)+fermi0(is)
            if(flab(k)(1:1)=='G') frozen(is)=frozen(is)+1
         enddo
         do k=isymt(is-1)+fermi0(is)+1,isymt(is)
            if(flab(k)(1:1)=='G') delete(is)=delete(is)+1
         enddo
         print'(40a2)',flab(isymt(is-1)+1:isymt(is))(1:1)//' '
      enddo
!
!--------------------------------------------------------
! Rename LO's which have same name in the same symmetry and
! category (occ, act, virt)
!--------------------------------------------------------
!
      call end_rename(nwk,iwk(1:nwk),flab(1:nwk),
     *fsym(iwk(1:nwk)),focvir(iwk(1:nwk)),yes)
!!
!!--------------------------------------------------------
!! Reorder orbitals SG and PI for the same bond. SG first
!!--------------------------------------------------------
!!
!      do k=2,nwk
!         l=len_trim(flab(k))
!         if(flab(k)(1:l-2)==flab(k-1)(1:l-2)) then
!            if(flab(k)(l-1:l)=='SG'.and.flab(k-1)(l-1:l)=='PI') then
!               !print*,'ECHANGE',k-1,k,flab(k-1),flab(k)
!               flab(k)(l-1:l)='PI'
!               flab(k-1)(l-1:l)='SG'
!               foccbid=focc(k)
!               focc(k)=focc(k-1)
!               focc(k-1)=foccbid
!               do i=1,nwk
!                  flobid=flo(i,k)
!                  flo(i,k)=flo(i,k-1)
!                  flo(i,k-1)=flobid
!               enddo
!            endif
!         endif
!      enddo
!
!--------------------------------------------------------
! Print LO's
!--------------------------------------------------------
!
      if(nprint>-1)
     *call scripto6(flo(:,iwk(1:nwk)),norb,nwk,norb,nwk,orbi,6,
     *focvir(iwk(1:nwk)),flab(iwk(1:nwk)),focc(iwk(1:nwk))
     *,fsym(iwk(1:nwk)),fdat1(iwk(1:nwk)),iwk(1:nwk))
      print*,'MOTRA Data:'
      print*,'FROZEN'
      print'(8i4)',frozen(1:nsym)
      print*,'DELETE'
      print'(8i4)',DELETE(1:nsym)
      print'(a,8i4)','FERMI in Molcost',fermi0(1:nsym)-frozen(1:nsym)
      open(99,file='DOLO_MOTRAIN',form='formatted',status='unknown')
!
!-----------------------------------------------
! Generate data for motra and molcost
!-----------------------------------------------
!
      write(99,'(a)') ' &MOTRA &END'
      write(99,'(a)') 'TITLE'
      write(99,'(a)') prefix(1:len_trim(prefix)-1)
      if(ychol) then
         write(99,'(a)') 'CTONLY'
         write(99,'(a)') 'KPQ'
         write(99,'(a)'),'FROZEN'
         write(99,'(8i4)') (0,k=1,nsym)
         write(99,'(a)') 'DELETE'
         write(99,'(8i4)')  (0,k=1,nsym)
      else
         write(99,'(a)'),'FROZEN'
         write(99,'(8i4)') frozen(1:nsym)
         write(99,'(a)') 'DELETE'
         write(99,'(8i4)') DELETE(1:nsym)
      endif
      write(99,'(a)') 'END OF INPUT'
      close(99)
      open(99,file='DOLO_MOLCOSTIN',form='formatted',status='unknown')
      write(99,'(a)') ' &COST'
      write(99,'(a)') ' prefix='//"'"//trim(prefix)//"'"
      if(ychol) write(99,'(a)') ' ychol=t,chol_ord=''KPQ'''
      if(yopm) print*,'openmolcas -> DOLO_MOLCOSTIN'
      if(yopm) write(99,'(a)') ' yopm=t,'
      write(99,'(a,8(i4,","))') ' FROZEN=',frozen(1:nsym)
      write(99,'(a,8(i4,","))') ' DELETE=',DELETE(1:nsym)
      write(99,'(a,8(i4,","))') ' FERMI=',fermi0(1:nsym)-frozen(1:nsym)
      write(99,'(a)') ' /'
      close(99)
!
!-----------------------------------------------
! Generate data for GCas
!-----------------------------------------------
!
      if(ygcas) then
         open(99,file='GCASIN',status='unknown')
         do k=1,norb
            namel=' &ras '
            write(namel(7:),'(a4,i1)') 'isy=',fsym(k)
            write(namel(12:),'(a9,a3,a1)')",occvir='",focvir(k)(1:3),"'"
            write(namel(25:),'(a8,a,a3)') ",label='",trim(flab(k)),"' /"
            write(99,'(a)') trim(namel)
         enddo
         close(99)
      endif
!
!--------------------------------------------------------
! give each Active a different name
!--------------------------------------------------------
!
      if(.not.loc_actives) then
         print*,' give each Active a different name'
         kl=0
         do k=1,norb
            if(flab(k)(1:1)=='A') then
               kl=kl+1
               ll=len_trim(flab(k))
               write(flab(k)(ll+1:ll+2),'(I2.2)') kl
            endif
         enddo
      endif
!
!--------------------------------------------------------
!     Create file NONORLOC
!--------------------------------------------------------
!
      open(53,status='scratch',form='unformatted')
      open(54,status='scratch',form='unformatted')
      open(55,status='scratch',form='unformatted')
      !print*,shape(flo),norb
!         call script(flo,norb,norb,
!     *   norb,norb)
      do is=1,nsym
         !print*,'sym',is,isym(is)
         ndims=isym(is)
         if(ndims==0) cycle
!         nwk=0
!         do k=1,norb
!            if(fsym(k)==is) then
!               nwk=nwk+1
!               iwk(nwk)=k
!            endif
!         enddo
         nn=isymt(is-1)
!         call script(flo(nn+1:nn+ndims,iwk(1:nwk)),ndims,ndims,
!     *   ndims,ndims)
!         write(53) flo(nn+1:nn+ndims,iwk(1:nwk))
!         write(54) focc(iwk(1:nwk))
!         write(55) flab(iwk(1:nwk))//'    '
         write(53) flo(nn+1:nn+ndims,nn+1:nn+ndims)
         write(54) focc(nn+1:nn+ndims)
         write(55) flab(nn+1:nn+ndims)!//'    '
      enddo
      call ecriorb('* Orbitales Locales NON orthogonales (Schmudorb)',
     *trim(workdir)//'NONORLOC',nsym,isym,53,56,ifiloc=54,ifillab=55)
!
!--------------------------------------------------------
!     Create file SCH_FERMI
!--------------------------------------------------------
!
      close(94,status='delete')
      open(94,status='unknown',file=trim(workdir)//'SCH_FERMI')
      write(94,'(a,8(i4,'',''))') ' &ferm fermi=',fermi0(1:nsym)
!     *-frozen(1:nsym)
      write(94,'(a)') ' /'
!
!--------------------------------------------------------
!     Create file containing the various fl...
!--------------------------------------------------------
!
      call crea_LoOinfo(iord)
!
!--------------------------------------------------------
!     close and delete files
!--------------------------------------------------------
!
      close(94)
      close(92,status='delete')
      close(93,status='delete')
      close(95,status='delete')
      close(96,status='delete')
      close(9,status='delete')
      do k=1,idatlist
         write(lo80,'(i4)') k
         lo80=adjustl(lo80)
         open(ifilpr,file='basicD_'//trim(lo80),status='unknown')
         close(ifilpr,status='delete')
         !print*,'delete '//'basicD_'//trim(lo80)
      enddo
      return
      end
       subroutine cherchelo(is,occ_loc,lab,kk,iord)
      use mod_dolo
      character(4) occ_loc
      character lab
      dimension iord(norb)
!      print*,'***********************************',occ_loc,' ',lab
      do k=1,norb
!         print*,'coucou1 ',focvir(k),occ_loc
!         do i=1,4
!          print*,focvir(k)(i:i),occ_loc(i:i)
!         enddo
         if(fsym(k)/=is) cycle
         if(focvir(k)==occ_loc) then
!         print*,'coucou2 ',flab(k)(1:1),lab
            if(flab(k)(1:1)==lab) then
               kk=kk+1
               iord(kk)=k
!               print*,'cherche',kk,k,'  ',lab,'  ',occ_loc,'  ',flab(k)
            endif
         endif
      enddo
      return
      end
       subroutine crea_LoOinfo(iord)
      use mod_dolo
      dimension iord(norb)
      character(3) aov
      character(18) flab_tmp
      character(9) fsigpi_tmp
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      open(99,file=trim(prefix)//'LOinfo',status='unknown')
      write(99,*) norb
!
! Ecriture du fichier LOinfo contenant des infos sur les OL
!
!
!   generation de l'ordre ijkloc
!
! modif iord      iord=0
! modif iord      n=0
! modif iord ! boucle de 1,2, pour ordonner selon les occ, virt
! modif iord       do icas=1,2
! modif iord          do is=1,nsym
! modif iord ! modifs IDRIS : 3 lignes commentees
! modif iord C            if(icas==1) oav='OCC'
! modif iord C            if(icas==2) oav='ACT'
! modif iord C            if(icas==3) oav='VIR'
! modif iord             do i=1,norb
! modif iord                if(flab(i)(1:1)=='G') cycle
! modif iord                if(fsym(i)/=is) cycle
! modif iord                if(icas==1.and.focvir(i)/='OCC'
! modif iord      *         .and.focvir(i)(1:4)/='ACTO') cycle
! modif iord                if(icas==2.and.focvir(i)/='VIRT'
! modif iord      *         .and.focvir(i)(1:4)/='ACTV') cycle
! modif iord                if(iord(i)/=0) cycle
! modif iord ! on a trouve une orbitale non encore assigee
! modif iord                n=n+1
! modif iord                iord(i)=n
! modif iord                !print*,'LOinf1',icas,n,i,flab(i),'  ',focvir(i),fsym(i)
! modif iord ! on cherche celles de meme nom et de meme oav (occ,act ou vir)
! modif iord !               do j=i+1,norb
! modif iord !                  if(focvir(i)/=focvir(j)) cycle
! modif iord !                  if(flab(i)==flab(j)) then
! modif iord !                     n=n+1
! modif iord !                     iord(j)=n
! modif iord !               print*,'LOinf2',icas,n,j,flab(j),'  ',focvir(j),fsym(j)
! modif iord !                  endif
! modif iord !               enddo
! modif iord             enddo
! modif iord          enddo
! modif iord       enddo
!
! Calcul iord: ordre des OL OCC/ACTocc/ACTvirt/VIRT
!
      iord=0
      n=0
      ! 4 cas pour OCC/ACTocc/ACTvirt/VIRT
      do icas=1,4
         do i=1,norb
            if(flab(i)(1:1)=='G') cycle
            if(icas==1.and.focvir(i)/='OCC') cycle
            if(icas==2.and.focvir(i)/='ACTO') cycle
            if(icas==3.and.focvir(i)/='ACTV') cycle
            if(icas==4.and.focvir(i)/='VIRT') cycle
            if(iord(i)/=0) cycle
! on a trouve une orbitale non encore assignee
            n=n+1
            iord(i)=n
            !print*,'LOinf1',icas,n,i,flab(i),'  ',focvir(i),fsym(i)
! on cherche celles de meme nom et de meme oav (occ,act ou vir)
            do j=i+1,norb
               if(focvir(i)/=focvir(j)) cycle
               if(flab(i)==flab(j)) then
                  n=n+1
                  iord(j)=n
!                 print*,'LOinf2',icas,n,j,flab(j),'  ',focvir(j),fsym(j)
               endif
            enddo
         enddo
      enddo


! fill atoms_in_lo for "T_" LO's
!
      do io=1,norb
         if(flab(io)(1:2)=='T_') then
            ind=index(flab(io),'.')
            fnat(io)=1
            atoms_in_lo(io,1)=flab(io)(3:ind-1)
         endif
      enddo
!
! end filling fsigpi. fsigpi(io) indicates if LO io is sigma,pi...
! possible values: SIG PI DIFF_S DIFF_D CORE LP
!
      do io=1,norb
         if(fsigpi(io)==' ') then
! frozen
            if(flab(io)(1:1)=='G') cycle
! core
            if(flab(io)(1:1)=='C') then
               fsigpi(io)='CORE'
               cycle
            endif
! diff
            if(flab(io)(1:1)=='T') then
               fsigpi(io)='DIFF_'
               ind=index(flab(io),'.')
               if(flab(io)(ind+1:ind+1)=='1') then
                  fsigpi(io)(6:6)=flab(io)(ind+2:ind+2)
               else if(flab(io)(ind+1:ind+1)=='2'.or.
     *         flab(io)(ind+1:ind+3)=='3d0') then
                  fsigpi(io)(6:7)=flab(io)(ind+2:ind+3)
               else if(flab(io)(ind+1:ind+1)>='3') then
                  fsigpi(io)(6:8)=flab(io)(ind+2:ind+4)
               endif
               cycle
            endif
! search suffix
            l=len_trim(flab(io))
            do k=l-1,1,-1
               if(flab(io)(k:k)=='.') then
                  if(flab(io)(k+1:k+2)=='LP') then
                     fsigpi(io)='LP'
                  else if(flab(io)(k+1:k+2)=='VI') then
                     ind=index(flab(io),'.')
                     fsigpi(io)='EMPTY_'//flab(io)(ind+1:ind+1)
                  else if(flab(io)(k+1:k+2)=='SG') then
                     fsigpi(io)='SIG'
                  else if(flab(io)(k+1:k+2)=='PI') then
                     fsigpi(io)='PI'
                  else if(flab(io)(k+1:k+2)=='DL') then
                     fsigpi(io)='PI'
                  endif
               endif
            enddo
         endif
      enddo
      do i=1,norb
C         if(iord(i).ne.0)
C     *   print'(2i4,1x,a14,1x,a4,1x,a8,i4,1x,20a4)'
C     *   ,i,iord(i),flab(i),focvir(i),fsigpi(i)
C     *   ,fnat(i),atoms_in_LO(i,1:fnat(i))
         if(iord(i).ne.0) then
            flab_tmp=flab(i)
            call maj(flab_tmp,18)
            fsigpi_tmp=fsigpi(i)
            call maj(fsigpi_tmp,9)
            write(99,'(2i4,1x,a18,1x,a4,1x,a9,i4,1x,100a4)')
     *      i,iord(i),flab_tmp,focvir(i),fsigpi_tmp
     *      ,fnat(i),atoms_in_LO(i,1:fnat(i))
         endif
      enddo
      print*,' '
      close(99)
      return
      end
       subroutine prefixofP_orb(flab,norb)
      character(18) flab(norb)
      do k=1,norb
         if(flab(k)(1:1)=='P') then
            i=index(flab(k),'.',.true.)
            flab(k)(i:)='.PI'
            flab(k)(1:1)='O'
            print*,flab(k)
         endif
      enddo
      end
      

