1 | include(dom.inc)
2 |
3 | ! ===============================================================
4 | ! Copyright (c) CERFACS (all rights reserved)
5 | ! ===============================================================
6 |
7 |
8 | subroutine heap_sort ( ireal_sort, iorder, in_list, &
9 | & nel, ival, rval, list )
10 |
11 | ! !
12 | ! ******************************************************************** !
13 | ! !
14 | ! Purpose: Sorts a list of objects with associated integer !
15 | ! or real values using the heap sort algorithm. !
16 | ! !
17 | ! Input: A parameter `ireal_sort' that determines if the !
18 | ! list is to be sorted based on real (ireal_sort=1) !
19 | ! or integer values (ireal_sort=0); a parameter !
20 | ! `iorder' gives the order of the sorted list !
21 | ! ( increasing values if iorder = 1, decreasing !
22 | ! values if iorder = -1 ); a parameter 'in_list' that !
23 | ! determines whether an integer pointer array is !
24 | ! provided (in_list=1) or not (in_list=0); the !
25 | ! number of elements in the list `nel'; the !
26 | ! optional integer `ival' or real lists `rval' !
27 | ! that are to be sorted; the optional integer pointer !
28 | ! array `list' ( used if isort_val = -1 ). !
29 | ! !
30 | ! Output: The sorted list, `ival' or `rval' if !
31 | ! isort_val =/= 0; an integer pointer array !
32 | ! `list'. !
33 | ! !
34 | ! Local: --- !
35 | ! !
36 | ! Notes: Algorithm taken from Numerical Recipes. !
37 | ! !
38 | ! Authors: M. Rudgyard !
39 | ! !
40 | ! Checked: 20/4/94 !
41 | ! !
42 | ! Last modified: 20/4/94 !
43 | ! !
44 | ! Changed to f90(fixed): M. Garcia (10/07/2003) !
45 | ! !
46 | ! ******************************************************************** !
47 | ! !
48 | implicit none
49 |
50 | ! IN/OUT
51 | ! ------
52 | DOM_INT, intent(in) :: ireal_sort
53 | DOM_INT, intent(in) :: iorder
54 | DOM_INT, intent(in) :: in_list
55 | DOM_INT, intent(in) :: nel
56 | DOM_INT, dimension(1:*), intent(inout) :: ival
57 | DOM_INT, dimension(1:nel), intent(inout) :: list
58 |
59 | DOM_REAL, dimension(1:*), intent(inout) :: rval
60 |
61 | ! LOCAL
62 | ! -----
63 | DOM_INT :: i, ir, itemp_list, itemp_val, j, l, n
64 | DOM_REAL :: rtemp_val
65 |
66 | ! !
67 | ! ******************************************************************** !
68 |
69 | !----------------------------------------------------------------------!
70 | ! Check input values: !
71 | !----------------------------------------------------------------------!
72 |
73 | if (nel <= 1) return
74 |
75 | if ((in_list /= 1).and.(in_list /= 0)) then
76 |
77 | write(6,*) 'Illegal value for in_list'
78 | write(6,*) '0 <= in_list <= 1 '
79 | stop
80 |
81 | end if
82 |
83 | if (abs(iorder) /= 1) then
84 |
85 | write(6,*) 'Illegal value for iorder'
86 | write(6,*) 'iorder = 1 or iorder = -1 '
87 |
88 | end if
89 |
90 | !----------------------------------------------------------------------!
91 | ! Fill integer pointer list if this is not given: !
92 | !----------------------------------------------------------------------!
93 |
94 | if (in_list == 0) then
95 |
96 | do n = 1, nel
97 |
98 | list(n) = n
99 |
100 | end do
101 |
102 | end if
103 |
104 |
105 | l = nel/2 + 1
106 | ir = nel
107 |
108 | !----------------------------------------------------------------------!
109 | ! Integer sort: !
110 | !----------------------------------------------------------------------!
111 |
112 | if (ireal_sort == 0) then
113 |
114 | do
115 |
116 | if (l > 1) then
117 |
118 | l = l - 1
119 | itemp_val = ival(l)
120 | itemp_list = list(l)
121 |
122 | else
123 |
124 | itemp_val = ival(ir)
125 | itemp_list = list(ir)
126 | ival(ir) = ival(1)
127 | list(ir) = list(1)
128 | ir = ir - 1
129 |
130 | if (ir == 1) then
131 |
132 | ival(1) = itemp_val
133 | list(1) = itemp_list
134 |
135 | if (iorder == -1) then
136 |
137 | do n = 1, nel/2
138 |
139 | itemp_list = list(n)
140 | itemp_val = ival(n)
141 | list(n) = list(nel-n+1)
142 | ival(n) = ival(nel-n+1)
143 | list(nel-n+1) = itemp_list
144 | ival(nel-n+1) = itemp_val
145 |
146 | end do
147 |
148 | end if
149 |
150 | return
151 |
152 | end if
153 |
154 | end if
155 |
156 | i = l
157 | j = l + l
158 |
159 | do while (j <= ir)
160 |
161 | if (j < ir) then
162 |
163 | if (ival(j) < ival(j+1)) j = j + 1
164 |
165 | end if
166 |
167 | if (itemp_val < ival(j)) then
168 |
169 | ival(i) = ival(j)
170 | list(i) = list(j)
171 | i = j
172 | j = j + j
173 |
174 | else
175 |
176 | j = ir + 1
177 |
178 | end if
179 |
180 | end do
181 |
182 | ival(i) = itemp_val
183 | list(i) = itemp_list
184 |
185 | end do
186 |
187 | !----------------------------------------------------------------------!
188 | ! Real sort: !
189 | !----------------------------------------------------------------------!
190 |
191 | else if (ireal_sort == 1) then
192 |
193 | do
194 |
195 | if (l > 1) then
196 |
197 | l = l - 1
198 | rtemp_val = rval(l)
199 | itemp_list = list(l)
200 |
201 | else
202 |
203 | rtemp_val = rval(ir)
204 | itemp_list = list(ir)
205 | rval(ir) = rval(1)
206 | list(ir) = list(1)
207 | ir = ir - 1
208 |
209 | if (ir == 1) then
210 |
211 | rval(1) = rtemp_val
212 | list(1) = itemp_list
213 |
214 | if (iorder == -1) then
215 |
216 | do n = 1, nel/2
217 |
218 | itemp_list = list(n)
219 | rtemp_val = rval(n)
220 | list(n) = list(nel-n+1)
221 | rval(n) = rval(nel-n+1)
222 | list(nel-n+1) = itemp_list
223 | rval(nel-n+1) = rtemp_val
224 |
225 | end do
226 |
227 | end if
228 |
229 | return
230 |
231 | end if
232 |
233 | end if
234 |
235 | i = l
236 | j = l + l
237 |
238 | do while (j <= ir)
239 |
240 | if (j < ir) then
241 |
242 | if (rval(j) < rval(j+1)) j = j + 1
243 |
244 | end if
245 |
246 | if (rtemp_val < rval(j)) then
247 |
248 | rval(i) = rval(j)
249 | list(i) = list(j)
250 | i = j
251 | j = j + j
252 |
253 | else
254 |
255 | j = ir + 1
256 |
257 | end if
258 |
259 | end do
260 |
261 | rval(i) = rtemp_val
262 | list(i) = itemp_list
263 |
264 | end do
265 |
266 | !----------------------------------------------------------------------!
267 | ! Illegal value: !
268 | !----------------------------------------------------------------------!
269 |
270 | else
271 |
272 | write(6,*) 'Illegal value for ireal_sort'
273 | write(6,*) '0 <= ireal_sort <= 1 '
274 | stop
275 |
276 | end if
277 |
278 |
279 | return
280 | end subroutine heap_sort
281 |
heap_sort.F could be called by: