      subroutine hier2(a,n,m,i1,s)
      implicit real(8)(a-h,o-x,z),logical(1)(y)
      dimension a(n,n),i1(m),s(n,n)
      double precision,allocatable,dimension(:,:) :: b,c
      logical,allocatable,dimension(:) :: h
      integer,allocatable,dimension(:) :: i2
      yw=.false.
      allocate (b(n,m))
      !S-1/2 sur les 1ere orb
      n2=n-m
      allocate (i2(n2))
      allocate (c(n,n2))
      call comple(n,(/(k,k=1,n)/),m,i1,n2,i2)
      if(yw)print*,'i1',i1(1:m)
      if(yw)print*,'i2',i2(1:n2)
      b(:,:)=a(:,i1(1:m))
      c(:,:)=a(:,i2(1:n2))
      if(yw)print*,'b'
      if(yw)call script(b,n,m,n,m)
      if(yw)print*,'c'
      if(yw)call script(c,n,n2,n,n2)
      call smud_bib(b,n,m,s)
      if(yw)print*,'b apres smud_bib'
      if(yw)call script(b,n,m,n,m)
      !Projection schmidt
      if(n2.eq.0) then
         a=b
         return
      endif
      do k=1,n2
         do l=1,m
         c(:,k)=c(:,k)-dot_product(c(:,k),matmul(s,b(:,l)))*b(:,l)
         enddo
      enddo
      if(yw)print*,'c proj'
      if(yw)call script(c,n,n2,n,n2)
      !normalisation
      do k=1,n2
         anorm=dot_product(c(:,k),matmul(s,c(:,k)))
         c(:,k)=c(:,k)/dsqrt(anorm)
      enddo
      if(yw)print*,'c proj norm'
      if(yw)call script(c,n,n2,n,n2)
      !s-1/2 sur les 2eme orb
      call smud_bib(c,n,n2,s)
      !on recompose a
      a(:,i1(1:m))=b(:,:)
      deallocate (b)
      allocate (h(n))
      h=.true.
      h(i1)=.false.
      l=0
      do k=1,n
         if(h(k)) then
            l=l+1
            i2(l)=k
         endif
      enddo
      a(:,i2(1:n2))=c(:,:)
      deallocate (c,h,i2)
      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))
      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
      
      
      
      
