      subroutine hier4(a8,n,npri,n1,n2,n3,s8,iter)
      implicit real(16)(a-h,o-x,z),logical(1)(y)
      dimension npri(n)
      real(16),allocatable,dimension(:,:) :: b,c,d
      logical,allocatable,dimension(:) :: y
      logical,allocatable,dimension(:) :: h
      integer,allocatable,dimension(:) :: i1,i2
      logical no_last_ort
      real(8) a8(n,n),s8(n,n)
      real(16),allocatable,dimension(:,:) :: a,s
      yw=.false.
      allocate(a(n,n),s(n,n))
      do i=1,n
         do j=1,n
            a(j,i)=a8(j,i)
            s(j,i)=s8(j,i)
         enddo
      enddo
      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*,'n1,n2,n3',n1,n2,n3
      if(yw)print*,'m1,m2',m1,m2
      if(yw)print*,'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(iter==1) then
         if(yw)print*,'i1',i1
         if(yw)print*,'i2',i2
         if(yw)print*,'b'
         if(yw)call script4(b,n,m1,n,m1)
         if(yw)print*,'c'
         if(yw)call script4(c,n,m2,n,m2)
         call smud_bib4(b,n,m1,s)
         if(yw)print*,'b apres smud_bib4'
         if(yw)call script4(b,n,m1,n,m1)
         allocate(d(m1,m1))
         d=matmul(transpose(b),matmul(s,b))
         if(yw)print*,'verif b'
         if(yw)call script4(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 script4(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
      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*,'c proj'
      if(yw)call script4(c,n,m2,n,m2)
      allocate(d(m1,m2))
      d=matmul(transpose(b),matmul(s,c))
      if(yw)print*,'verif bc'
      if(yw)call script4(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)/sqrt(anorm)
      enddo
      if(yw)print*,'c proj norm'
      if(yw)call script4(c,n,m2,n,m2)
      a(:,i2(1:m2))=c(:,:)
         !print*,'a2',a(1,111:112)
      !======================
      !s-1/2 sur les 2eme orb
      !======================
      call smud_bib4(c,n,m2,s)
      allocate(d(m2,m2))
      d=matmul(transpose(c),matmul(s,c))
      if(yw)print*,'verif c'
      if(yw)call script4(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*,'reverif b'
      if(yw)call script4(d,m1,m1,m1,m1)
      deallocate(d)
      deallocate (b)
      !on recompose a
      a(:,i2(1:m2))=c(:,:)
         !print*,'a3',a(1,111:112)
      deallocate (c)
      allocate(d(n,n))
      d=matmul(transpose(a),matmul(s,a))
      if(yw)print*,'verif a'
      if(yw)call script4(d,n,n,n,n)
      deallocate(d)
      deallocate (y)
      deallocate(a,s)
      if(yw)print*,'sortie hier4'
      return
      end
       subroutine smud_bib4(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(16)(a-h,o-x,z),logical(1)(y)
      real(16),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 script4(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 script4(u1,m,m,m,m)
         deallocate (u1)
      endif
      call hdiag4(s,v,n,n)
      s1=0.d0
      do k=1,n
         s1(k,k)=sqrt(s(k,k))
         s(k,k)=1.d0/sqrt(s(k,k))
      enddo
      if(yw)print*,'S'
      if(yw)call script4(s,n,n,n,n)
      if(yw)print*,'S1'
      if(yw)call script4(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 script4(s,n,n,n,n)
      if(yw)print*,'s1'
      if(yw)call script4(s1,n,n,n,n)
      if(yw)print*,'a'
      if(yw)call script4(a,n,m,n,m)
      if(yw) then
         allocate (u1(m,m))
         print*,'recou a 2 '
         u1=matmul(transpose(a),a)
         call script4(u1,m,m,m,m)
         deallocate (u1)
      endif
c
c     orthogonalisation de a
c
      call smudo_bib4(n,m,a1,a)
      if(yw) then
         allocate (u1(m,m))
         print*,'recou a1 '
         u1=matmul(transpose(a1),a1)
         call script4(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_bib4(n,m,a1ext,aext)
      implicit real(16)(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_bib4(n,m,a1ext,aext)
      return
      end
      
       subroutine smudo1_bib4(n,m,a1ext,aext)
      implicit real(16)(a-h,o-x,z),logical(1)(y)
      dimension aext(n,m),a1ext(n,m)
      real(16),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 script4(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=sqrt(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 script4(a,n,n,n,n)
      if(nprint.ge.3) print*,'N',n
      if(nprint.ge.3) print*,'n',n
      if(nprint.ge.3) print*,'a diag'
      if(nprint.ge.3) call script4(a,n,n,n,n)
      if(nprint.ge.3) print*,'vp'
      if(nprint.ge.3) call script4(v,n,n,n,n)
      s=matmul(transpose(a0),a0)
      if(nprint.ge.3) print*,'s'
      if(nprint.ge.3) call script4(s,n,n,n,n)
      call hdiag4(s,vs,m,m)
c      call jacobi(n,s,vs,n)
      if(nprint.ge.3) print*,'s diag'
      if(nprint.ge.3) call script4(s,n,n,n,n)
      if(nprint.ge.3) print*,'vp'
      if(nprint.ge.3) call script4(vs,n,n,n,n)
      do k=1,m
         s(k,k)=1.d0/sqrt(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 script4(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 script4(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 script4(vs,m,m,m,m)
      endif
      a1ext=s1
      deallocate (a,s,vs,a0,s1)
      return
      end
      
      
      
      
