subroutine orthnorm (pvecs,klen,kvecs)

!-----------------------------------------------------------------------
!   ORTHNORM - orthonormalize vectors

!   Purpose. Orthonormalize pvecs using Householder transformations.
!   -------- This is more stable than the usual modified Gramm-Schmidt
!            method (see Walker J., 1988, SIAM J.Sci.Stat.Comp.,
!            pp 152-163).

!   Interface.
!   ----------
!      CALL ORTHNORM (pvecs,klen,kvecs)

!      Explicit arguments:

!      Inputs:  klen  -- nuumber of elements in each vector
!               kvecs -- number of vectors
!               pvecs -- vectors to be orthonormalized

!      Outputs: pvecs -- orthonormalized vectors

!   Reference.   Walker J., 1988, SIAM J.Sci.Stat.Comp., pp 152-163
!   ----------

!   Author.
!   -------
!       Mike Fisher  *ECMWF*

!   Modifications.
!   --------------
!       Original      96/08/27
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!-----------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

IMPLICIT NONE
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
INTEGER(KIND=JPIM),INTENT(IN)    :: KVECS 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVECS(KLEN,KVECS) 
REAL(KIND=JPRB) :: zsign(kvecs)

INTEGER(KIND=JPIM) :: jj, jk, jl

REAL(KIND=JPRB) :: zdot, zuk
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!--- calculate Householder vectors

IF (LHOOK) CALL DR_HOOK('ORTHNORM',0,ZHOOK_HANDLE)
do jk=1,kvecs
  zdot = 0.0_JPRB
  do jj=jk+1,klen
    zdot = zdot + pvecs(jj,jk)*pvecs(jj,jk)
  enddo

  if (pvecs(jk,jk) < 0.0_JPRB) then
    zsign(jk) = 1.0_JPRB
    pvecs(jk,jk) = pvecs(jk,jk)-sqrt(zdot + pvecs(jk,jk)*pvecs(jk,jk))
  else
    zsign(jk) = -1.0_JPRB
    pvecs(jk,jk) = pvecs(jk,jk)+sqrt(zdot + pvecs(jk,jk)*pvecs(jk,jk))
  endif

  do jj=1,jk-1
    pvecs(jj,jk) = 0.0_JPRB
  enddo

  zdot = zdot + pvecs(jk,jk)*pvecs(jk,jk)

  do jj=jk,klen
    pvecs(jj,jk) = pvecs(jj,jk)*sqrt(2.0_JPRB/zdot)
  enddo

  do jj=jk+1,kvecs
    zdot = 0.0_JPRB
    do jl=jk,klen
      zdot = zdot + pvecs(jl,jk)*pvecs(jl,jj)
    enddo
    do jl=jk,klen
      pvecs(jl,jj) = pvecs(jl,jj) - zdot*pvecs(jl,jk)
    enddo
  enddo
enddo

!--- apply to the identity matrix

do jk=kvecs,1,-1
  do jl=jk+1,kvecs
    zdot = 0.0_JPRB
    do jj=jk,klen
      zdot = zdot + pvecs(jj,jl)*pvecs(jj,jk)
    enddo

    do jj=jk,klen
      pvecs(jj,jl) = pvecs(jj,jl) - zdot*pvecs(jj,jk)
    enddo
  enddo

  zuk = -zsign(jk)*pvecs(jk,jk)
  do jj=jk,klen
    pvecs(jj,jk) = pvecs(jj,jk)*zuk
  enddo

  pvecs(jk,jk) = pvecs(jk,jk) + zsign(jk)
enddo

IF (LHOOK) CALL DR_HOOK('ORTHNORM',1,ZHOOK_HANDLE)
end subroutine orthnorm

