      subroutine orientation2(u,n,orb,v,yor)
      use mod_dolo
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      character(8) orb(n)
      character(4) orbr
      dimension u(n,n)
      dimension v(n,n)
      common/orcom/ o1(3),o2(3),o3(3),norient
      allocatable p(:,:),y(:),vv(:,:),uu(:,:)
      yw=.false.
      if(yw)print*,'entree orientation2'
      yor=.true.
      if(yw)print*,'norient',norient
      if(norient==0) return
      yor=.false.
      allocate(p(n,n),y(n))
      p=1.d20
      if(yw)print*,'matrice densite extraite'
      if(yw)call scripto(u,n,n,n,n,orb)
!
! l'orientation ne marche que pour les p. Il ne faut pas
! d'orbitales d,f,...
!
      do k=1,n
         if(max(index(orb(k)(5:8),'1s'),index(orb(k)(5:8),'2p'))==0)
     *   then
            print*,'orbitale autre que s ou p pour l''orientation'
            print*,orb(k)
            stop
         endif
      enddo
!
! matrice de passage
!
      kk=0
      y=.false.
      ! on fait une boucle sur les OA
      do k=1,n
         ! si l'OA a deja ete trouvee, on saute
         if(y(k)) cycle
         ! on teste si c'est une 1s. dans ce cas la ligne et colonne
         ! correspondantes sont celle d'une matrice unite
         if(orb(k)(5:6)=='1s') then
            if(orient=='ORTH') cycle
            if(yw)print*,'OA 1s trouvee',k,orb(k)
            kk=kk+1
            p(k,kk)=1.d0
            p(1:k-1,kk)=0.d0
            p(k+1:n,kk)=0.d0
            if(yw)print'(a,i4,100f8.4)',
     *      'vecteur de la mat de passage, colonne',kk,p(:,kk)
            cycle
         endif
         ! on teste si c'est une OA 2p
         if(orb(k)(5:6)=='2p') then
            if(yw)print*,'OA 2p trouvee',k,orb(k)
            ! on note l'atome
            orbr=orb(k)(1:4)
            o3=o1
            ! boucle sur nn de 1 a 1 pour un axe, de 1 a 2 pour un plan
            if(yw)print*,'norient',norient
            do nn=1,norient-1
               if(yw)print*,'o3',o3
               kk=kk+1
               p2=0.d0
               ! boucle sur x,y,z
               ntrouv=0
               do l=0,2
                  ! si des p manquent dans les OA pour des raisons de
                  ! symetrie, la boucle ne devait pas se faire de 0 a 2.
                  ! sauter si on a depasse l'atome dont on s'occupe
                  if(yw)print*,'k,kk,l,n',k,kk,l,n
                  if(k+l>n) exit
                  if(orbr/=orb(k+l)(1:4)) exit
                  if(orb(k+l)(5:7)=='2px') then
                     if(yw)print*,'trouve 2px en position',l+1
                     p(k+l,kk)=o3(1)
                     p2=p2+o3(1)*o3(1)
                     y(k+l)=.true.
                     ll=l
                     ind=1
                     ntrouv=ntrouv+1
                  else if (orb(k+l)(5:7)=='2py') then
                     if(yw)print*,'trouve 2py en position',l+1
                     p(k+l,kk)=o3(2)
                     p2=p2+o3(2)*o3(2)
                     y(k+l)=.true.
                     ll=l
                     ind=2
                     ntrouv=ntrouv+1
                  else if (orb(k+l)(5:7)=='2pz') then
                     if(yw)print*,'trouve 2pz en position',l+1
                     p(k+l,kk)=o3(3)
                     p2=p2+o3(3)*o3(3)
                     y(k+l)=.true.
                     ll=l
                     ind=3
                     ntrouv=ntrouv+1
                  endif
               enddo
               if(yw) print*,'ntrouv,p2',ntrouv,p2,dot_product(o3,o3)
               if(ntrouv==1) then
                  ! alors on n'a trouve qu'une seule OA p
                  ! Alors la matrice de passage est carree
                  ! si l'OA est parallele a la direction, OK
                  ! sinon, on supprime la ligne/colonne
!                  if(abs(dot_product(o3,o3)-p2)>1.d-8) print*,
!     *            'OA supprimee'
!                  if(abs(dot_product(o3,o3)-p2)>1.d-8) p2=0.d0
!                  !print*,'o3',o3,dot_product(o3,o3),p2
               endif
               o3=o2
               if(p2<1.d-10) then
                  kk=kk-1
                  if(yw) print*,'kk=kk-1=',kk
                  cycle
               endif
               p(1:k-1,kk)=0.d0
!               print*,'p',kk,p(k:k+2,Kk)
               !exit
               if(k+ll<n)p(k+ll+1:n,kk)=0.d0
               if(yw)print'(a,i4,100f8.4)',
     *         'vecteur de la mat de passage, colonne',kk,p(:,kk)
            enddo
         endif
      enddo
!
! Normalisation
!
      kkk=0
      do k=1,kk
         anorm=dot_product(p(:,k),p(:,k))
!         if(anorm<1.d-8) cycle
         kkk=kkk+1
         p(:,kkk)=p(:,k)/dsqrt(anorm)
      enddo
      kk=kkk
      if(yw)print*,'matrice de passage'
      if(yw)call script(p,n,kk,n,n)
      if(yw)print*,'kk',kk
      !
      ! transformation
      !
      nboc=0
      if(kk>0) then
         allocate(uu(kk,kk))
         allocate(vv(kk,kk))
         uu=matmul(matmul(transpose(p(:,1:kk)),u),p(:,1:kk))
         if(yw)print*,'uu (Pt*u*P)'
         if(yw)call script(uu,kk,kk,kk,kk)
         call hdiag(uu,vv,kk,kk)
         if(yw) print*,'vecteurs propres'
         if(yw)call script(vv,kk,kk,kk,kk)
         v(:,1:kk)=matmul(p(:,1:kk),vv(:,:))
         if(yw)print'(a,/)',
     *         '  occupations, orbitales naturelles'
         if(yw)print'(14x,10f8.4)',(uu(k,k),k=1,kk)
         if(yw)call scripto(v(:,1:kk),n,kk,n,n,orb)
         !
         ! on insere des orbitales bidon a
         ! la place des eliminees entre les
         ! occ et les anti-liantes
         !
         ! On definit la limite des occupees par
         ! la derniere orb de coef>1
         do k=1,kk
            if(uu(k,k)>=1.d0) nboc=k
            if(uu(k,k)<1.d0) then
               nboc=k-1
               exit
            endif
         enddo
         v(:,n-kk+nboc+1:n)=v(:,nboc+1:kk)
         v(:,nboc+1:n-kk+nboc)=0.d0
         kkk=kk
         do k=1,nboc
            u(k,k)=uu(k,k)
         enddo
         do k=n,n-kk+nboc+1,-1
            u(k,k)=uu(kkk,kkk)
            kkk=kkk-1
         enddo
         deallocate(uu,vv)
      endif
      if(yw)print*,'nboc,n,kk',nboc,n,kk
      do k=nboc+1,n-kk+nboc
         u(k,k)=-10.d0
      enddo
      return
      end
