      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
      yw1=.true.
      yw=.true.
      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 ior1,ior2,ior3',ior1,ior2,ior3
      if(yw1)print*,'hier3 n1,n2,n3',n1,n2,n3
      if(yw1)print*,'hier3 m1,m2',m1,m2
      if(yw1)print*,'hier3 npri',npri
      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(yw) print*,' '
      if(yw) print*,'S-1/2 sur les 1ere orb'
      if(ior1==1) then
         if(yw1)print*,'i1',i1
         if(yw1)print*,'i2',i2
         if(yw1)print*,'b  1eres Ol, a orthogonaliser par S-1/2'
         if(yw)call script(b,n,m1,n,m1)
         !if(yw1)print*,'c'
         !if(yw)call script(c,n,m2,n,m2)
         call smud_bib(b,n,m1,s)
         if(yw1)print*,'b apres smud_bib  1ere OL orthogonalisees'
         if(yw)call script(b,n,m1,n,m1)
         allocate(d(m1,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(:,:)
         allocate(d(n,n))
         !d=matmul(transpose(a),matmul(s,a))
         d=matmul(s,a)
         d=matmul(transpose(a),d)
         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)
         !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(yw) print*,' '
      if(yw) print*,'Projection schmidt'
      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(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)
         a(:,i2(1:m2))=c(:,:)

         allocate(d(n,n))
         !d=matmul(transpose(b),matmul(s,c))
         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)
      endif
      !======================
      !s-1/2 sur les 2eme orb
      !======================
      if(ior3==1) then  
         if(yw) print*,' '
         if(yw) print*,'s-1/2 sur les 2eme orb'
         call smud_bib(c,n,m2,s)
         if(yw1)print*,'hier3 (2emes OL apres S-1/2)'
         if(yw)call script(c,n,m2,n,m2)
         allocate(d(m2,m2))
         !d=matmul(transpose(c),matmul(s,c))
         if(yw)print*,'mat de rec S apres smud_bib'
         if(yw) call script(s,n,n,n,n)
         d=matmul(s,c)
         d=matmul(transpose(c),d)
         if(yw1)print*,'hier3 verif rec entre 2emes OL'
         if(yw)call script(d,m2,m2,m2,m2)
         deallocate(d)
         allocate(d(m1,m1))
         print*,'m1,m2,n',m1,m2,n
         d=matmul(transpose(a(:,m2+1:m1+m2)),matmul(s,a(:,m2+1:m1+m2)))
         !d(:,1:m1)=matmul(s,a(:,m2+1:m1+m2))
         !d=matmul(transpose(a(:,m2+1:m1+m2)),d(:,1:m1))
         if(yw1)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))
         d=matmul(s,a)
         d=matmul(transpose(a),d)
         if(yw1)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(yw1)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)
      real(8),allocatable :: work(:,:)
      nprint=0
      yw1=.true.
      yw=.true.
      if(yw1)print*,'entree smud_bib'
      if(n.eq.0) return
      allocate (v(n,n))
      allocate (a1(n,m))
      allocate (s1(n,n))
      allocate (s0(n,n))
      allocate(work(n,n))
      s0=s
      if(yw1) print*,'smud: m,n',m,n
      if(yw1) print*,'smud: a (OL en entree)'
      if(yw) 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 '
      !   work=matmul(s,a)
      !   u1=matmul(transpose(a),work)
      !   !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(yw1)print*,'smud: S (1/sqrt(diagonale de s))'
      if(yw)call script(s,n,n,n,n)
      !if(yw1)print*,'smud: S1 (sqrt(diagonale de s))'
      !if(yw)call script(s1,n,n,n,n)
      !s=matmul(v,matmul(s,transpose(v)))
      !s1=matmul(v,matmul(s1,transpose(v)))
      work=matmul(s,transpose(v))
      s=matmul(v,work)
      work=matmul(s1,transpose(v))
      s1=matmul(v,work)
      !u1=matmul(s,s1)      
c
c     a exprime dans la base orthogonale
c
      a=matmul(s1,a)
      if(yw1)print*,'s  (S-1/2 en base d''OA)'
      if(yw)call script(s,n,n,n,n)
      !if(yw1)print*,'s1'
      !if(yw)call script(s1,n,n,n,n)
      if(yw1)print*,'a  OL a orthogonaliser par S-1/2'
      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)      
      deallocate (work)      
      if(yw)print*,'               '
      if(yw)print*,'sortie smud_bib'
      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
      yw1=.true.
      yw=.true.
      allocate (a(n,m),s(m,m),vs(m,m),a0(n,m),s1(n,m))
      yverif=.false.
      nprint=0
      if(yw1) print*,'N',n
      a=aext
      if(yw1) print*,'a'
      if(yw) call script(a,n,m,n,m)
      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(yw1) print*,'a norm'
      a0=a
      if(yw) call script(a,n,m,n,m)
      if(yw1) print*,'N',n
      if(yw1) print*,'n',n
      if(yw1) print*,'a diag'
      if(yw) call script(a,n,m,n,m)
      s=matmul(transpose(a0),a0)
      if(yw1) print*,'s'
      if(yw) call script(s,m,m,m,m)
      call hdiag(s,vs,m,m)
c      call jacobi(n,s,vs,n)
      if(yw1) print*,'s diag'
      if(yw) call script(s,m,m,m,m)
      if(yw1) print*,'vs'
      if(yw) call script(vs,m,m,m,m)
      do k=1,m
         s(k,k)=1.d0/dsqrt(s(k,k))
      enddo
      !vs=matmul(vs,matmul(s,transpose(vs)))
      s1=matmul(s,transpose(vs))
      vs=matmul(vs,s1)
      if(yw1) print*,'s-1/2 vect orth'
      if(yw) call script(vs,m,m,m,m)
c      vs=matmul(transpose(a),matmul(vs,(a)))
      s1=matmul(a0,vs)
      if(yw1) print*,'S-1/2 vect orth dans base orth'
      if(yw) call script(s1,n,m,n,m)
      if(yverif) then
         vs=matmul(transpose(s1),s1)
         if(yw1) print*,'verif prod scal'
         if(yw) call script(vs,m,m,m,m)
      endif
      a1ext=s1
      deallocate (a,s,vs,a0,s1)
      return
      end
      
      
      
      
