      subroutine orientation(orb,norb)
      use bas
      use mod_sym
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      parameter (maxsym=8)
      character(3000) orb
      character(4) ORIENT
      character(4) c1,c2,c3
      common/orcom/ o1(3),o2(3),o3(3),norient
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      integer virgule(2),multcent(8)
      yw=.false.
      print*,' '
      print*,'===================================================='
      long=len_trim(orb)
      if(yw)print*,'long',long
!
! On cherche les strings "PARA" ou "ORTH"
!
      norient=0
      jj=index(orb,'PARA')
      if(jj/=0)orient='PARA'
      if(jj==0) then
         jj=index(orb,'ORTH')
         if(jj/=0)orient='ORTH'
      endif
      if(jj==0) return
!
! Trouve !
!
      if(yw)print*,trim(orb)
      if(yw)print*,'123456789012345678901234567890123456789'//
     *'01234567890123456789012345678901234567890'
      if(yw)print*,'jj',jj
!
! Dechiffrage des centres donnant l'orientation
!
      ! Mise a blanc de "("
      orb(jj:jj+4)=' '
      ! Recherche de ")"
      kk=index(orb(jj:long),')')+jj-1
      if(yw)print*,'kk',kk
      ! Mise a blanc de ")"
      orb(kk:kk)=' '
      if(yw)print*,orb(1:long)
      ! jj+4,kk est la plage ou les centres donnant l'orientation
      ! sont ecrits  ex : "C4,C6"
      ! on va compter le nb de virgules, il y a un centre de plus (il
      ! y a en fait 3 ou 4 centres)
      norient=1
      virgule=0
      do k=jj+4,kk
         if(orb(k:k)==',') then
            virgule(norient)=k
            norient=norient+1
            orb(k:k)=' '
         endif
      enddo
      if(virgule(2)==0) virgule(2)=kk
      if(yw)print*,'virgule',virgule
      if(yw)print*,'norient',norient
      if(norient/=2.and.norient/=3) then
         print*,'erreur pour' ,orient
         stop
      endif
      if(yw)print*,'natom',natom
      do k=1,natom1
      if(yw)print'(a12,3f12.8)',atom(k),coor(:,k)
      enddo
!
! On cherche les coordonnees des centres 
!
      c1=' '
      c2=' '
      c3=' '
      if(yw)print*,'jj+4',jj+4,kk
      c1=orb(jj+4:virgule(1)-1)
      c2=orb(virgule(1)+1:virgule(2))
      if(norient==3) c3=orb(virgule(2)+1:kk)
!      if(norient==2) read(orb(jj+4:kk),'(2a)') c1,c2
!      if(norient==3) read(orb(jj+4:kk),'(3a)') c1,c2,c3
      c1=adjustl(c1)
      c2=adjustl(c2)
      c3=adjustl(c3)
      if(yw)print*,'c1,c2,c3 ',c1,c2,c3
      if(yw)print*,'c1 ',c1,'..'
      ! 1er centre
      if(c1=='0') then
         o1=0.d0
      else
         ytrouve=.false.
         do k=1,natom
            if(yw)print*,atom(k)
            if(c1==atom(k)) then
               ytrouve=.true.
               o1=coor(:,k)
               exit
            endif
         enddo
         if(.not.ytrouve) then
            print*,'centre non trouve ',c1
            stop
         endif
      endif
      if(yw)print*,'c2 ',c2,'..'
      if(yw)print*,'l',len_trim(c2)
      ! 2eme centre
      if(c2=='0') then
         o2=0.d0
      else
         ! on cherche tous les centres de nom c2,
         ! puis on garde celui plus pres de c1
         nmultcent=0
         ytrouve=.false.
         do k=1,natom1
            if(yw)print*,atom(k),len_trim(atom(k))
            if(c2==atom(k)) then
               o2=coor(:,k)
               if(yw)print*,'o2',o2
               if(yw)print*,'o1',o1
               if(all(o2==o1)) cycle
               if(yw)print*,'coucou'
               ytrouve=.true.
               nmultcent=nmultcent+1
               multcent(nmultcent)=k
            endif
         enddo
         if(.not.ytrouve) then
            print*,'centre non trouve ',c2
            stop
         endif
         if(nmultcent>1) then
            d0=1.d10
            i=0
            do k=1,nmultcent
               j=multcent(k)
               d=dsqrt((o1(1)-coor(1,j))**2
     *         +(o1(2)-coor(2,j))**2
     *         +(o1(3)-coor(3,j))**2)
               if(yw)print*,'k,d',k,d
               if(yw)  print*,'k,d',coor(:,j)
               if(d<d0) then
                  d0=d
                  i=j
               endif
            enddo
            o2=coor(:,i)
         endif
      endif
      if(yw)print*,c3,'c3 ','..'
      if(c3/=' ') then
         ytrouve=.false.
         if(c3=='0') then
            o3=0.d0
         else
            do k=1,natom
               if(yw)print*,atom(k)
               if(c3==atom(k)) then
                  ytrouve=.true.
                  o3=coor(:,k)
                  exit
               endif
            enddo
            if(.not.ytrouve) then
               print*,'centre non trouve ',c3
               stop
            endif
         endif
      endif
      print*,'Orientation obligatoire des orbitales'
      print*,'Donnee ',orient
      if(norient==2) then
              print*,'Axe defini en donnee par'
      else
              print*,'Plan defini en donnee par'
      endif
      print'(a,3f12.8)',c1,o1
      print'(a,3f12.8)',c2,o2
      if(norient==3)print'(a,3f12.8)',c3,o3
