!      subroutine hier3(a,n,npri,n1,n2,n3,s,ior1,ior2,ior3)
!      implicit real(8)(a-h,o-x,z),logical(1)(y)
!      dimension a(n,n),s(n,n)
!      dimension npri(n)
!      double precision,allocatable,dimension(:,:) :: b,c,d
!      logical,allocatable,dimension(:) :: y
!      logical,allocatable,dimension(:) :: h
!      integer,allocatable,dimension(:) :: i1,i2
!      logical no_last_ort
!      yw=.false.
!      m1=n2-n1
!      m2=n3-n2
!      allocate (b(n,m1))
!      allocate (c(n,m2))
!      allocate (y(n))
!      allocate(i1(m1),i2(m2))
!      if(yw)print*,'hier3 ior1,ior2,ior3',ior1,ior2,ior3
!      if(yw)print*,'hier3 n1,n2,n3',n1,n2,n3
!      if(yw)print*,'hier3 m1,m2',m1,m2
!      if(yw)print*,'hier3 npri',npri
!      i1=npri(n1+1:n2)
!      i2=npri(n2+1:n3)
!      b(:,:)=a(:,i1(1:m1))
!      c(:,:)=a(:,i2(1:m2))
!      !======================
!      !S-1/2 sur les 1ere orb
!      !======================
!      if(ior1==1) then
!         if(yw)print*,'i1',i1
!         if(yw)print*,'i2',i2
!         if(yw)print*,'b'
!         if(yw)call script(b,n,m1,n,m1)
!         if(yw)print*,'c'
!         if(yw)call script(c,n,m2,n,m2)
!         call smud_bib(b,n,m1,s)
!         if(yw)print*,'b apres smud_bib'
!         if(yw)call script(b,n,m1,n,m1)
!         allocate(d(m1,m1))
!         d=matmul(transpose(b),matmul(s,b))
!         if(yw)print*,'verif b'
!         if(yw)call script(d,m1,m1,m1,m1)
!         deallocate(d)
!         !on recompose a
!         a(:,i1(1:m1))=b(:,:)
!         allocate(d(n,n))
!         d=matmul(transpose(a),matmul(s,a))
!         if(yw)print*,'verif A1'
!         if(yw)call script(d,n,n,n,n)
!         deallocate(d)
!         !print*,'a1',a(1,111:112)
!      endif
!      !======================
!      !Projection schmidt
!      !======================
!!      if(m2.eq.0.or.no_last_ort) then
!!         a(:,i1(1:m1))=b(:,:)
!!         return
!!      endif
!      if(ior2==1) then
!         y=.false.
!         y(npri(1:n2))=.true.
!         do k=1,m2
!            do l=1,n
!               if(y(l))
!     *         c(:,k)=c(:,k)-dot_product(c(:,k),matmul(s,a(:,l)))*a(:,l)
!            enddo
!         enddo
!         if(yw)print*,'hier3 c proj'
!         if(yw)call script(c,n,m2,n,m2)
!         allocate(d(m1,m2))
!         d=matmul(transpose(b),matmul(s,c))
!         if(yw)print*,'hier3 verif bc'
!         if(yw)call script(d,m1,m2,m1,m2)
!         deallocate(d)
!         !normalisation
!         do k=1,m2
!            anorm=dot_product(c(:,k),matmul(s,c(:,k)))
!            c(:,k)=c(:,k)/dsqrt(anorm)
!         enddo
!         if(yw)print*,'hier3 c proj norm'
!         if(yw)call script(c,n,m2,n,m2)
!         a(:,i2(1:m2))=c(:,:)
!         !print*,'a2',a(1,111:112)
!      endif
!      !======================
!      !s-1/2 sur les 2eme orb
!      !======================
!      if(ior3==1) then
!         call smud_bib(c,n,m2,s)
!         allocate(d(m2,m2))
!         d=matmul(transpose(c),matmul(s,c))
!         if(yw)print*,'hier3 verif c'
!         if(yw)call script(d,m2,m2,m2,m2)
!         deallocate(d)
!         allocate(d(m1,m1))
!         d=matmul(transpose(a(:,m2+1:m1+m2)),matmul(s,a(:,m2+1:m1+m2)))
!         if(yw)print*,'hier3 reverif b'
!         if(yw)call script(d,m1,m1,m1,m1)
!         deallocate(d)
!         !on recompose a
!         a(:,i2(1:m2))=c(:,:)
!            !print*,'a3',a(1,111:112)
!         allocate(d(n,n))
!         d=matmul(transpose(a),matmul(s,a))
!         if(yw)print*,'hier3 verif a'
!         if(yw)call script(d,n,n,n,n)
!         deallocate(d)
!      endif
!      deallocate (c)
!      deallocate (b)
!      deallocate (y)
!      deallocate(i1,i2)
!      if(yw)print*,'sortie hier3'
!      return
!      end
!       subroutine smud_bib(a,n,m,s)
!!
!!---------------------------------------------------------------
!!     subroutine d'orthogonalisation par s-1/2
!!     a (en donnee) sont les vecteurs non orth
!!     exprimes dans une base non orthogonale
!!     a1 (en sortie) sont les vec orthogonaux, dans la meme base
!!     s est la matrice de recouvrement de la base
!!---------------------------------------------------------------
!!       
!      implicit real(8)(a-h,o-x,z),logical(1)(y)
!      double precision,allocatable,dimension(:,:) :: u1,v,s1,s0,a1
!      dimension a(n,m),s(n,n)
!      nprint=0
!      yw=.false.
!      if(yw)print*,'entree hier2'
!      if(n.eq.0) return
!      allocate (v(n,n))
!      allocate (a1(n,m))
!      allocate (s1(n,n))
!      allocate (s0(n,n))
!      s0=s
!      if(nprint.ge.3) print*,'n',n
!      if(nprint.ge.3) print*,'a'
!      if(nprint.ge.3) call script(a,n,m,n,m)
!c
!c     on se fait une base orthogonale
!c
!      if(yw) then
!         allocate (u1(m,m))
!         print*,'recou a 1 '
!         u1=matmul(transpose(a),matmul(s,a))
!         call script(u1,m,m,m,m)
!         deallocate (u1)
!      endif
!      call hdiag(s,v,n,n)
!      s1=0.d0
!      do k=1,n
!         s1(k,k)=dsqrt(s(k,k))
!         s(k,k)=1.d0/dsqrt(s(k,k))
!      enddo
!      if(yw)print*,'S'
!      if(yw)call script(s,n,n,n,n)
!      if(yw)print*,'S1'
!      if(yw)call script(s1,n,n,n,n)
!      s=matmul(v,matmul(s,transpose(v)))
!      s1=matmul(v,matmul(s1,transpose(v)))
!      !u1=matmul(s,s1)      
!c
!c     a exprime dans la base orthogonale
!c
!      a=matmul(s1,a)
!      if(yw)print*,'s'
!      if(yw)call script(s,n,n,n,n)
!      if(yw)print*,'s1'
!      if(yw)call script(s1,n,n,n,n)
!      if(yw)print*,'a'
!      if(yw)call script(a,n,m,n,m)
!      if(yw) then
!         allocate (u1(m,m))
!         print*,'recou a 2 '
!         u1=matmul(transpose(a),a)
!         call script(u1,m,m,m,m)
!         deallocate (u1)
!      endif
!c
!c     orthogonalisation de a
!c
!      call smudo_bib(n,m,a1,a)
!      if(yw) then
!         allocate (u1(m,m))
!         print*,'recou a1 '
!         u1=matmul(transpose(a1),a1)
!         call script(u1,m,m,m,m)
!         deallocate (u1)
!      endif
!c
!c        on repasse dans la base non orthogonale
!c
!      a=matmul(s,a1)
!      s=s0
!      deallocate (v)
!      deallocate (s1)
!      deallocate (a1)
!      deallocate (s0)      
!      return
!      end
!       subroutine smudo_bib(n,m,a1ext,aext)
!      implicit real(8)(a-h,o-x,z),logical(1)(y)
!      dimension aext(n,m),a1ext(n,m)
!c
!c---------------------------------------------------------------
!c     subroutine d'orthogonalisation par s-1/2
!c     a (en donnee) sont les vecteurs non orth
!c     donnes dans une base ORTHOGONALE
!c     a1 (en sortie) sont les vec orthogonaux, dans la meme base
!c---------------------------------------------------------------
!c
!      if(n.eq.0) return
!      call smudo1_bib(n,m,a1ext,aext)
!      return
!      end
!      
!       subroutine smudo1_bib(n,m,a1ext,aext)
!      implicit real(8)(a-h,o-x,z),logical(1)(y)
!      dimension aext(n,m),a1ext(n,m)
!      double precision,allocatable,dimension(:,:) :: a,s,vs,a0,s1
!      allocate (a(n,m),s(m,m),vs(m,m),a0(n,m),s1(n,m))
!      yverif=.false.
!      nprint=0
!      if(nprint.ge.3) print*,'N',n
!      a=aext
!      if(nprint.ge.3) print*,'a'
!      if(nprint.ge.3) call script(a,n,n,n,n)
!      do k=1,m
!         anor=0.D0
!         do l=1,n
!            anor=anor+a(l,k)*a(l,k)
!         enddo
!         anor=dsqrt(anor)
!         do l=1,n
!            a(l,k)=a(l,k)/anor
!         enddo
!      enddo
!      if(nprint.ge.3) print*,'a norm'
!      a0=a
!      if(nprint.ge.3) call script(a,n,n,n,n)
!c      call hdiag(a,v,n,n)
!      if(nprint.ge.3) print*,'N',n
!c      call jacobi(n,a,v,n)
!      if(nprint.ge.3) print*,'n',n
!      if(nprint.ge.3) print*,'a diag'
!      if(nprint.ge.3) call script(a,n,n,n,n)
!      if(nprint.ge.3) print*,'vp'
!      if(nprint.ge.3) call script(v,n,n,n,n)
!      s=matmul(transpose(a0),a0)
!      if(nprint.ge.3) print*,'s'
!      if(nprint.ge.3) call script(s,n,n,n,n)
!      call hdiag(s,vs,m,m)
!c      call jacobi(n,s,vs,n)
!      if(nprint.ge.3) print*,'s diag'
!      if(nprint.ge.3) call script(s,n,n,n,n)
!      if(nprint.ge.3) print*,'vp'
!      if(nprint.ge.3) call script(vs,n,n,n,n)
!      do k=1,m
!         s(k,k)=1.d0/dsqrt(s(k,k))
!      enddo
!      vs=matmul(vs,matmul(s,transpose(vs)))
!      if(nprint.ge.3) print*,'s-1/2 vect orth'
!      if(nprint.ge.3) call script(vs,n,n,n,n)
!c      vs=matmul(transpose(a),matmul(vs,(a)))
!      s1=matmul(a0,vs)
!      if(nprint.ge.3) print*,'S-1/2 vect orth dans base orth'
!      if(nprint.ge.3) call script(s1,n,m,n,m)
!      if(yverif) then
!         vs=matmul(transpose(s1),s1)
!         if(nprint.ge.3) print*,'verif prod scal'
!         if(nprint.ge.3) call script(vs,m,m,m,m)
!      endif
!      a1ext=s1
!      deallocate (a,s,vs,a0,s1)
!      return
!      end
      
