var/da/da_tracing/da_trace_real_sort.inc

   1 subroutine da_trace_real_sort(&
   2    key, &
   3    n, &
   4    index)
   5
   6    !-----------------------------------------------------------------------
   7    ! Purpose: Sort reals for tracing
   8    !-----------------------------------------------------------------------
   9
  10    implicit none
  11
  12    integer, intent(in)  :: n      ! The number of items to be sorted.
  13    real,    intent(in)  :: key(:)
  14    integer, intent(out) :: index(:)
  15
  16    integer :: head       ! heaps are tree structures: head and child refer
  17    integer :: child      ! to related items within the tree
  18    integer :: i
  19    integer :: dum        ! used to swap index items
  20
  21    ! initialise index:
  22    do i=1,n
  23       index(i)=i
  24    end do
  25
  26    ! Do heapsort: Create the heap...
  27    makeheap : do i=n/2,1,-1
  28       head=i
  29       sift1 : do
  30          ! find the largest out of the head and its two children...
  31          child=head*2
  32          if (child>n) exit sift1
  33          if (child<n) then
  34             if (key(index(child+1))>key(index(child))) child=child+1
  35          end if
  36          ! if the head is the largest, then sift is done...
  37          if (key(index(head))>=key(index(child))) exit sift1
  38          ! otherwise swap to put the largest child at the head,
  39          ! and prepare to repeat the procedure for the head in its new
  40          ! subordinate position.
  41          dum=index(child)
  42          index(child)=index(head)
  43          index(head)=dum
  44          head=child
  45       end do sift1
  46    end do makeheap
  47
  48    ! Retire heads of the heap, which are the largest, and
  49    ! stack them at the end of the array.
  50
  51    retire : do i=n,2,-1
  52       dum=index(1)
  53       index(1)=index(i)
  54       index(i)=dum
  55       head=1
  56       ! second sift is similar to first...
  57       sift2: do
  58          child=head*2
  59          if (child>(i-1)) exit sift2
  60          if (child<(i-1)) then
  61             if (key(index(child+1))>key(index(child))) child=child+1
  62          end if
  63          if (key(index(head))>=key(index(child))) exit sift2
  64          dum=index(child)
  65          index(child)=index(head)
  66          index(head)=dum
  67          head=child
  68       end do sift2
  69    end do retire
  70
  71 end subroutine da_trace_real_sort
  72
  73