      subroutine proj(jl,nl,u,ndims,idf,nd1,nd2,ioproj,ioref,is,iop
     *,occup3,tipo,norb,maxproj,noproj)
      use mod_script
c      subroutine proj(jl,nl,u,ndims,ioref,ioproj,nbp,v,s,ul,nd1,nd2,
c     *nbocs,nbals,nbocacts,nbalacts,is,nboctot,nbactot,nbaltot,
c     *tipo,yact,yocc,ycor,occup3)
c------------------------------------------------------------
c     PROJECTION
c     projection d'un ensemble d'orbitales sur l'autre
c     u matrice des orbitales
c     ioref(io)=i : l'orbitale io est la reference (cad l'orbitale sur
c     le complementaire de laquelle il faut projeter) i.
c     ioproj(io)=i : l'orbitale io est a projeter orth a l'espace des
c     ref i
c     en donnee : jl(orbitale)=liaison de l'orb
c     norbl(liaison)=nb d'orb de la liaison
c------------------------------------------------------------
      use bas
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8)
      parameter (maxl=3000)
      character*8 orbi1,orbi2
      common/pr/nprint
c      common/bas/ orbi,nbas(nfix),nbast(0:nfix),natom,atom,base
c      character*8 orbi(nfix)
c      character*8 base(nfix)
c      character*4 atom(100)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      dimension u(ndims,idf),ioref(maxl),jl(idf)
      dimension ioproj(maxproj,nl),noproj(nl)
      dimension v(ndims,ndims),s(ndims,ndims),ul(ndims,ndims)
      dimension nbocs(maxsym,maxl),nbals(maxsym,maxl)
      dimension nbocacts(maxsym,maxl),nbalacts(maxsym,maxl)
      dimension jbocs(maxsym,maxl),jbals(maxsym,maxl)
      integer,dimension(:),allocatable :: jp
      dimension yl(maxl),ysupp(maxl)
      dimension nsup(maxl)!,ir(nfix),yz(nfix)
      allocatable ir(:),yz(:)
      dimension norbl(maxl)
      dimension yact(ndims),yocc(ndims),ycor(ndims),occup3(idf)
      character*12 tipo(norb)
      yw=.false.
      iop=0
      if(yw) then
         print*,'ndims,idf',ndims,idf
         do k=1,nl
            if(yw)print*,'nl,k,noproj(k)',nl,k,noproj(k)
         enddo
      endif
      do k=1,nl
         if(noproj(k).ne.0) goto 2
      enddo
      return
 2    continue
      allocate(ir(norb),yz(norb))
      print*,' '
      print'(a26)',      '         ================='
      print'(a26)',      '         =  PROJECTIONS  ='
      print'(a15,i4,a7)','         =  sym',is,'    ='
      print'(a26)',      '         ================='
      if(yw) then
         print*,'entree dans proj',nd1,nd2,ndims
         print*,'le frag i a la ref ioref(i)'
         print*,'proj ioref',ioref(1:nl)
         print*,'jl : orb i appartient au fragment jl(i)'
         print*,'jl         ',jl(1:idf)
c         print*,'nbocs',nbocs(is,1:nl)
c         print*,'nbals',nbals(is,1:nl)
c         print*,'nbocacts',nbocacts(is,1:nl)
c         print*,'nbalacts',nbalacts(is,1:nl)
      endif
      il=0
      if(yw)print*,'vecteur en entree'
      if(yw)call scripto1(u,ndims,idf,ndims,idf,orbi(nd1:nd2))
      nsup(1:nl)=0
      norbl(1:nl)=0
      yz(1:ndims)=.false.
      do i=1,idf
         norbl(jl(i))=norbl(jl(i))+1
      enddo
      if(yw)then
         print*,'le frag il contient norbl(il) orb' 
         print*,'norbl',norbl(1:nl)
      endif
c------------------------------------
c     boucle sur les orb a projeter
c------------------------------------
      do i=1,idf
         ysup=il.ne.jl(i)
         il=jl(i)
         if(yw)print*,'i,il',i,il
         if(il.eq.0) cycle
         if(noproj(il).eq.0) cycle
         if(noproj(il).ne.0) then
            ip=iabs(noproj(il))
            isgn=noproj(il)/ip
            nbp=noproj(il)
          !  nbp=0
          !  do while (ip.ne.0)
          !     ip=ip/nl
          !     nbp=nbp+1
          !  enddo
            allocate (jp(nbp))
            ip=iabs(noproj(il))
c------------------------------------------------------
c           on decode les references de la projection
c------------------------------------------------------
            ysupp(1:nl)=.false.
            jp(1:nbp)=ioproj(1:nbp,il)
          !  do j=1,nbp
          !     jjp=mod(ip,nl)
          !     ip=(ip-jjp)/nl
          !     jp(j)=isgn*jjp
          !  enddo
            if(yw) then
            write(75,*)
     *         'projection de l''orbitale',i,' sur les references',
     *         jp(1:nbp),'$'
               call scril
            endif
c-------------------------------------
c           boucle sur les projections
c-------------------------------------
            do k=1,nbp
c----------------------------------------------------------
c              boucle sur les orb, pour chercher celles qui
c              correspondent a la projection
c----------------------------------------------------------
               do j=1,idf
                  if(ioref(jl(j)).eq.0) cycle
