heap_sort.F [SRC] [CPP] [JOB] [SCAN] SOURCES / FUNCTIONS

```   1 | include(dom.inc)
2 |
3 | !     ===============================================================
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 | !                                                                      !
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:
 Makefile [SOURCES] - 88 meshpartition.F [SOURCES/MAIN/MASTER] - 44 - 79