!
! vecteur(s) d'orientation
!
      print*,'vecteur(s) d''orientation'
      o1=o2-o1
      ! normalisation
      o1=o1/dsqrt(dot_product(o1,o1))
      print'(2a,3f12.8)',c1,c2,o1
      if(c3/=' ') then
         o2=o3-o2
         ! orthogonalisation par projection
         o2=o2-dot_product(o1,o2)*o1
         anorm=dot_product(o2,o2)
         if(anorm<1.d-8) then
            print*,c1//'- '//c2//'  et  '//c2//' - '//c3//
     *      ' sont paralleles'
            stop
         endif
         ! normalisation
         o2=o2/dsqrt(anorm)
         print'(2a,3f12.8)',c2,c3,o2
      endif
!
! orient='ORTH'
!
      if(orient=='ORTH') then
         if(norient==2) then
            print*,'plan des orbitales defini par les vecteurs :'
            ! on construit 2 vecteurs orthogonaux a o1
            o3=o1
            if(abs(o3(1))>1.d-1.or.abs(o3(2))>1.d-1) then
               o1(3)=0.d0
               o1(1)=o3(2)
               o1(2)=-o3(1)
            else
               o1(1)=0.d0
               o1(2)=o3(3)
               o1(3)=-o3(2)
            endif
            ! normalisation
            o1=o1/dsqrt(dot_product(o1,o1))
            ! o2 obtenu par produit vectoriel
            o2(1)=o1(2)*o3(3)-o1(3)-o3(2)
            o2(2)=o1(1)*o3(3)-o1(3)-o3(1)
            o2(3)=o1(2)*o3(1)-o1(1)-o3(2)
            ! o2 est orthogonalise a o1
            o2=o2-dot_product(o1,o2)*o1
            o2=o2/dsqrt(dot_product(o2,o2))
            print'(3f12.8)',o1
            print'(3f12.8)',o2
            norient=3
         else
            print*,'axe des orbitales defini par le vecteur :'
            ! on construit 1 vecteur orthogonal a o1 et o2
            o3=o1
            o1(1)=o2(3)*o3(2)-o2(2)*o3(3)
            o1(2)=o2(1)*o3(3)-o2(3)*o3(1)
            o1(3)=o2(2)*o3(1)-o2(1)*o3(2)
            print'(3f12.8)',o1
            norient=2
         endif
      endif

!
! Y a-t-il des centres avec des p manquantes ?
!
      if(norient==3) then
         kk=0
         yx=.true.
         yy=.true.
         yz=.true.
         if(yz) then
            do is=1,nsym
               if(yw)print*,'is',is
               do k=1,isym(is)
                  kk=kk+1
                  !print*,'orbi',kk,orbi(kk)
                  if(orbi(kk)(5:6)=='2p') then
!                    Correction de 2 lignes : orbi(kk+1) introduit une
!                    erreur sur certans compilos, si kk==valeur max
!                    idem pour orbi(kk-1) si kk==1
!                    if((kk==isym(is).or.orbi(kk+1)(1:6)/=orbi(kk)(1:6))
!    *               .and.(kk==1.or.orbi(kk-1)(1:6)/=orbi(kk)(1:6)))then
                     ytest1=kk==isym(is)
                     if(.not.ytest1) ytest1=
     *               orbi(kk+1)(1:6)/=orbi(kk)(1:6)
                     ytest2=kk==1
                     if(.not.ytest2) ytest2=
     *               orbi(kk-1)(1:6)/=orbi(kk)(1:6)
                     ytest=ytest1.and.ytest2
                     if(ytest) then
!                    fin de la correction
                        if(yw)print*,'p seule'
                        ! rotation o1/o2
                        if(orbi(kk)(7:7)=='x') then
                           if(yw)print*,'axe 2pz'
                           if(yx) then
                              yx=.false.
                              if(abs(o1(1)-1.d0)>1.d-8) then
                                 o3=o1
                                 o1=o2
                                 o2=o3
                              endif
                              o1(3)=0.d0
                              o1=o1/dsqrt(dot_product(o1,o1))
                              o2=o2-dot_product(o1,o2)*o1
                              o2=o2/dsqrt(dot_product(o2,o2))
                           endif
                        else if(orbi(kk)(7:7)=='y') then
                           if(yw)print*,'axe 2pz'
                           if(yy) then
                              yy=.false.
                              if(abs(o1(2)-1.d0)>1.d-8) then
                                 o3=o1
                                 o1=o2
                                 o2=o3
                              endif
                              o1(3)=0.d0
                              o1=o1/dsqrt(dot_product(o1,o1))
                              o2=o2-dot_product(o1,o2)*o1
                              o2=o2/dsqrt(dot_product(o2,o2))
                           endif
                        else if(orbi(kk)(7:7)=='z') then
                           if(yw)print*,'axe 2pz'
                           if(yz) then
                              yz=.false.
                              if(abs(o1(3)-1.d0)>1.d-8) then
                                 o3=o1
                                 o1=o2
                                 o2=o3
                              endif
                              o1(3)=0.d0
                              o1=o1/dsqrt(dot_product(o1,o1))
                              o2=o2-dot_product(o1,o2)*o1
                              o2=o2/dsqrt(dot_product(o2,o2))
                           endif
                        endif
                     endif
                  endif
               enddo
            enddo
            print*,'vecteurs reorientes suivant les axes'
            print'(3f12.8)',o1
            print'(3f12.8)',o2
         endif
      endif
      print*,' '
      print*,'Orientation obligatoire : '
      print*,'les orbitales eliminees sont remplacees par des '//
     *'orbitales nulles d''occupation 1.'
      print*,' '
      print*,'===================================================='
      print*,' '
      return
      end
!**********************************************************************
!**********************************************************************
!**********************************************************************
!**********************************************************************
      subroutine orientation2(u,n,orb,v,yor)
      use bas
      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 or2'
      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(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
