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