c                  print*,'k,j,jp(k),jl(j),ioref(jl(j))',
c     *            k,j,jp(k),jl(j),ioref(jl(j))
                  if(jp(k).eq.ioref(jl(j))) then
                     if(yw) then
                     write(75,*)'on projette la liaison',jl(i),
     *               'sur la liaison',jl(j),'$'
                     call scril
                     endif
c                    on compte le nombre d'occ suppr
                     ysupp(jl(j))=.true.
                     dp=dot_product(u(:,i),u(:,j))
                     write(6,'(a8,i4,a9,i3,a5,i4,a9,i3,a6,f8.4)')
     *               'orbitale',i,' (liaison',jl(i),
     *               ') sur',j,' (liaison',jl(j),') rec=',dp
                     u(:,i)=u(:,i)-dp*u(:,j)
                     if(yw)call scripto1
     *               (u,ndims,idf,ndims,idf,orbi(nd1:nd2))
c                     anorm=dsqrt(dot_product(u(:,i),u(:,i)))
c                     u(:,i)=u(:,i)/anorm
                  endif
               enddo
            enddo
            deallocate (jp)
         endif
c-------------------------------------------------------
c        a ce niveau
c        ysupp(liaison)=T : la liaison est projetante
c-------------------------------------------------------
         if(yw)print*,'a proj is,il,nbocs,nbals',is,il,
     *   nbocs(is,il),nbals(is,il)
         if(yw)print'(a10)','ysupp'
         if(yw)print'(20l2)',ysupp(1:nl)
         if(yw)print'(a10,20l2)','ysup',ysup
         if(ysup) then
c-------------------------------------------
c        boucle sur les liaisons projetantes
c-------------------------------------------
         do k=1,nl
            if(ysupp(k)) then
               if(yw)write(75,*) 'ref is,k,nbocs+,nbals+',
     *         is,k,nbocs(is,k)+nbocacts(is,k),nbals(is,k)+
     *         nbalacts(is,k),'$'
               if(yw)call scril
               if(yw)print*,'nsup avant son calcul',nsup(1:nl),' k',k
               nsup(il)=nsup(il)+norbl(k)
               if(yw)print*,'nsup apres son calcul',nsup(1:nl),' k',k
            endif
         enddo
         endif
      enddo
      if(yw) then
         print*,'u apres projection'
         call scripto1(u,ndims,idf,ndims,idf,orbi(nd1:nd2))
         print'('' nsup'',20(20i3,/))',nsup(1:nl)
         !print'('' jl'',20(20i3,/))',jl(1:ndims)
      endif
c--------------------------------------
c     S**(-1/2) sur chaque liaison
c--------------------------------------
c     boucle sur les liaisons a orthognaliser
      print'(a61)',
     *'2) orthogonalisation S-1/2 des orbitales liaison par liaison'
      do il=1,nl
         if(noproj(il).eq.0) cycle
         if(nsup(il).eq.0) cycle
         print'(a10,i3)','liaison',il
         n=0
c        on cherche les orbitales de la liaison
         do i=1,idf
            if(jl(i).eq.il) then
               n=n+1
               v(:,n)=u(:,i)
               ir(n)=i
               if(yw)print*,'orb de la liaison',il,' :',i,n
            endif
         enddo
         np=n-nsup(il)
         if(n.eq.0) cycle
         s(1:n,1:n)=matmul(transpose(v(:,1:n)),v(:,1:n))
c         if(yw) then
            print*,'matrice de recouvrement'
            call script(s(1:n,1:n),n,n,n,n)
c         endif
         call hdiag(s(1:n,1:n),ul(1:n,1:n),n,n)
         print'('' valeurs propres'',10f8.4)',(s(i,i),i=1,n)
         print'('' nombre de vecteurs supprimes'',i4)',n-np
         if(yw) then
            print*,'liaison',il,'  valeurs propres',(s(i,i),i=1,n)
            print*,'liaison',il,'  vecteurs propres'
            call script(ul(1:n,1:n),n,n,n,n)
            call scripto1(v(:,1:n),ndims,n,ndims,n,orbi(nd1:nd2))
         endif
         v(:,1:n)=matmul(v(:,1:n),ul(1:n,1:n))
         if(yw)call scripto1(v(:,1:n),ndims,n,ndims,n,orbi(nd1:nd2))
c        normalisation
         do k=1,n
            anor=dot_product(v(:,k),v(:,k))
            v(:,k)=v(:,k)/dsqrt(anor)
         enddo
         if(yw) then
            print*,'v apres norm'
            call scripto1(v(:,1:n),ndims,n,ndims,n,orbi(nd1:nd2))
         endif
c        on remplace
         kk=0
         if(yw)print*,'n,np',n,np
         do k=1,np
            kk=kk+1
            u(:,ir(kk))=v(:,k)
         enddo
         do k=np+1,n
            kk=kk+1
            u(:,ir(kk))=0.d0
            yz(ir(kk))=.true.
         enddo
         if(yw) then
            print'(a5,60l2)','yz',yz(1:ndims)
            print*,'u apres remplacement'
            call scripto1(u,ndims,idf,ndims,idf,orbi(nd1:nd2))
         endif
      enddo
c     on deplace
      do k=1,idf
         if(.not.yz(k)) then
            iop=iop+1
            u(1:ndims,iop)=u(1:ndims,k)
            occup3(iop)=occup3(k)
            tipo(iop)=tipo(k)
         endif
      enddo
      iop=idf-iop
      if(yw) then
         print*,'u apres elimination'
         call scripto1(u,ndims,iop,ndims,iop,orbi(nd1:nd2))
      endif
      deallocate(ir,yz)
      return
      end
