!
!  An example of the heapsort algorithm in FORTRAN-90
!
! $Id: heapsort.f90,v 0.3 2023/03/10 14:15:38 kc4zvw Exp kc4zvw $
!

program Heapsort_Demo

    implicit none

    integer, parameter :: num = 30
    real :: array(num)

    call random_seed
    call random_number(array)

    write(*,*) "A program to heapsort an array of real numbers"
    write(*,*)
    write(*,*) "Unsorted array: "
    call display_numbers(array)

    call heapsort(array)

    write(*,*) "Sorted array: "
    call display_numbers(array)

    write(*,*) "Finished."

contains

subroutine heapsort(a)

    real, intent(in out) :: a(0:)
    integer :: start, n, bottom
    real :: temp

    n = size(a)
    do start = (n - 2) / 2, 0, -1
        call siftdown(a, start, n);
    end do
   
    do bottom = n - 1, 1, -1
        temp = a(0)
        a(0) = a(bottom)
        a(bottom) = temp;
        call siftdown(a, 0, bottom)
    end do

end subroutine heapsort

subroutine siftdown(a, start, bottom)
  
    real, intent(in out) :: a(0:)
    integer, intent(in) :: start, bottom
    integer :: child, root
    real :: temp

    root = start
    do while (root * 2 + 1 < bottom)
        child = root * 2 + 1

        if (child + 1 < bottom) then
            if (a(child) < a(child+1)) child = child + 1
        end if
    
        if (a(root) < a(child)) then
            temp = a(child)
            a(child) = a(root)
            a(root) = temp
            root = child
        else
            return
        end if  
    end do      
    
end subroutine siftdown

subroutine display_numbers(a)

    real, intent(in out) :: a(0:)
    integer :: start, n
    
    n = size(a)
    do start = 0, n - 1, 1
        write(*, 100, advance='no') a(start)
        if (mod(start, 5) == 4) write(*,*)
    end do
    write(*,*)

100 format (' ', F12.6)

end subroutine display_numbers


end program Heapsort_Demo

! ***** End of File *****