!*********************************************************
!*********************************************************
!*********************************************************
!*********************************************************
      subroutine hier3(a,n,npri,n1,n2,n3,s,ior1,ior2,ior3)
      use mod_script
!
!-------------------------------------------------------------
!     subroutine d'orthogonalisation des vecteurs de 2 espaces 
!     
!     a : matrice des vecteurs en entree. dimension a(n,n)
!     
!   ------------------------------
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |      a         |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!     |     |                |
!   ------------------------------
!    n1    n2               n3
!     
!     vecteurs prioritaires: n1+1 a n2
!     vecteurs secondaires : n2+1 a n3
!
!     en fait, il y a un vecteur d'entiers npri, qui fait que les
!     vecteurs peuvent arriver dans n'importe quel ordre. Les vecteurs
!     prioritaires sont ceux correspondant aux 1eres valeurs de npri.
!     ex: si n1==0,n2==2, npri=3,6,1,2,4..., les vecteurs prioritaires
!     sont les vecteurs 3 et 6 de a.
!
!     s est la matrice de recouvrement entre OA (base dans laquelle
!     est exprime a)
!
!     Le processus normal est:
!     1. S-1/2 sur les vecteurs prioritaires
!     2. Schmidt des secondaires sur les prioritaires
!     3. S-1/2 sur les vecteurs secondaires
!     normalement ior1==1, ior2==1, ior3==1
!     si ior_i==0, on ne fait pas l'etape _i
!
!     en sortie: vecteurs orthogonaux sur a (remplaces)
!
!
!-------------------------------------------------------------
!
      implicit real(8)(a-h,o-x,z),logical(1)(y)
      dimension a(n,n),s(n,n)
      dimension npri(n)
      double precision,allocatable,dimension(:,:) :: b,c,d,work
      logical,allocatable,dimension(:) :: y
      logical,allocatable,dimension(:) :: h
      integer,allocatable,dimension(:) :: i1,i2
      logical no_last_ort
      yw1=.false.
      yw=.false.
      if(yw) print'(/,a,/)','*********entree hier3*********'
      m1=n2-n1
      m2=n3-n2
      allocate (b(n,m1))
      allocate (c(n,m2))
      allocate (y(n))
      allocate(i1(m1),i2(m2))
      if(yw1)print*,'hier3: options d''orthogonalisations'
     *,ior1,ior2,ior3
      if(yw1)print*,'hier3: bornes',n1,n2,n3
      if(yw1)print*,'hier3: tailles des 2 espaces',m1,m2
      if(yw1)write(6,'(a)',advance='NO')
     *'hier3 vecteurs prioritaires'
      if(yw1)print'(20i4)',npri(1:m1)
      if(yw1)write(6,'(a,100i4)',advance='NO')
     *'hier3 vecteurs secondaires'
      if(yw1)print'(20i4)',npri(m1+1:m2)
      !if(yw)print*,'mat de rec entre OA S a l''entree de hier3'
      !if(yw) call script(s,n,n,n,n)
      i1=npri(n1+1:n2)
      i2=npri(n2+1:n3)
      b(:,:)=a(:,i1(1:m1))
      c(:,:)=a(:,i2(1:m2))
      !======================
      !S-1/2 sur les 1ere orb
      !======================
      if(ior1==1) then
         allocate(work(n,n))
         if(yw1) print*,' '
         if(yw1) print*,'******Etape 1: S-1/2 sur les 1ere orb*******'
         if(yw1) print*,' '
         if(yw1)print*,'b  1eres Ol, a orthogonaliser par S-1/2'
         if(yw)call script(b,n,m1,n,m1)
         call smud_bib_2(b,n,m1,s)
         if(yw1)print*,'b apres smud_bib  1ere OL orthogonalisees'
         if(yw)call script(b,n,m1,n,m1)
         !
         ! VERIF: rec

         allocate(d(m1,m1))
         work(:,1:m1)=matmul(s,b)
         d=matmul(transpose(b),work(:,1:m1))
         !d=matmul(transpose(b),matmul(s,b))
         if(yw1)print*,'verif b  recouvrement entre les 1eres orb'
         if(yw)call script(d,m1,m1,m1,m1)
         deallocate(d)

         !on recompose a
         a(:,i1(1:m1))=b(:,:)

         !VERIF: rec des vecteurs de a
         allocate(d(n,n))
         work(:,1:m1)=matmul(s,b)
         d=matmul(transpose(b),work)

         !d=matmul(transpose(a),matmul(s,a))
         if(yw1)print*,
     *   'verif A1  (rec entre OL apres S-1/2 sur les 1eres orbitales'
         if(yw)call script(d,n,n,n,n)
         deallocate(d,work)
      endif
      !======================
      !Projection schmidt
      !======================

      if(ior2==1) then
         if(yw1) print*,' '
         if(yw1) print*,'***********Etape 2: Projection schmidt********'
         if(yw1) print*,' '

         ! PROJECTION
         y=.false.
         y(npri(1:n2))=.true.
         allocate(work(n,n))
         do l=1,n
            if(y(l)) then
               work(:,l)=matmul(s,a(:,l))
            endif
         enddo
         do k=1,m2
            do l=1,n
               if(y(l))
     *         c(:,k)=c(:,k)-dot_product(c(:,k),work(:,l))*a(:,l)
     *         !c(:,k)=c(:,k)-dot_product(c(:,k),matmul(s,a(:,l)))*a(:,l)
            enddo
         enddo
         if(yw1)print*,'hier3 c proj  (2emes OL apres projection)'
         if(yw)call script(c,n,m2,n,m2)

         !NORMALISATION
         do k=1,m2
            anorm=dot_product(c(:,k),matmul(s,c(:,k)))
            c(:,k)=c(:,k)/dsqrt(anorm)
         enddo
         if(yw1)print*,'hier3 (2emes OL apres projection, normalisees)'
         if(yw)call script(c,n,m2,n,m2)

         !transfert dans la matrice d'entree:
         a(:,i2(1:m2))=c(:,:)
         
         ! VERIF: Produit scalaire dans a
         allocate(d(n,n))
         d=matmul(s,a)
         d=matmul(transpose(a),d)
         if(yw1)print*,'hier3 verif : rec entre OL apres Schmidt'
         if(yw)call script(d,n,n,n,n)
         deallocate(d,work)
      endif
      !======================
      !s-1/2 sur les 2eme orb
      !======================
      if(ior3==1) then
         if(yw1) print*,' '
         if(yw1) print*,'******Etape 3: S-1/2 sur les 2eme orb*******'
         if(yw1) print*,' '
         call smud_bib_2(c,n,m2,s)
         if(yw1) print*,'******fin 3: S-1/2 sur les 2eme orb*******'

         !VERIF: Produit scalaire entre les 2eme vecteurs orthogonalises
         allocate(d(m2,m2))
         allocate(work(n,m2))
         work(:,1:m2)=matmul(s,c)
         d=matmul(transpose(c), work(:,1:m2))
         !d=matmul(transpose(c),matmul(s,c))
         if(yw1)print*,
     *   'hier3 verif Produit scalaire entre 2eme vecteurs'
         if(yw)call script(d,m2,m2,m2,m2)
         deallocate(d)

         !ON RECOMPOSE a
         a(:,i2(1:m2))=c(:,1:m2)
         if(yw)print*,' '
         if(yw1)print*,'hier3: vecteurs orthogonaux'
         if(yw) call mscript(a)


         !VERIF: Produit scalaire entre les vecteurs orthogonalises
         allocate(d(n,n))
         !d=matmul(transpose(a),matmul(s,a))
         d=matmul(s,a)
         d=matmul(transpose(a),d)
         if(yw)print*,'hier3 verif Produit scalaire entre les vecteurs'
         if(yw)call script(d,n,n,n,n)
         aa=0.d0
         do i=1,n
            do j=1,i-1
               aa=max(aa,abs(d(i,j)))
            enddo
         enddo
         if(yw)print*,'smud: valeur extradiagonale max:',aa
         aa=0.d0
         do i=1,n
            aa=max(aa,abs(1.d0-d(i,i)))
         enddo
         if(yw)print*,'smud: valeurs diagonales: ecart max a 1:',aa
         deallocate(d,work)
      endif
      deallocate (c)
      deallocate (b)
      deallocate (y)
      deallocate(i1,i2)
      if(yw)print*,'*********sortie hier3*********'
      if(yw)print*,' '
      return
      end
