      subroutine proj_dir(BB)
      use mod_dolo
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      logical chiffre
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character(len_datlist) AA,BB
      character(18) labelk,labelp
      character(4) occ_loc
      dimension iwkk(100),iwkp(100)
      dimension jwkk(100),jwkp(100)
      if(yes) print*,'entree proj_dir'
      yw=.false.
      AA=BB
!
!---------------------------------------------------------------
! substract a set of LO's from another (larger) set of LO's
!---------------------------------------------------------------
!
!
!---------------------------------------------------------------
! read LO's (proj and kept)
!---------------------------------------------------------------
!
      AA(1:4)=' '
      aa=adjustl(aa)
      if(chiffre(aa(1:1))) then
         l=len_trim(aa)
         call fnormaligo(aa,l)
         ik=index(aa,'-')
         nwkp=0
         nwkk=0
         do k=1,ik
            if(aa(k:k)==' ') nwkp=nwkp+1
         enddo
         do k=ik+1,l
            if(aa(k:k)==' ') nwkk=nwkk+1
         enddo
         read(aa(1:ik-2),*) iwkp(1:nwkp)
         aa(1:ik)=' '
         read(aa(ik+2:l),*) iwkk(1:nwkk)
      else
         l=index(AA,' ')
         read(aa(1:l-1),'(a)') labelp
         read(aa(l+1:l+14),'(a)') labelk
         if(yw)print*,labelk
         if(yw)print*,labelp
!
!----------------
! find kept LO's
!----------------
!
         call findlo(labelk,nwkk,iwkk)
         if(yw)print*,'iwkk',iwkk(1:nwkk)
!
!----------------
! find projected LO's
!----------------
!
         call findlo(labelp,nwkp,iwkp)
         if(yw)print*,'iwkp',iwkp(1:nwkp)
      endif
      if(nwkk>nwkp) then
         print*,'Projected',nwkp,'  orbitals'
         print*,'Kept     ',nwkp,'  orbitals'
         print*,'there must be more projected than kept LO''s'
         print*,'wrong data'
         return
      endif
!
!----------------
! project (LO's of same OCC/VIRT and same symmetry)
!----------------
!
      do iocc=1,4
         if(iocc==1) occ_loc='OCC'
         if(iocc==2) occ_loc='ACTO'
         if(iocc==3) occ_loc='ACTV'
         if(iocc==4) occ_loc='VIRT'
         do is=1,nsym
            mwkk=0
            mwkp=0
            do k=1,nwkk
               ik=iwkk(k)
               if(fsym(ik)/=is) cycle
               if(focvir(ik)/=occ_loc) cycle
               mwkk=mwkk+1
               jwkk(mwkk)=ik
            enddo
            do k=1,nwkp
               ik=iwkp(k)
               if(fsym(ik)/=is) cycle
               if(focvir(ik)/=occ_loc) cycle
               mwkp=mwkp+1
               jwkp(mwkp)=ik
            enddo
            if(yw)print*,'proj sym, occ_loc',is,' ',occ_loc
            if(yw)print*,'jwkk',jwkk(1:mwkk)
            if(yw)print*,'jwkp',jwkp(1:mwkp)
            if(yw)print'(a,40i2)','fsym',fsym(1:fnorb)
            if(mwkk>0) call proj(mwkk,mwkp,jwkk,jwkp)
            if(yw)print'(a,40i2)','fsym',fsym(1:fnorb)
            if(yw)print*,'iwkk',iwkk(1:nwkk)
            if(yw)print*,'sym ',fsym(iwkk(1:nwkk))
            if(yw)print*,'iwkp',iwkp(1:nwkp)
            if(yw)print*,'sym ',fsym(iwkp(1:nwkp))
!            do k=mwkp-mwkk+1,mwkp
!               do l=nwkk,1,-1
!                  if(iwkk(l)>jwkp(k)) iwkk(l)=iwkk(l)-1
!               enddo
!               do l=nwkp,1,-1
!                  if(iwkp(l)>jwkp(k)) iwkp(l)=iwkp(l)-1
!               enddo
!            enddo
            call findlo(labelk,nwkk,iwkk)
            call findlo(labelp,nwkp,iwkp)
            if(yw)print*,'iwkk',iwkk(1:nwkk)
            if(yw)print*,'sym ',fsym(iwkk(1:nwkk))
            if(yw)print*,'iwkp',iwkp(1:nwkp)
            if(yw)print*,'sym ',fsym(iwkp(1:nwkp))
         enddo
      enddo
      if(yes) print*,'sortie proj_dir'
 
 
      return
      end
       subroutine findlo(label,nwkk,iwkk)
      use mod_dolo
      logical yw
      character(18) label
      dimension iwkk(100)
      yw=.false.
      if(yw) print*,'finlo label ',trim(label)
      nwkk=0
      do k=1,fnorb
         if(flab(k)==label) then
            nwkk=nwkk+1
            iwkk(nwkk)=k
         endif
      enddo
      if(yw)print*,'iwkk',iwkk(1:nwkk)
      if(yw)print*,'sym ',fsym(iwkk(1:nwkk))
      return
      end
 
 
