SUBROUTINE Heapsort(K__Number, P__Array, K__Index)

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

IMPLICIT NONE

! Subroutine argunments
INTEGER(KIND=JPIM), INTENT(in)    :: K__Number
REAL(KIND=JPRB),    INTENT(in)    :: P__Array(:)
INTEGER(KIND=JPIM), INTENT(inout) :: K__Index(:)

INTEGER(KIND=JPIM) :: i,j,I__Right,I__Left, idx
REAL(KIND=JPRB) :: Z__Tmp
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!------------------------------------------

IF (LHOOK) CALL DR_HOOK('HEAPSORT',0,ZHOOK_HANDLE)

IF (K__Number <= 1) THEN
   IF (LHOOK) CALL DR_HOOK('HEAPSORT',1,ZHOOK_HANDLE)
   RETURN
ENDIF

I__Left  = K__Number/2+1
I__Right = K__Number

LOOP: DO
   IF (I__Left > 1) THEN
      I__Left = I__Left - 1
      idx  = K__Index(I__Left)
   ELSE
      idx = K__Index(I__Right)
      K__Index(I__Right) = K__Index(1)
      I__Right = I__Right - 1
      if (I__Right == 1) then
         K__Index(1) = idx
         Exit LOOP
      endif
   ENDIF
   Z__Tmp = P__Array(idx)
   i = I__Left
   j = 2*I__Left
   DO WHILE (j <= I__Right)
      IF (j < I__Right) THEN
         IF (P__Array(K__Index(j)) < P__Array(K__Index(j+1))) j = j + 1
      ENDIF
      IF (Z__Tmp < P__Array(K__Index(j))) THEN
         K__Index(i) = K__Index(j)
         i = j
         j = 2*j
      ELSE
         j = I__Right + 1
      ENDIF
   ENDDO
   K__Index(i) = idx
ENDDO LOOP

IF (LHOOK) CALL DR_HOOK('HEAPSORT',1,ZHOOK_HANDLE)

END SUBROUTINE Heapsort