!*********************************************************
      subroutine smud_bib_2(a,n,m,s)
      use mod_script
!
!---------------------------------------------------------------
!     subroutine d'orthogonalisation par s-1/2
!     a (en donnee) sont les vecteurs non orth
!     exprimes dans une base non orthogonale
!     a1 (en sortie) sont les vec orthogonaux, dans la meme base
!     s est la matrice de recouvrement de la base
!---------------------------------------------------------------
!       
      implicit real(8)(a-h,o-x,z),logical(1)(y)
      double precision,allocatable,dimension(:,:) :: u1,v,s1,s0,a1,work
      dimension a(n,m),s(n,n)
      allocate(work(n,n))
      nprint=0
      yw=.false.
      yw1=.false.
      if(yw1) print*,' '
      if(yw1)print*,'**********entree smud_bib**********'
      if(yw1) print*,' '
      if(n.eq.0) return
      if(yw1) print*,'smud: m,n',m,n
      if(m==0) return
      if(yw1) print*,'smud: a (OL en entree)'
      if(yw) call script(a,n,m,n,m)

      ! Recouvrement S1 entre les vecteurs en entree
      allocate (s1(m,m))
      work(:,1:m)=matmul(s,a)
      s1=matmul(transpose(a),work(:,1:m))
      !s1=matmul(transpose(a),matmul(s,a))
      if(yw1) print*,' '
      if(yw1) print*,'smud: Recouvrement entre les vecteurs en entree'
      if(yw)call mscript(s1)
      ! Verif: vecteurs dependants?
      aa=0.d0
      do i=1,m
         do j=1,i-1
            if(aa<=abs(s1(i,j))) then
               ii=i
               jj=j
               aa=abs(s1(i,j))
            endif
         enddo
      enddo
      if(yw)print*,'smud: valeur extradiagonale max ds la mat de rec:'
     *,ii,jj,aa
      if(yw)call mscript(transpose(a(:,(/ii,jj/))))
      if(yw) then
         do i=1,n
            if(abs(a(i,ii))>0.01.or.abs(a(i,jj))>0.01) 
     *      print'(i4,2f12.8)',i,a(i,ii),a(i,jj)
         enddo
         !do i=1,m
         !   print'(i4,2f12.8)',i,a(i,ii),a(i,jj)
         !enddo
      endif
      aa=0.d0
      do i=1,m
         if(aa<=abs(1.d0-s1(i,i))) then
            ii=i
            aa=abs(1.d0-s1(i,i))
         endif
      enddo
      if(yw)print*,'smud: valeurs diagonales: ecart max a 1:',ii,aa

      ! Calcul de S1**-1/2)
      allocate (v(m,m))
      call hdiag_L(s1,v,m,m)
      if(yw1)print*,'vecteurs propres de S1'
      if(yw)call mscript(v)
      if(yw1)print*,' '
      if(yw1)print*,'smud: S1 diagonalise)'
      if(yw1)print*,' '
      if(yw1)print'(10f8.4)',(s1(k,k),k=1,m)
      if(yw1)print*,' '
      do k=1,m
         s1(k,k)=1.d0/dsqrt(s1(k,k))
      enddo
      if(yw1)print*,'smud: S1 (1/sqrt(s1 diagonalise))'
      if(yw1)print*,' '
      if(yw1)print'(10f8.4)',(s1(k,k),k=1,m)
      if(yw1)print*,' '
      s1=matmul(s1,transpose(v))
      s1=matmul(v,s1)
      !s1=matmul(v,matmul(s1,transpose(v)))
      if(yw1)print*,'smud: S1**-1/2'
      if(yw)call mscript(s1)

      ! vecteurs orthogonalises: produit a*S1-1/2
      a=matmul(a,s1)
      if(yw1)print*,'smud: vecteurs orthogonalises'
      if(yw)call mscript(a)

      ! VERIF: produit scalaire entre les vecteurs orthogonalises
      if(yw1)print*,'smud: ',
     *'VERIF: produit scalaire entre les vecteurs orthogonalises'
      work(:,1:m)=matmul(s,a)
      s1=matmul(transpose(a),work(:,1:m))
      !s1=matmul(transpose(a),matmul(s,a))
      if(yw)call mscript(s1)
      aa=0.d0
      do i=1,m
         do j=1,i-1
            aa=max(aa,abs(s1(i,j)))
         enddo
      enddo
      if(yw1)print*,'smud: valeur extradiagonale max:',aa
      aa=0.d0
      do i=1,m
         aa=max(aa,abs(1.d0-s1(i,i)))
      enddo
      if(yw1)print*,'smud: valeurs diagonales: ecart max a 1:',aa
      if(yw1) print*,' '
      if(yw1)print*,'**********sortie smud_bib**********'
      if(yw1) print*,' '
      deallocate(work)
      end
      
      
      
      
      
      
      
      
      
      
